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 because ABE checks and diagnostics are not
2076 -- 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
2278 Var_Attrs
: Variable_Attributes
;
2282 Extract_Variable_Reference_Attributes
2285 Attrs
=> Var_Attrs
);
2287 Marker
:= Make_Variable_Reference_Marker
(Sloc
(N
));
2289 -- Inherit the attributes of the original variable reference
2291 Set_Target
(Marker
, Var_Id
);
2292 Set_Is_Read
(Marker
, Read
);
2293 Set_Is_Write
(Marker
, Write
);
2295 -- The marker is inserted prior to the original variable reference. The
2296 -- insertion must take place even when the reference does not occur in
2297 -- the main unit to keep the tree symmetric. This ensures that internal
2298 -- name serialization is consistent in case the variable marker causes
2299 -- the tree to transform in some way.
2301 Insert_Action
(N
, Marker
);
2303 -- The marker becomes the "corresponding" scenario for the reference.
2304 -- Save the marker for later processing for the ABE phase.
2306 Record_Elaboration_Scenario
(Marker
);
2307 end Build_Variable_Reference_Marker
;
2309 ---------------------------------
2310 -- Check_Elaboration_Scenarios --
2311 ---------------------------------
2313 procedure Check_Elaboration_Scenarios
is
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 because ABE checks and diagnostics are not
2323 -- performed in this mode.
2325 elsif ASIS_Mode
then
2329 -- Restore the original elaboration model which was in effect when the
2330 -- scenarios were first recorded. The model may be specified by pragma
2331 -- Elaboration_Checks which appears on the initial declaration of the
2334 Install_Elaboration_Model
(Unit_Entity
(Cunit_Entity
(Main_Unit
)));
2336 -- Examine the context of the main unit and record all units with prior
2337 -- elaboration with respect to it.
2339 Find_Elaborated_Units
;
2341 -- Examine each top-level scenario saved during the Recording phase for
2342 -- conditional ABEs and perform various actions depending on the model
2343 -- in effect. The table of visited bodies is created for each new top-
2346 for Index
in Top_Level_Scenarios
.First
.. Top_Level_Scenarios
.Last
loop
2347 Reset_Visited_Bodies
;
2349 Process_Conditional_ABE
(Top_Level_Scenarios
.Table
(Index
));
2352 -- Examine each SPARK scenario saved during the Recording phase which
2353 -- is not necessarily executable during elaboration, but still requires
2354 -- elaboration-related checks.
2356 for Index
in SPARK_Scenarios
.First
.. SPARK_Scenarios
.Last
loop
2357 Check_SPARK_Scenario
(SPARK_Scenarios
.Table
(Index
));
2359 end Check_Elaboration_Scenarios
;
2361 ------------------------------
2362 -- Check_Preelaborated_Call --
2363 ------------------------------
2365 procedure Check_Preelaborated_Call
(Call
: Node_Id
) is
2366 function In_Preelaborated_Context
(N
: Node_Id
) return Boolean;
2367 -- Determine whether arbitrary node appears in a preelaborated context
2369 ------------------------------
2370 -- In_Preelaborated_Context --
2371 ------------------------------
2373 function In_Preelaborated_Context
(N
: Node_Id
) return Boolean is
2374 Body_Id
: constant Entity_Id
:= Find_Code_Unit
(N
);
2375 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Body_Id
);
2378 -- The node appears within a package body whose corresponding spec is
2379 -- subject to pragma Remote_Call_Interface or Remote_Types. This does
2380 -- not result in a preelaborated context because the package body may
2381 -- be on another machine.
2383 if Ekind
(Body_Id
) = E_Package_Body
2384 and then Ekind_In
(Spec_Id
, E_Generic_Package
, E_Package
)
2385 and then (Is_Remote_Call_Interface
(Spec_Id
)
2386 or else Is_Remote_Types
(Spec_Id
))
2390 -- Otherwise the node appears within a preelaborated context when the
2391 -- associated unit is preelaborated.
2394 return Is_Preelaborated_Unit
(Spec_Id
);
2396 end In_Preelaborated_Context
;
2400 Call_Attrs
: Call_Attributes
;
2401 Level
: Enclosing_Level_Kind
;
2402 Target_Id
: Entity_Id
;
2404 -- Start of processing for Check_Preelaborated_Call
2407 Extract_Call_Attributes
2409 Target_Id
=> Target_Id
,
2410 Attrs
=> Call_Attrs
);
2412 -- Nothing to do when the call is internally generated because it is
2413 -- assumed that it will never violate preelaboration.
2415 if not Call_Attrs
.From_Source
then
2419 -- Performance note: parent traversal
2421 Level
:= Find_Enclosing_Level
(Call
);
2423 -- Library-level calls are always considered because they are part of
2424 -- the associated unit's elaboration actions.
2426 if Level
in Library_Level
then
2429 -- Calls at the library level of a generic package body must be checked
2430 -- because they would render an instantiation illegal if the template is
2431 -- marked as preelaborated. Note that this does not apply to calls at
2432 -- the library level of a generic package spec.
2434 elsif Level
= Generic_Package_Body
then
2437 -- Otherwise the call does not appear at the proper level and must not
2438 -- be considered for this check.
2444 -- The call appears within a preelaborated unit. Emit a warning only for
2445 -- internal uses, otherwise this is an error.
2447 if In_Preelaborated_Context
(Call
) then
2448 Error_Msg_Warn
:= GNAT_Mode
;
2450 ("<<non-static call not allowed in preelaborated unit", Call
);
2452 end Check_Preelaborated_Call
;
2454 ------------------------------
2455 -- Check_SPARK_Derived_Type --
2456 ------------------------------
2458 procedure Check_SPARK_Derived_Type
(Typ_Decl
: Node_Id
) is
2459 Typ
: constant Entity_Id
:= Defining_Entity
(Typ_Decl
);
2461 -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally
2462 -- unnested to avoid deep indentation of code.
2464 Stop_Check
: exception;
2465 -- This exception is raised when the freeze node violates the placement
2468 procedure Check_Overriding_Primitive
2471 pragma Inline
(Check_Overriding_Primitive
);
2472 -- Verify that freeze node FNode is within the early call region of
2473 -- overriding primitive Prim's body.
2475 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
;
2476 pragma Inline
(Freeze_Node_Location
);
2477 -- Return a more accurate source location associated with freeze node
2480 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean;
2481 pragma Inline
(Precedes_Source_Construct
);
2482 -- Determine whether arbitrary node N appears prior to some source
2485 procedure Suggest_Elaborate_Body
2487 Body_Decl
: Node_Id
;
2488 Error_Nod
: Node_Id
);
2489 pragma Inline
(Suggest_Elaborate_Body
);
2490 -- Suggest the use of pragma Elaborate_Body when the pragma will allow
2491 -- for node N to appear within the early call region of subprogram body
2492 -- Body_Decl. The suggestion is attached to Error_Nod as a continuation
2495 --------------------------------
2496 -- Check_Overriding_Primitive --
2497 --------------------------------
2499 procedure Check_Overriding_Primitive
2503 Prim_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Prim
);
2504 Body_Decl
: Node_Id
;
2505 Body_Id
: Entity_Id
;
2509 -- Nothing to do for predefined primitives because they are artifacts
2510 -- of tagged type expansion and cannot override source primitives.
2512 if Is_Predefined_Dispatching_Operation
(Prim
) then
2516 Body_Id
:= Corresponding_Body
(Prim_Decl
);
2518 -- Nothing to do when the primitive does not have a corresponding
2519 -- body. This can happen when the unit with the bodies is not the
2520 -- main unit subjected to ABE checks.
2522 if No
(Body_Id
) then
2525 -- The primitive overrides a parent or progenitor primitive
2527 elsif Present
(Overridden_Operation
(Prim
)) then
2529 -- Nothing to do when overriding an interface primitive happens by
2530 -- inheriting a non-interface primitive as the check would be done
2531 -- on the parent primitive.
2533 if Present
(Alias
(Prim
)) then
2537 -- Nothing to do when the primitive is not overriding. The body of
2538 -- such a primitive cannot be targeted by a dispatching call which
2539 -- is executable during elaboration, and cannot cause an ABE.
2545 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
2546 Region
:= Find_Early_Call_Region
(Body_Decl
);
2548 -- The freeze node appears prior to the early call region of the
2551 -- IMPORTANT: This check must always be performed even when -gnatd.v
2552 -- (enforce SPARK elaboration rules in SPARK code) is not specified
2553 -- because the static model cannot guarantee the absence of ABEs in
2554 -- in the presence of dispatching calls.
2556 if Earlier_In_Extended_Unit
(FNode
, Region
) then
2557 Error_Msg_Node_2
:= Prim
;
2559 ("first freezing point of type & must appear within early call "
2560 & "region of primitive body & (SPARK RM 7.7(8))",
2563 Error_Msg_Sloc
:= Sloc
(Region
);
2564 Error_Msg_N
("\region starts #", Typ_Decl
);
2566 Error_Msg_Sloc
:= Sloc
(Body_Decl
);
2567 Error_Msg_N
("\region ends #", Typ_Decl
);
2569 Error_Msg_Sloc
:= Freeze_Node_Location
(FNode
);
2570 Error_Msg_N
("\first freezing point #", Typ_Decl
);
2572 -- If applicable, suggest the use of pragma Elaborate_Body in the
2573 -- associated package spec.
2575 Suggest_Elaborate_Body
2577 Body_Decl
=> Body_Decl
,
2578 Error_Nod
=> Typ_Decl
);
2582 end Check_Overriding_Primitive
;
2584 --------------------------
2585 -- Freeze_Node_Location --
2586 --------------------------
2588 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
is
2589 Context
: constant Node_Id
:= Parent
(FNode
);
2590 Loc
: constant Source_Ptr
:= Sloc
(FNode
);
2592 Prv_Decls
: List_Id
;
2593 Vis_Decls
: List_Id
;
2596 -- In general, the source location of the freeze node is as close as
2597 -- possible to the real freeze point, except when the freeze node is
2598 -- at the "bottom" of a package spec.
2600 if Nkind
(Context
) = N_Package_Specification
then
2601 Prv_Decls
:= Private_Declarations
(Context
);
2602 Vis_Decls
:= Visible_Declarations
(Context
);
2604 -- The freeze node appears in the private declarations of the
2607 if Present
(Prv_Decls
)
2608 and then List_Containing
(FNode
) = Prv_Decls
2612 -- The freeze node appears in the visible declarations of the
2613 -- package and there are no private declarations.
2615 elsif Present
(Vis_Decls
)
2616 and then List_Containing
(FNode
) = Vis_Decls
2617 and then (No
(Prv_Decls
) or else Is_Empty_List
(Prv_Decls
))
2621 -- Otherwise the freeze node is not in the "last" declarative list
2622 -- of the package. Use the existing source location of the freeze
2629 -- The freeze node appears at the "bottom" of the package when it
2630 -- is in the "last" declarative list and is either the last in the
2631 -- list or is followed by internal constructs only. In that case
2632 -- the more appropriate source location is that of the package end
2635 if not Precedes_Source_Construct
(FNode
) then
2636 return Sloc
(End_Label
(Context
));
2641 end Freeze_Node_Location
;
2643 -------------------------------
2644 -- Precedes_Source_Construct --
2645 -------------------------------
2647 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean is
2652 while Present
(Decl
) loop
2653 if Comes_From_Source
(Decl
) then
2656 -- A generated body for a source expression function is treated as
2657 -- a source construct.
2659 elsif Nkind
(Decl
) = N_Subprogram_Body
2660 and then Was_Expression_Function
(Decl
)
2661 and then Comes_From_Source
(Original_Node
(Decl
))
2670 end Precedes_Source_Construct
;
2672 ----------------------------
2673 -- Suggest_Elaborate_Body --
2674 ----------------------------
2676 procedure Suggest_Elaborate_Body
2678 Body_Decl
: Node_Id
;
2679 Error_Nod
: Node_Id
)
2681 Unt
: constant Node_Id
:= Unit
(Cunit
(Main_Unit
));
2685 -- The suggestion applies only when the subprogram body resides in a
2686 -- compilation package body, and a pragma Elaborate_Body would allow
2687 -- for the node to appear in the early call region of the subprogram
2688 -- body. This implies that all code from the subprogram body up to
2689 -- the node is preelaborable.
2691 if Nkind
(Unt
) = N_Package_Body
then
2693 -- Find the start of the early call region again assuming that the
2694 -- package spec has pragma Elaborate_Body. Note that the internal
2695 -- data structures are intentionally not updated because this is a
2696 -- speculative search.
2699 Find_Early_Call_Region
2700 (Body_Decl
=> Body_Decl
,
2701 Assume_Elab_Body
=> True,
2702 Skip_Memoization
=> True);
2704 -- If the node appears within the early call region, assuming that
2705 -- the package spec carries pragma Elaborate_Body, then it is safe
2706 -- to suggest the pragma.
2708 if Earlier_In_Extended_Unit
(Region
, N
) then
2709 Error_Msg_Name_1
:= Name_Elaborate_Body
;
2711 ("\consider adding pragma % in spec of unit &",
2712 Error_Nod
, Defining_Entity
(Unt
));
2715 end Suggest_Elaborate_Body
;
2719 FNode
: constant Node_Id
:= Freeze_Node
(Typ
);
2720 Prims
: constant Elist_Id
:= Direct_Primitive_Operations
(Typ
);
2722 Prim_Elmt
: Elmt_Id
;
2724 -- Start of processing for Check_SPARK_Derived_Type
2727 -- A type should have its freeze node set by the time SPARK scenarios
2728 -- are being verified.
2730 pragma Assert
(Present
(FNode
));
2732 -- Verify that the freeze node of the derived type is within the early
2733 -- call region of each overriding primitive body (SPARK RM 7.7(8)).
2735 if Present
(Prims
) then
2736 Prim_Elmt
:= First_Elmt
(Prims
);
2737 while Present
(Prim_Elmt
) loop
2738 Check_Overriding_Primitive
2739 (Prim
=> Node
(Prim_Elmt
),
2742 Next_Elmt
(Prim_Elmt
);
2749 end Check_SPARK_Derived_Type
;
2751 -------------------------------
2752 -- Check_SPARK_Instantiation --
2753 -------------------------------
2755 procedure Check_SPARK_Instantiation
(Exp_Inst
: Node_Id
) is
2756 Gen_Attrs
: Target_Attributes
;
2759 Inst_Attrs
: Instantiation_Attributes
;
2760 Inst_Id
: Entity_Id
;
2763 Extract_Instantiation_Attributes
2764 (Exp_Inst
=> Exp_Inst
,
2768 Attrs
=> Inst_Attrs
);
2770 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
2772 -- The instantiation and the generic body are both in the main unit
2774 if Present
(Gen_Attrs
.Body_Decl
)
2775 and then In_Extended_Main_Code_Unit
(Gen_Attrs
.Body_Decl
)
2777 -- If the instantiation appears prior to the generic body, then the
2778 -- instantiation is illegal (SPARK RM 7.7(6)).
2780 -- IMPORTANT: This check must always be performed even when -gnatd.v
2781 -- (enforce SPARK elaboration rules in SPARK code) is not specified
2782 -- because the rule prevents use-before-declaration of objects that
2783 -- may precede the generic body.
2785 and then Earlier_In_Extended_Unit
(Inst
, Gen_Attrs
.Body_Decl
)
2787 Error_Msg_NE
("cannot instantiate & before body seen", Inst
, Gen_Id
);
2789 end Check_SPARK_Instantiation
;
2791 ---------------------------------
2792 -- Check_SPARK_Model_In_Effect --
2793 ---------------------------------
2795 SPARK_Model_Warning_Posted
: Boolean := False;
2796 -- This flag prevents the same SPARK model-related warning from being
2797 -- emitted multiple times.
2799 procedure Check_SPARK_Model_In_Effect
(N
: Node_Id
) is
2801 -- Do not emit the warning multiple times as this creates useless noise
2803 if SPARK_Model_Warning_Posted
then
2806 -- SPARK rule verification requires the "strict" static model
2808 elsif Static_Elaboration_Checks
and not Relaxed_Elaboration_Checks
then
2811 -- Any other combination of models does not guarantee the absence of ABE
2812 -- problems for SPARK rule verification purposes. Note that there is no
2813 -- need to check for the legacy ABE mechanism because the legacy code
2814 -- has its own orthogonal processing for SPARK rules.
2817 SPARK_Model_Warning_Posted
:= True;
2820 ("??SPARK elaboration checks require static elaboration model", N
);
2822 if Dynamic_Elaboration_Checks
then
2823 Error_Msg_N
("\dynamic elaboration model is in effect", N
);
2825 pragma Assert
(Relaxed_Elaboration_Checks
);
2826 Error_Msg_N
("\relaxed elaboration model is in effect", N
);
2829 end Check_SPARK_Model_In_Effect
;
2831 --------------------------
2832 -- Check_SPARK_Scenario --
2833 --------------------------
2835 procedure Check_SPARK_Scenario
(N
: Node_Id
) is
2837 -- Ensure that a suitable elaboration model is in effect for SPARK rule
2840 Check_SPARK_Model_In_Effect
(N
);
2842 -- Add the current scenario to the stack of active scenarios
2844 Push_Active_Scenario
(N
);
2846 if Is_Suitable_SPARK_Derived_Type
(N
) then
2847 Check_SPARK_Derived_Type
(N
);
2849 elsif Is_Suitable_SPARK_Instantiation
(N
) then
2850 Check_SPARK_Instantiation
(N
);
2852 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
2853 Check_SPARK_Refined_State_Pragma
(N
);
2856 -- Remove the current scenario from the stack of active scenarios once
2857 -- all ABE diagnostics and checks have been performed.
2859 Pop_Active_Scenario
(N
);
2860 end Check_SPARK_Scenario
;
2862 --------------------------------------
2863 -- Check_SPARK_Refined_State_Pragma --
2864 --------------------------------------
2866 procedure Check_SPARK_Refined_State_Pragma
(N
: Node_Id
) is
2868 -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are
2869 -- intentionally unnested to avoid deep indentation of code.
2871 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
);
2872 pragma Inline
(Check_SPARK_Constituent
);
2873 -- Ensure that a single constituent Constit_Id is elaborated prior to
2876 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
);
2877 pragma Inline
(Check_SPARK_Constituents
);
2878 -- Ensure that all constituents found in list Constits are elaborated
2879 -- prior to the main unit.
2881 procedure Check_SPARK_Initialized_State
(State
: Node_Id
);
2882 pragma Inline
(Check_SPARK_Initialized_State
);
2883 -- Ensure that the constituents of single abstract state State are
2884 -- elaborated prior to the main unit.
2886 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
);
2887 pragma Inline
(Check_SPARK_Initialized_States
);
2888 -- Ensure that the constituents of all abstract states which appear in
2889 -- the Initializes pragma of package Pack_Id are elaborated prior to the
2892 -----------------------------
2893 -- Check_SPARK_Constituent --
2894 -----------------------------
2896 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
) is
2900 -- Nothing to do for "null" constituents
2902 if Nkind
(Constit_Id
) = N_Null
then
2905 -- Nothing to do for illegal constituents
2907 elsif Error_Posted
(Constit_Id
) then
2911 Prag
:= SPARK_Pragma
(Constit_Id
);
2913 -- The check applies only when the constituent is subject to pragma
2917 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
2919 -- An external constituent of an abstract state which appears in
2920 -- the Initializes pragma of a package spec imposes an Elaborate
2921 -- requirement on the context of the main unit. Determine whether
2922 -- the context has a pragma strong enough to meet the requirement.
2924 -- IMPORTANT: This check is performed only when -gnatd.v (enforce
2925 -- SPARK elaboration rules in SPARK code) is in effect because the
2926 -- static model can ensure the prior elaboration of the unit which
2927 -- contains a constituent by installing implicit Elaborate pragma.
2929 if Debug_Flag_Dot_V
then
2930 Meet_Elaboration_Requirement
2932 Target_Id
=> Constit_Id
,
2933 Req_Nam
=> Name_Elaborate
);
2935 -- Otherwise ensure that the unit with the external constituent is
2936 -- elaborated prior to the main unit.
2939 Ensure_Prior_Elaboration
2941 Unit_Id
=> Find_Top_Unit
(Constit_Id
),
2942 Prag_Nam
=> Name_Elaborate
,
2943 State
=> Initial_State
);
2946 end Check_SPARK_Constituent
;
2948 ------------------------------
2949 -- Check_SPARK_Constituents --
2950 ------------------------------
2952 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
) is
2953 Constit_Elmt
: Elmt_Id
;
2956 if Present
(Constits
) then
2957 Constit_Elmt
:= First_Elmt
(Constits
);
2958 while Present
(Constit_Elmt
) loop
2959 Check_SPARK_Constituent
(Node
(Constit_Elmt
));
2960 Next_Elmt
(Constit_Elmt
);
2963 end Check_SPARK_Constituents
;
2965 -----------------------------------
2966 -- Check_SPARK_Initialized_State --
2967 -----------------------------------
2969 procedure Check_SPARK_Initialized_State
(State
: Node_Id
) is
2971 State_Id
: Entity_Id
;
2974 -- Nothing to do for "null" initialization items
2976 if Nkind
(State
) = N_Null
then
2979 -- Nothing to do for illegal states
2981 elsif Error_Posted
(State
) then
2985 State_Id
:= Entity_Of
(State
);
2987 -- Sanitize the state
2989 if No
(State_Id
) then
2992 elsif Error_Posted
(State_Id
) then
2995 elsif Ekind
(State_Id
) /= E_Abstract_State
then
2999 -- The check is performed only when the abstract state is subject to
3002 Prag
:= SPARK_Pragma
(State_Id
);
3005 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
3007 Check_SPARK_Constituents
(Refinement_Constituents
(State_Id
));
3009 end Check_SPARK_Initialized_State
;
3011 ------------------------------------
3012 -- Check_SPARK_Initialized_States --
3013 ------------------------------------
3015 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
) is
3016 Prag
: constant Node_Id
:= Get_Pragma
(Pack_Id
, Pragma_Initializes
);
3021 if Present
(Prag
) then
3022 Inits
:= Expression
(Get_Argument
(Prag
, Pack_Id
));
3024 -- Avoid processing a "null" initialization list. The only other
3025 -- alternative is an aggregate.
3027 if Nkind
(Inits
) = N_Aggregate
then
3029 -- The initialization items appear in list form:
3033 if Present
(Expressions
(Inits
)) then
3034 Init
:= First
(Expressions
(Inits
));
3035 while Present
(Init
) loop
3036 Check_SPARK_Initialized_State
(Init
);
3041 -- The initialization items appear in associated form:
3043 -- (state1 => item1,
3044 -- state2 => (item2, item3))
3046 if Present
(Component_Associations
(Inits
)) then
3047 Init
:= First
(Component_Associations
(Inits
));
3048 while Present
(Init
) loop
3049 Check_SPARK_Initialized_State
(Init
);
3055 end Check_SPARK_Initialized_States
;
3059 Pack_Body
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
3061 -- Start of processing for Check_SPARK_Refined_State_Pragma
3064 -- Pragma Refined_State must be associated with a package body
3067 (Present
(Pack_Body
) and then Nkind
(Pack_Body
) = N_Package_Body
);
3069 -- Verify that each external contitunent of an abstract state mentioned
3070 -- in pragma Initializes is properly elaborated.
3072 Check_SPARK_Initialized_States
(Unique_Defining_Entity
(Pack_Body
));
3073 end Check_SPARK_Refined_State_Pragma
;
3075 ----------------------
3076 -- Compilation_Unit --
3077 ----------------------
3079 function Compilation_Unit
(Unit_Id
: Entity_Id
) return Node_Id
is
3080 Comp_Unit
: Node_Id
;
3083 Comp_Unit
:= Parent
(Unit_Id
);
3085 -- Handle the case where a concurrent subunit is rewritten as a null
3086 -- statement due to expansion activities.
3088 if Nkind
(Comp_Unit
) = N_Null_Statement
3089 and then Nkind_In
(Original_Node
(Comp_Unit
), N_Protected_Body
,
3092 Comp_Unit
:= Parent
(Comp_Unit
);
3093 pragma Assert
(Nkind
(Comp_Unit
) = N_Subunit
);
3095 -- Otherwise use the declaration node of the unit
3098 Comp_Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
3101 -- Handle the case where a subprogram instantiation which acts as a
3102 -- compilation unit is expanded into an anonymous package that wraps
3103 -- the instantiated subprogram.
3105 if Nkind
(Comp_Unit
) = N_Package_Specification
3106 and then Nkind_In
(Original_Node
(Parent
(Comp_Unit
)),
3107 N_Function_Instantiation
,
3108 N_Procedure_Instantiation
)
3110 Comp_Unit
:= Parent
(Parent
(Comp_Unit
));
3112 -- Handle the case where the compilation unit is a subunit
3114 elsif Nkind
(Comp_Unit
) = N_Subunit
then
3115 Comp_Unit
:= Parent
(Comp_Unit
);
3118 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
3121 end Compilation_Unit
;
3123 -----------------------
3124 -- Early_Call_Region --
3125 -----------------------
3127 function Early_Call_Region
(Body_Id
: Entity_Id
) return Node_Id
is
3129 pragma Assert
(Ekind_In
(Body_Id
, E_Entry
,
3133 E_Subprogram_Body
));
3135 if Early_Call_Regions_In_Use
then
3136 return Early_Call_Regions
.Get
(Body_Id
);
3139 return Early_Call_Regions_No_Element
;
3140 end Early_Call_Region
;
3142 -----------------------------
3143 -- Early_Call_Regions_Hash --
3144 -----------------------------
3146 function Early_Call_Regions_Hash
3147 (Key
: Entity_Id
) return Early_Call_Regions_Index
3150 return Early_Call_Regions_Index
(Key
mod Early_Call_Regions_Max
);
3151 end Early_Call_Regions_Hash
;
3157 procedure Elab_Msg_NE
3164 function Prefix
return String;
3165 -- Obtain the prefix of the message
3167 function Suffix
return String;
3168 -- Obtain the suffix of the message
3174 function Prefix
return String is
3187 function Suffix
return String is
3196 -- Start of processing for Elab_Msg_NE
3199 Error_Msg_NE
(Prefix
& Msg
& Suffix
, N
, Id
);
3202 ------------------------
3203 -- Elaboration_Status --
3204 ------------------------
3206 function Elaboration_Status
3207 (Unit_Id
: Entity_Id
) return Elaboration_Attributes
3210 if Elaboration_Statuses_In_Use
then
3211 return Elaboration_Statuses
.Get
(Unit_Id
);
3214 return Elaboration_Statuses_No_Element
;
3215 end Elaboration_Status
;
3217 -------------------------------
3218 -- Elaboration_Statuses_Hash --
3219 -------------------------------
3221 function Elaboration_Statuses_Hash
3222 (Key
: Entity_Id
) return Elaboration_Statuses_Index
3225 return Elaboration_Statuses_Index
(Key
mod Elaboration_Statuses_Max
);
3226 end Elaboration_Statuses_Hash
;
3228 ------------------------------
3229 -- Ensure_Prior_Elaboration --
3230 ------------------------------
3232 procedure Ensure_Prior_Elaboration
3234 Unit_Id
: Entity_Id
;
3236 State
: Processing_Attributes
)
3239 pragma Assert
(Nam_In
(Prag_Nam
, Name_Elaborate
, Name_Elaborate_All
));
3241 -- Nothing to do when the caller has suppressed the generation of
3242 -- implicit Elaborate[_All] pragmas.
3244 if State
.Suppress_Implicit_Pragmas
then
3247 -- Nothing to do when the need for prior elaboration came from a partial
3248 -- finalization routine which occurs in an initialization context. This
3249 -- behaviour parallels that of the old ABE mechanism.
3251 elsif State
.Within_Partial_Finalization
then
3254 -- Nothing to do when the need for prior elaboration came from a task
3255 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on
3256 -- task bodies) is in effect.
3258 elsif Debug_Flag_Dot_Y
and then State
.Within_Task_Body
then
3261 -- Nothing to do when the unit is elaborated prior to the main unit.
3262 -- This check must also consider the following cases:
3264 -- * No check is made against the context of the main unit because this
3265 -- is specific to the elaboration model in effect and requires custom
3266 -- handling (see Ensure_xxx_Prior_Elaboration).
3268 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
3269 -- Elaborate[_All] MUST be generated even though Unit_Id is always
3270 -- elaborated prior to the main unit. This is a conservative strategy
3271 -- which ensures that other units withed by Unit_Id will not lead to
3274 -- package A is package body A is
3275 -- procedure ABE; procedure ABE is ... end ABE;
3279 -- package B is package body B is
3280 -- pragma Elaborate_Body; procedure Proc is
3282 -- procedure Proc; A.ABE;
3283 -- package B; end Proc;
3287 -- package C is package body C is
3293 -- In the example above, the elaboration of C invokes B.Proc. B is
3294 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is
3295 -- generated for B in C, then the following elaboratio order will lead
3298 -- spec of A elaborated
3299 -- spec of B elaborated
3300 -- body of B elaborated
3301 -- spec of C elaborated
3302 -- body of C elaborated <-- calls B.Proc which calls A.ABE
3303 -- body of A elaborated <-- problem
3305 -- The generation of an implicit pragma Elaborate_All (B) ensures that
3306 -- the elaboration order mechanism will not pick the above order.
3308 -- An implicit Elaborate is NOT generated when the unit is subject to
3309 -- Elaborate_Body because both pragmas have the exact same effect.
3311 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST
3312 -- NOT be generated in this case because a unit cannot depend on its
3313 -- own elaboration. This case is therefore treated as valid prior
3316 elsif Has_Prior_Elaboration
3317 (Unit_Id
=> Unit_Id
,
3318 Same_Unit_OK
=> True,
3319 Elab_Body_OK
=> Prag_Nam
= Name_Elaborate
)
3323 -- Suggest the use of pragma Prag_Nam when the dynamic model is in
3326 elsif Dynamic_Elaboration_Checks
then
3327 Ensure_Prior_Elaboration_Dynamic
3330 Prag_Nam
=> Prag_Nam
);
3332 -- Install an implicit pragma Prag_Nam when the static model is in
3336 pragma Assert
(Static_Elaboration_Checks
);
3338 Ensure_Prior_Elaboration_Static
3341 Prag_Nam
=> Prag_Nam
);
3343 end Ensure_Prior_Elaboration
;
3345 --------------------------------------
3346 -- Ensure_Prior_Elaboration_Dynamic --
3347 --------------------------------------
3349 procedure Ensure_Prior_Elaboration_Dynamic
3351 Unit_Id
: Entity_Id
;
3354 procedure Info_Missing_Pragma
;
3355 pragma Inline
(Info_Missing_Pragma
);
3356 -- Output information concerning missing Elaborate or Elaborate_All
3357 -- pragma with name Prag_Nam for scenario N, which would ensure the
3358 -- prior elaboration of Unit_Id.
3360 -------------------------
3361 -- Info_Missing_Pragma --
3362 -------------------------
3364 procedure Info_Missing_Pragma
is
3366 -- Internal units are ignored as they cause unnecessary noise
3368 if not In_Internal_Unit
(Unit_Id
) then
3370 -- The name of the unit subjected to the elaboration pragma is
3371 -- fully qualified to improve the clarity of the info message.
3373 Error_Msg_Name_1
:= Prag_Nam
;
3374 Error_Msg_Qual_Level
:= Nat
'Last;
3376 Error_Msg_NE
("info: missing pragma % for unit &", N
, Unit_Id
);
3377 Error_Msg_Qual_Level
:= 0;
3379 end Info_Missing_Pragma
;
3383 Elab_Attrs
: Elaboration_Attributes
;
3384 Level
: Enclosing_Level_Kind
;
3386 -- Start of processing for Ensure_Prior_Elaboration_Dynamic
3389 Elab_Attrs
:= Elaboration_Status
(Unit_Id
);
3391 -- Nothing to do when the unit is guaranteed prior elaboration by means
3392 -- of a source Elaborate[_All] pragma.
3394 if Present
(Elab_Attrs
.Source_Pragma
) then
3398 -- Output extra information on a missing Elaborate[_All] pragma when
3399 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
3402 if Elab_Info_Messages
then
3404 -- Performance note: parent traversal
3406 Level
:= Find_Enclosing_Level
(N
);
3408 -- Declaration-level scenario
3410 if (Is_Suitable_Call
(N
) or else Is_Suitable_Instantiation
(N
))
3411 and then Level
= Declaration_Level
3415 -- Library-level scenario
3417 elsif Level
in Library_Level
then
3420 -- Instantiation library-level scenario
3422 elsif Level
= Instantiation
then
3425 -- Otherwise the scenario does not appear at the proper level and
3426 -- cannot possibly act as a top-level scenario.
3432 Info_Missing_Pragma
;
3434 end Ensure_Prior_Elaboration_Dynamic
;
3436 -------------------------------------
3437 -- Ensure_Prior_Elaboration_Static --
3438 -------------------------------------
3440 procedure Ensure_Prior_Elaboration_Static
3442 Unit_Id
: Entity_Id
;
3445 function Find_With_Clause
3447 Withed_Id
: Entity_Id
) return Node_Id
;
3448 pragma Inline
(Find_With_Clause
);
3449 -- Find a nonlimited with clause in the list of context items Items
3450 -- that withs unit Withed_Id. Return Empty if no such clause is found.
3452 procedure Info_Implicit_Pragma
;
3453 pragma Inline
(Info_Implicit_Pragma
);
3454 -- Output information concerning an implicitly generated Elaborate or
3455 -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures
3456 -- the prior elaboration of unit Unit_Id.
3458 ----------------------
3459 -- Find_With_Clause --
3460 ----------------------
3462 function Find_With_Clause
3464 Withed_Id
: Entity_Id
) return Node_Id
3469 -- Examine the context clauses looking for a suitable with. Note that
3470 -- limited clauses do not affect the elaboration order.
3472 Item
:= First
(Items
);
3473 while Present
(Item
) loop
3474 if Nkind
(Item
) = N_With_Clause
3475 and then not Error_Posted
(Item
)
3476 and then not Limited_Present
(Item
)
3477 and then Entity
(Name
(Item
)) = Withed_Id
3486 end Find_With_Clause
;
3488 --------------------------
3489 -- Info_Implicit_Pragma --
3490 --------------------------
3492 procedure Info_Implicit_Pragma
is
3494 -- Internal units are ignored as they cause unnecessary noise
3496 if not In_Internal_Unit
(Unit_Id
) then
3498 -- The name of the unit subjected to the elaboration pragma is
3499 -- fully qualified to improve the clarity of the info message.
3501 Error_Msg_Name_1
:= Prag_Nam
;
3502 Error_Msg_Qual_Level
:= Nat
'Last;
3505 ("info: implicit pragma % generated for unit &", N
, Unit_Id
);
3507 Error_Msg_Qual_Level
:= 0;
3508 Output_Active_Scenarios
(N
);
3510 end Info_Implicit_Pragma
;
3514 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
3515 Loc
: constant Source_Ptr
:= Sloc
(Main_Cunit
);
3516 Unit_Cunit
: constant Node_Id
:= Compilation_Unit
(Unit_Id
);
3519 Elab_Attrs
: Elaboration_Attributes
;
3522 -- Start of processing for Ensure_Prior_Elaboration_Static
3525 Elab_Attrs
:= Elaboration_Status
(Unit_Id
);
3527 -- Nothing to do when the unit is guaranteed prior elaboration by means
3528 -- of a source Elaborate[_All] pragma.
3530 if Present
(Elab_Attrs
.Source_Pragma
) then
3533 -- Nothing to do when the unit has an existing implicit Elaborate[_All]
3534 -- pragma installed by a previous scenario.
3536 elsif Present
(Elab_Attrs
.With_Clause
) then
3538 -- The unit is already guaranteed prior elaboration by means of an
3539 -- implicit Elaborate pragma, however the current scenario imposes
3540 -- a stronger requirement of Elaborate_All. "Upgrade" the existing
3541 -- pragma to match this new requirement.
3543 if Elaborate_Desirable
(Elab_Attrs
.With_Clause
)
3544 and then Prag_Nam
= Name_Elaborate_All
3546 Set_Elaborate_All_Desirable
(Elab_Attrs
.With_Clause
);
3547 Set_Elaborate_Desirable
(Elab_Attrs
.With_Clause
, False);
3553 -- At this point it is known that the unit has no prior elaboration
3554 -- according to pragmas and hierarchical relationships.
3556 Items
:= Context_Items
(Main_Cunit
);
3560 Set_Context_Items
(Main_Cunit
, Items
);
3563 -- Locate the with clause for the unit. Note that there may not be a
3564 -- clause if the unit is visible through a subunit-body, body-spec, or
3565 -- spec-parent relationship.
3570 Withed_Id
=> Unit_Id
);
3575 -- Note that adding implicit with clauses is safe because analysis,
3576 -- resolution, and expansion have already taken place and it is not
3577 -- possible to interfere with visibility.
3581 Make_With_Clause
(Loc
,
3582 Name
=> New_Occurrence_Of
(Unit_Id
, Loc
));
3584 Set_Implicit_With
(Clause
);
3585 Set_Library_Unit
(Clause
, Unit_Cunit
);
3587 Append_To
(Items
, Clause
);
3590 -- Mark the with clause depending on the pragma required
3592 if Prag_Nam
= Name_Elaborate
then
3593 Set_Elaborate_Desirable
(Clause
);
3595 Set_Elaborate_All_Desirable
(Clause
);
3598 -- The implicit Elaborate[_All] ensures the prior elaboration of the
3599 -- unit. Include the unit in the elaboration context of the main unit.
3601 Set_Elaboration_Status
3602 (Unit_Id
=> Unit_Id
,
3603 Val
=> Elaboration_Attributes
'(Source_Pragma => Empty,
3604 With_Clause => Clause));
3606 -- Output extra information on an implicit Elaborate[_All] pragma when
3607 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is
3610 if Elab_Info_Messages then
3611 Info_Implicit_Pragma;
3613 end Ensure_Prior_Elaboration_Static;
3615 -----------------------------
3616 -- Extract_Assignment_Name --
3617 -----------------------------
3619 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is
3625 -- When the name denotes an array or record component, find the whole
3628 while Nkind_In (Nam, N_Explicit_Dereference,
3629 N_Indexed_Component,
3630 N_Selected_Component,
3633 Nam := Prefix (Nam);
3637 end Extract_Assignment_Name;
3639 -----------------------------
3640 -- Extract_Call_Attributes --
3641 -----------------------------
3643 procedure Extract_Call_Attributes
3645 Target_Id : out Entity_Id;
3646 Attrs : out Call_Attributes)
3648 From_Source : Boolean;
3649 In_Declarations : Boolean;
3650 Is_Dispatching : Boolean;
3653 -- Extraction for call markers
3655 if Nkind (Call) = N_Call_Marker then
3656 Target_Id := Target (Call);
3657 From_Source := Is_Source_Call (Call);
3658 In_Declarations := Is_Declaration_Level_Node (Call);
3659 Is_Dispatching := Is_Dispatching_Call (Call);
3661 -- Extraction for entry calls, requeue, and subprogram calls
3664 pragma Assert (Nkind_In (Call, N_Entry_Call_Statement,
3666 N_Procedure_Call_Statement,
3667 N_Requeue_Statement));
3669 Target_Id := Entity (Extract_Call_Name (Call));
3670 From_Source := Comes_From_Source (Call);
3672 -- Performance note: parent traversal
3674 In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level;
3676 Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
3677 and then Present (Controlling_Argument (Call));
3680 -- Obtain the original entry or subprogram which the target may rename
3681 -- except when the target is an instantiation. In this case the alias
3682 -- is the internally generated subprogram which appears within the the
3683 -- anonymous package created for the instantiation. Such an alias is not
3684 -- a suitable target.
3686 if not (Is_Subprogram (Target_Id)
3687 and then Is_Generic_Instance (Target_Id))
3689 Target_Id := Get_Renamed_Entity (Target_Id);
3692 -- Set all attributes
3694 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call);
3695 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call);
3696 Attrs.From_Source := From_Source;
3697 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call);
3698 Attrs.In_Declarations := In_Declarations;
3699 Attrs.Is_Dispatching := Is_Dispatching;
3700 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call);
3701 end Extract_Call_Attributes;
3703 -----------------------
3704 -- Extract_Call_Name --
3705 -----------------------
3707 function Extract_Call_Name (Call : Node_Id) return Node_Id is
3713 -- When the call invokes an entry family, the name appears as an indexed
3716 if Nkind (Nam) = N_Indexed_Component then
3717 Nam := Prefix (Nam);
3720 -- When the call employs the object.operation form, the name appears as
3721 -- a selected component.
3723 if Nkind (Nam) = N_Selected_Component then
3724 Nam := Selector_Name (Nam);
3728 end Extract_Call_Name;
3730 ---------------------------------
3731 -- Extract_Instance_Attributes --
3732 ---------------------------------
3734 procedure Extract_Instance_Attributes
3735 (Exp_Inst : Node_Id;
3736 Inst_Body : out Node_Id;
3737 Inst_Decl : out Node_Id)
3739 Body_Id : Entity_Id;
3742 -- Assume that the attributes are unavailable
3747 -- Generic package or subprogram spec
3749 if Nkind_In (Exp_Inst, N_Package_Declaration,
3750 N_Subprogram_Declaration)
3752 Inst_Decl := Exp_Inst;
3753 Body_Id := Corresponding_Body (Inst_Decl);
3755 if Present (Body_Id) then
3756 Inst_Body := Unit_Declaration_Node (Body_Id);
3759 -- Generic package or subprogram body
3763 (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body));
3765 Inst_Body := Exp_Inst;
3766 Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body));
3768 end Extract_Instance_Attributes;
3770 --------------------------------------
3771 -- Extract_Instantiation_Attributes --
3772 --------------------------------------
3774 procedure Extract_Instantiation_Attributes
3775 (Exp_Inst : Node_Id;
3777 Inst_Id : out Entity_Id;
3778 Gen_Id : out Entity_Id;
3779 Attrs : out Instantiation_Attributes)
3782 Inst := Original_Node (Exp_Inst);
3783 Inst_Id := Defining_Entity (Inst);
3785 -- Traverse a possible chain of renamings to obtain the original generic
3786 -- being instantiatied.
3788 Gen_Id := Get_Renamed_Entity (Entity (Name (Inst)));
3790 -- Set all attributes
3792 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst);
3793 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst);
3794 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst);
3795 Attrs.In_Declarations := Is_Declaration_Level_Node (Inst);
3796 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst);
3797 end Extract_Instantiation_Attributes;
3799 -------------------------------
3800 -- Extract_Target_Attributes --
3801 -------------------------------
3803 procedure Extract_Target_Attributes
3804 (Target_Id : Entity_Id;
3805 Attrs : out Target_Attributes)
3807 procedure Extract_Package_Or_Subprogram_Attributes
3808 (Spec_Id : out Entity_Id;
3809 Body_Decl : out Node_Id);
3810 -- Obtain the attributes associated with a package or a subprogram.
3811 -- Spec_Id is the package or subprogram. Body_Decl is the declaration
3812 -- of the corresponding package or subprogram body.
3814 procedure Extract_Protected_Entry_Attributes
3815 (Spec_Id : out Entity_Id;
3816 Body_Decl : out Node_Id;
3817 Body_Barf : out Node_Id);
3818 -- Obtain the attributes associated with a protected entry [family].
3819 -- Spec_Id is the entity of the protected body subprogram. Body_Decl
3820 -- is the declaration of Spec_Id's corresponding body. Body_Barf is
3821 -- the declaration of the barrier function body.
3823 procedure Extract_Protected_Subprogram_Attributes
3824 (Spec_Id : out Entity_Id;
3825 Body_Decl : out Node_Id);
3826 -- Obtain the attributes associated with a protected subprogram. Formal
3827 -- Spec_Id is the entity of the protected body subprogram. Body_Decl is
3828 -- the declaration of Spec_Id's corresponding body.
3830 procedure Extract_Task_Entry_Attributes
3831 (Spec_Id : out Entity_Id;
3832 Body_Decl : out Node_Id);
3833 -- Obtain the attributes associated with a task entry [family]. Formal
3834 -- Spec_Id is the entity of the task body procedure. Body_Decl is the
3835 -- declaration of Spec_Id's corresponding body.
3837 ----------------------------------------------
3838 -- Extract_Package_Or_Subprogram_Attributes --
3839 ----------------------------------------------
3841 procedure Extract_Package_Or_Subprogram_Attributes
3842 (Spec_Id : out Entity_Id;
3843 Body_Decl : out Node_Id)
3845 Body_Id : Entity_Id;
3846 Init_Id : Entity_Id;
3847 Spec_Decl : Node_Id;
3850 -- Assume that the body is not available
3853 Spec_Id := Target_Id;
3855 -- For body retrieval purposes, the entity of the initial declaration
3856 -- is that of the spec.
3860 -- The only exception to the above is a function which returns a
3861 -- constrained array type in a SPARK-to-C compilation. In this case
3862 -- the function receives a corresponding procedure which has an out
3863 -- parameter. The proper body for ABE checks and diagnostics is that
3864 -- of the procedure.
3866 if Ekind (Init_Id) = E_Function
3867 and then Rewritten_For_C (Init_Id)
3869 Init_Id := Corresponding_Procedure (Init_Id);
3872 -- Extract the attributes of the body
3874 Spec_Decl := Unit_Declaration_Node (Init_Id);
3876 -- The initial declaration is a stand alone subprogram body
3878 if Nkind (Spec_Decl) = N_Subprogram_Body then
3879 Body_Decl := Spec_Decl;
3881 -- Otherwise the package or subprogram has a spec and a completing
3884 elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
3885 N_Generic_Subprogram_Declaration,
3886 N_Package_Declaration,
3887 N_Subprogram_Body_Stub,
3888 N_Subprogram_Declaration)
3890 Body_Id := Corresponding_Body (Spec_Decl);
3892 if Present (Body_Id) then
3893 Body_Decl := Unit_Declaration_Node (Body_Id);
3896 end Extract_Package_Or_Subprogram_Attributes;
3898 ----------------------------------------
3899 -- Extract_Protected_Entry_Attributes --
3900 ----------------------------------------
3902 procedure Extract_Protected_Entry_Attributes
3903 (Spec_Id : out Entity_Id;
3904 Body_Decl : out Node_Id;
3905 Body_Barf : out Node_Id)
3907 Barf_Id : Entity_Id;
3908 Body_Id : Entity_Id;
3911 -- Assume that the bodies are not available
3916 -- When the entry [family] has already been expanded, it carries both
3917 -- the procedure which emulates the behavior of the entry [family] as
3918 -- well as the barrier function.
3920 if Present (Protected_Body_Subprogram (Target_Id)) then
3921 Spec_Id := Protected_Body_Subprogram (Target_Id);
3923 -- Extract the attributes of the barrier function
3927 (Unit_Declaration_Node (Barrier_Function (Target_Id)));
3929 if Present (Barf_Id) then
3930 Body_Barf := Unit_Declaration_Node (Barf_Id);
3933 -- Otherwise no expansion took place
3936 Spec_Id := Target_Id;
3939 -- Extract the attributes of the entry body
3941 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
3943 if Present (Body_Id) then
3944 Body_Decl := Unit_Declaration_Node (Body_Id);
3946 end Extract_Protected_Entry_Attributes;
3948 ---------------------------------------------
3949 -- Extract_Protected_Subprogram_Attributes --
3950 ---------------------------------------------
3952 procedure Extract_Protected_Subprogram_Attributes
3953 (Spec_Id : out Entity_Id;
3954 Body_Decl : out Node_Id)
3956 Body_Id : Entity_Id;
3959 -- Assume that the body is not available
3963 -- When the protected subprogram has already been expanded, it
3964 -- carries the subprogram which seizes the lock and invokes the
3965 -- original statements.
3967 if Present (Protected_Subprogram (Target_Id)) then
3969 Protected_Body_Subprogram (Protected_Subprogram (Target_Id));
3971 -- Otherwise no expansion took place
3974 Spec_Id := Target_Id;
3977 -- Extract the attributes of the body
3979 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
3981 if Present (Body_Id) then
3982 Body_Decl := Unit_Declaration_Node (Body_Id);
3984 end Extract_Protected_Subprogram_Attributes;
3986 -----------------------------------
3987 -- Extract_Task_Entry_Attributes --
3988 -----------------------------------
3990 procedure Extract_Task_Entry_Attributes
3991 (Spec_Id : out Entity_Id;
3992 Body_Decl : out Node_Id)
3994 Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id));
3995 Body_Id : Entity_Id;
3998 -- Assume that the body is not available
4002 -- The the task type has already been expanded, it carries the
4003 -- procedure which emulates the behavior of the task body.
4005 if Present (Task_Body_Procedure (Task_Typ)) then
4006 Spec_Id := Task_Body_Procedure (Task_Typ);
4008 -- Otherwise no expansion took place
4011 Spec_Id := Task_Typ;
4014 -- Extract the attributes of the body
4016 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4018 if Present (Body_Id) then
4019 Body_Decl := Unit_Declaration_Node (Body_Id);
4021 end Extract_Task_Entry_Attributes;
4025 Prag : constant Node_Id := SPARK_Pragma (Target_Id);
4026 Body_Barf : Node_Id;
4027 Body_Decl : Node_Id;
4028 Spec_Id : Entity_Id;
4030 -- Start of processing for Extract_Target_Attributes
4033 -- Assume that the body of the barrier function is not available
4037 -- The target is a protected entry [family]
4039 if Is_Protected_Entry (Target_Id) then
4040 Extract_Protected_Entry_Attributes
4041 (Spec_Id => Spec_Id,
4042 Body_Decl => Body_Decl,
4043 Body_Barf => Body_Barf);
4045 -- The target is a protected subprogram
4047 elsif Is_Protected_Subp (Target_Id)
4048 or else Is_Protected_Body_Subp (Target_Id)
4050 Extract_Protected_Subprogram_Attributes
4051 (Spec_Id => Spec_Id,
4052 Body_Decl => Body_Decl);
4054 -- The target is a task entry [family]
4056 elsif Is_Task_Entry (Target_Id) then
4057 Extract_Task_Entry_Attributes
4058 (Spec_Id => Spec_Id,
4059 Body_Decl => Body_Decl);
4061 -- Otherwise the target is a package or a subprogram
4064 Extract_Package_Or_Subprogram_Attributes
4065 (Spec_Id => Spec_Id,
4066 Body_Decl => Body_Decl);
4069 -- Set all attributes
4071 Attrs.Body_Barf := Body_Barf;
4072 Attrs.Body_Decl := Body_Decl;
4073 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id);
4074 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Target_Id);
4075 Attrs.From_Source := Comes_From_Source (Target_Id);
4076 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id);
4077 Attrs.SPARK_Mode_On :=
4078 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
4079 Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id);
4080 Attrs.Spec_Id := Spec_Id;
4081 Attrs.Unit_Id := Find_Top_Unit (Target_Id);
4083 -- At this point certain attributes should always be available
4085 pragma Assert (Present (Attrs.Spec_Decl));
4086 pragma Assert (Present (Attrs.Spec_Id));
4087 pragma Assert (Present (Attrs.Unit_Id));
4088 end Extract_Target_Attributes;
4090 -----------------------------
4091 -- Extract_Task_Attributes --
4092 -----------------------------
4094 procedure Extract_Task_Attributes
4096 Attrs : out Task_Attributes)
4098 Task_Typ : constant Entity_Id := Non_Private_View (Typ);
4100 Body_Decl : Node_Id;
4101 Body_Id : Entity_Id;
4103 Spec_Id : Entity_Id;
4106 -- Assume that the body of the task procedure is not available
4110 -- The initial declaration is that of the task body procedure
4112 Spec_Id := Get_Task_Body_Procedure (Task_Typ);
4113 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4115 if Present (Body_Id) then
4116 Body_Decl := Unit_Declaration_Node (Body_Id);
4119 Prag := SPARK_Pragma (Task_Typ);
4121 -- Set all attributes
4123 Attrs.Body_Decl := Body_Decl;
4124 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ);
4125 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Task_Typ);
4126 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ);
4127 Attrs.SPARK_Mode_On :=
4128 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
4129 Attrs.Spec_Id := Spec_Id;
4130 Attrs.Task_Decl := Declaration_Node (Task_Typ);
4131 Attrs.Unit_Id := Find_Top_Unit (Task_Typ);
4133 -- At this point certain attributes should always be available
4135 pragma Assert (Present (Attrs.Spec_Id));
4136 pragma Assert (Present (Attrs.Task_Decl));
4137 pragma Assert (Present (Attrs.Unit_Id));
4138 end Extract_Task_Attributes;
4140 -------------------------------------------
4141 -- Extract_Variable_Reference_Attributes --
4142 -------------------------------------------
4144 procedure Extract_Variable_Reference_Attributes
4146 Var_Id : out Entity_Id;
4147 Attrs : out Variable_Attributes)
4149 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id;
4150 -- Obtain the ultimate renamed variable of variable Id
4152 --------------------------
4153 -- Get_Renamed_Variable --
4154 --------------------------
4156 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is
4161 while Present (Renamed_Entity (Ren_Id))
4162 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity
4164 Ren_Id := Renamed_Entity (Ren_Id);
4168 end Get_Renamed_Variable;
4170 -- Start of processing for Extract_Variable_Reference_Attributes
4173 -- Extraction for variable reference markers
4175 if Nkind (Ref) = N_Variable_Reference_Marker then
4176 Var_Id := Target (Ref);
4178 -- Extraction for expanded names and identifiers
4181 Var_Id := Entity (Ref);
4184 -- Obtain the original variable which the reference mentions
4186 Var_Id := Get_Renamed_Variable (Var_Id);
4187 Attrs.Unit_Id := Find_Top_Unit (Var_Id);
4189 -- At this point certain attributes should always be available
4191 pragma Assert (Present (Attrs.Unit_Id));
4192 end Extract_Variable_Reference_Attributes;
4194 --------------------
4195 -- Find_Code_Unit --
4196 --------------------
4198 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is
4200 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N))));
4203 ----------------------------
4204 -- Find_Early_Call_Region --
4205 ----------------------------
4207 function Find_Early_Call_Region
4208 (Body_Decl : Node_Id;
4209 Assume_Elab_Body : Boolean := False;
4210 Skip_Memoization : Boolean := False) return Node_Id
4212 -- NOTE: The routines within Find_Early_Call_Region are intentionally
4213 -- unnested to avoid deep indentation of code.
4215 ECR_Found : exception;
4216 -- This exception is raised when the early call region has been found
4218 Start : Node_Id := Empty;
4219 -- The start of the early call region. This variable is updated by the
4220 -- various nested routines. Due to the use of exceptions, the variable
4221 -- must be global to the nested routines.
4223 -- The algorithm implemented in this routine attempts to find the early
4224 -- call region of a subprogram body by inspecting constructs in reverse
4225 -- declarative order, while navigating the tree. The algorithm consists
4226 -- of an Inspection phase and an Advancement phase. The pseudocode is as
4231 -- advancement phase
4234 -- The infinite loop is terminated by raising exception ECR_Found. The
4235 -- algorithm utilizes two pointers, Curr and Start, to represent the
4236 -- current construct to inspect and the start of the early call region.
4238 -- IMPORTANT: The algorithm must maintain the following invariant at all
4239 -- time for it to function properly - a nested construct is entered only
4240 -- when it contains suitable constructs. This guarantees that leaving a
4241 -- nested or encapsulating construct functions properly.
4243 -- The Inspection phase determines whether the current construct is non-
4244 -- preelaborable, and if it is, the algorithm terminates.
4246 -- The Advancement phase walks the tree in reverse declarative order,
4247 -- while entering and leaving nested and encapsulating constructs. It
4248 -- may also terminate the elaborithm. There are several special cases
4255 -- <construct N-1> <- Curr
4256 -- <construct N> <- Start
4257 -- <subprogram body>
4259 -- In the general case, a declarative or statement list is traversed in
4260 -- reverse order where Curr is the lead pointer, and Start indicates the
4261 -- last preelaborable construct.
4263 -- 2) Entering handled bodies
4265 -- package body Nested is <- Curr (2.3)
4266 -- <declarations> <- Curr (2.2)
4268 -- <statements> <- Curr (2.1)
4270 -- <construct> <- Start
4272 -- In this case, the algorithm enters a handled body by starting from
4273 -- the last statement (2.1), or the last declaration (2.2), or the body
4274 -- is consumed (2.3) because it is empty and thus preelaborable.
4276 -- 3) Entering package declarations
4278 -- package Nested is <- Curr (2.3)
4279 -- <visible declarations> <- Curr (2.2)
4281 -- <private declarations> <- Curr (2.1)
4283 -- <construct> <- Start
4285 -- In this case, the algorithm enters a package declaration by starting
4286 -- from the last private declaration (2.1), the last visible declaration
4287 -- (2.2), or the package is consumed (2.3) because it is empty and thus
4290 -- 4) Transitioning from list to list of the same construct
4292 -- Certain constructs have two eligible lists. The algorithm must thus
4293 -- transition from the second to the first list when the second list is
4296 -- declare <- Curr (4.2)
4297 -- <declarations> <- Curr (4.1)
4299 -- <statements> <- Start
4302 -- In this case, the algorithm has exhausted the second list (statements
4303 -- in the example), and continues with the last declaration (4.1) or the
4304 -- construct is consumed (4.2) because it contains only preelaborable
4307 -- 5) Transitioning from list to construct
4309 -- tack body Task is <- Curr (5.1)
4311 -- <construct 1> <- Start
4313 -- In this case, the algorithm has exhausted a list, Curr is Empty, and
4314 -- the owner of the list is consumed (5.1).
4316 -- 6) Transitioning from unit to unit
4318 -- A package body with a spec subject to pragma Elaborate_Body extends
4319 -- the possible range of the early call region to the package spec.
4321 -- package Pack is <- Curr (6.3)
4322 -- pragma Elaborate_Body; <- Curr (6.2)
4323 -- <visible declarations> <- Curr (6.2)
4325 -- <private declarations> <- Curr (6.1)
4328 -- package body Pack is <- Curr, Start
4330 -- In this case, the algorithm has reached a package body compilation
4331 -- unit whose spec is subject to pragma Elaborate_Body, or the caller
4332 -- of the algorithm has specified this behavior. This transition is
4333 -- equivalent to 3).
4335 -- 7) Transitioning from unit to termination
4337 -- Reaching a compilation unit always terminates the algorithm as there
4338 -- are no more lists to examine. This must take 6) into account.
4340 -- 8) Transitioning from subunit to stub
4342 -- package body Pack is separate; <- Curr (8.1)
4345 -- package body Pack is <- Curr, Start
4347 -- Reaching a subunit continues the search from the corresponding stub
4350 procedure Advance (Curr : in out Node_Id);
4351 pragma Inline (Advance);
4352 -- Update the Curr and Start pointers depending on their location in the
4353 -- tree to the next eligible construct. This routine raises ECR_Found.
4355 procedure Enter_Handled_Body (Curr : in out Node_Id);
4356 pragma Inline (Enter_Handled_Body);
4357 -- Update the Curr and Start pointers to enter a nested handled body if
4358 -- applicable. This routine raises ECR_Found.
4360 procedure Enter_Package_Declaration (Curr : in out Node_Id);
4361 pragma Inline (Enter_Package_Declaration);
4362 -- Update the Curr and Start pointers to enter a nested package spec if
4363 -- applicable. This routine raises ECR_Found.
4365 function Find_ECR (N : Node_Id) return Node_Id;
4366 pragma Inline (Find_ECR);
4367 -- Find an early call region starting from arbitrary node N
4369 function Has_Suitable_Construct (List : List_Id) return Boolean;
4370 pragma Inline (Has_Suitable_Construct);
4371 -- Determine whether list List contains at least one suitable construct
4372 -- for inclusion into an early call region.
4374 procedure Include (N : Node_Id; Curr : out Node_Id);
4375 pragma Inline (Include);
4376 -- Update the Curr and Start pointers to include arbitrary construct N
4377 -- in the early call region. This routine raises ECR_Found.
4379 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean;
4380 pragma Inline (Is_OK_Preelaborable_Construct);
4381 -- Determine whether arbitrary node N denotes a preelaboration-safe
4384 function Is_Suitable_Construct (N : Node_Id) return Boolean;
4385 pragma Inline (Is_Suitable_Construct);
4386 -- Determine whether arbitrary node N denotes a suitable construct for
4387 -- inclusion into the early call region.
4389 procedure Transition_Body_Declarations
4391 Curr : out Node_Id);
4392 pragma Inline (Transition_Body_Declarations);
4393 -- Update the Curr and Start pointers when construct Bod denotes a block
4394 -- statement or a suitable body. This routine raises ECR_Found.
4396 procedure Transition_Handled_Statements
4398 Curr : out Node_Id);
4399 pragma Inline (Transition_Handled_Statements);
4400 -- Update the Curr and Start pointers when node HSS denotes a handled
4401 -- sequence of statements. This routine raises ECR_Found.
4403 procedure Transition_Spec_Declarations
4405 Curr : out Node_Id);
4406 pragma Inline (Transition_Spec_Declarations);
4407 -- Update the Curr and Start pointers when construct Spec denotes
4408 -- a concurrent definition or a package spec. This routine raises
4411 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id);
4412 pragma Inline (Transition_Unit);
4413 -- Update the Curr and Start pointers when node Unit denotes a potential
4414 -- compilation unit. This routine raises ECR_Found.
4420 procedure Advance (Curr : in out Node_Id) is
4424 -- Curr denotes one of the following cases upon entry into this
4427 -- * Empty - There is no current construct when a declarative or a
4428 -- statement list has been exhausted. This does not necessarily
4429 -- indicate that the early call region has been computed as it
4430 -- may still be possible to transition to another list.
4432 -- * Encapsulator - The current construct encapsulates declarations
4433 -- and/or statements. This indicates that the early call region
4434 -- may extend within the nested construct.
4436 -- * Preelaborable - The current construct is always preelaborable
4437 -- because Find_ECR would not invoke Advance if this was not the
4440 -- The current construct is an encapsulator or is preelaborable
4442 if Present (Curr) then
4444 -- Enter encapsulators by inspecting their declarations and/or
4447 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then
4448 Enter_Handled_Body (Curr);
4450 elsif Nkind (Curr) = N_Package_Declaration then
4451 Enter_Package_Declaration (Curr);
4453 -- Early call regions have a property which can be exploited to
4454 -- optimize the algorithm.
4456 -- <preceding subprogram body>
4457 -- <preelaborable construct 1>
4459 -- <preelaborable construct N>
4460 -- <initiating subprogram body>
4462 -- If a traversal initiated from a subprogram body reaches a
4463 -- preceding subprogram body, then both bodies share the same
4464 -- early call region.
4466 -- The property results in the following desirable effects:
4468 -- * If the preceding body already has an early call region, then
4469 -- the initiating body can reuse it. This minimizes the amount
4470 -- of processing performed by the algorithm.
4472 -- * If the preceding body lack an early call region, then the
4473 -- algorithm can compute the early call region, and reuse it
4474 -- for the initiating body. This processing performs the same
4475 -- amount of work, but has the beneficial effect of computing
4476 -- the early call regions of all preceding bodies.
4478 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then
4480 Find_Early_Call_Region
4482 Assume_Elab_Body => Assume_Elab_Body,
4483 Skip_Memoization => Skip_Memoization);
4487 -- Otherwise current construct is preelaborable. Unpdate the early
4488 -- call region to include it.
4491 Include (Curr, Curr);
4494 -- Otherwise the current construct is missing, indicating that the
4495 -- current list has been exhausted. Depending on the context of the
4496 -- list, several transitions are possible.
4499 -- The invariant of the algorithm ensures that Curr and Start are
4500 -- at the same level of nesting at the point of a transition. The
4501 -- algorithm can determine which list the traversal came from by
4504 Context := Parent (Start);
4506 -- Attempt the following transitions:
4508 -- private declarations -> visible declarations
4509 -- private declarations -> upper level
4510 -- private declarations -> terminate
4511 -- visible declarations -> upper level
4512 -- visible declarations -> terminate
4514 if Nkind_In (Context, N_Package_Specification,
4515 N_Protected_Definition,
4518 Transition_Spec_Declarations (Context, Curr);
4520 -- Attempt the following transitions:
4522 -- statements -> declarations
4523 -- statements -> upper level
4524 -- statements -> corresponding package spec (Elab_Body)
4525 -- statements -> terminate
4527 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
4528 Transition_Handled_Statements (Context, Curr);
4530 -- Attempt the following transitions:
4532 -- declarations -> upper level
4533 -- declarations -> corresponding package spec (Elab_Body)
4534 -- declarations -> terminate
4536 elsif Nkind_In (Context, N_Block_Statement,
4543 Transition_Body_Declarations (Context, Curr);
4545 -- Otherwise it is not possible to transition. Stop the search
4546 -- because there are no more declarations or statements to check.
4554 --------------------------
4555 -- Enter_Handled_Body --
4556 --------------------------
4558 procedure Enter_Handled_Body (Curr : in out Node_Id) is
4559 Decls : constant List_Id := Declarations (Curr);
4560 HSS : constant Node_Id := Handled_Statement_Sequence (Curr);
4561 Stmts : List_Id := No_List;
4564 if Present (HSS) then
4565 Stmts := Statements (HSS);
4568 -- The handled body has a non-empty statement sequence. The construct
4569 -- to inspect is the last statement.
4571 if Has_Suitable_Construct (Stmts) then
4572 Curr := Last (Stmts);
4574 -- The handled body lacks statements, but has non-empty declarations.
4575 -- The construct to inspect is the last declaration.
4577 elsif Has_Suitable_Construct (Decls) then
4578 Curr := Last (Decls);
4580 -- Otherwise the handled body lacks both declarations and statements.
4581 -- The construct to inspect is the node which precedes the handled
4582 -- body. Update the early call region to include the handled body.
4585 Include (Curr, Curr);
4587 end Enter_Handled_Body;
4589 -------------------------------
4590 -- Enter_Package_Declaration --
4591 -------------------------------
4593 procedure Enter_Package_Declaration (Curr : in out Node_Id) is
4594 Pack_Spec : constant Node_Id := Specification (Curr);
4595 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec);
4596 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec);
4599 -- The package has a non-empty private declarations. The construct to
4600 -- inspect is the last private declaration.
4602 if Has_Suitable_Construct (Prv_Decls) then
4603 Curr := Last (Prv_Decls);
4605 -- The package lacks private declarations, but has non-empty visible
4606 -- declarations. In this case the construct to inspect is the last
4607 -- visible declaration.
4609 elsif Has_Suitable_Construct (Vis_Decls) then
4610 Curr := Last (Vis_Decls);
4612 -- Otherwise the package lacks any declarations. The construct to
4613 -- inspect is the node which precedes the package. Update the early
4614 -- call region to include the package declaration.
4617 Include (Curr, Curr);
4619 end Enter_Package_Declaration;
4625 function Find_ECR (N : Node_Id) return Node_Id is
4629 -- The early call region starts at N
4634 -- Inspect each node in reverse declarative order while going in and
4635 -- out of nested and enclosing constructs. Note that the only way to
4636 -- terminate this infinite loop is to raise exception ECR_Found.
4639 -- The current construct is not preelaboration-safe. Terminate the
4643 and then not Is_OK_Preelaborable_Construct (Curr)
4648 -- Advance to the next suitable construct. This may terminate the
4649 -- traversal by raising ECR_Found.
4659 ----------------------------
4660 -- Has_Suitable_Construct --
4661 ----------------------------
4663 function Has_Suitable_Construct (List : List_Id) return Boolean is
4667 -- Examine the list in reverse declarative order, looking for a
4668 -- suitable construct.
4670 if Present (List) then
4671 Item := Last (List);
4672 while Present (Item) loop
4673 if Is_Suitable_Construct (Item) then
4682 end Has_Suitable_Construct;
4688 procedure Include (N : Node_Id; Curr : out Node_Id) is
4692 -- The input node is a compilation unit. This terminates the search
4693 -- because there are no more lists to inspect and there are no more
4694 -- enclosing constructs to climb up to. The transitions are:
4696 -- private declarations -> terminate
4697 -- visible declarations -> terminate
4698 -- statements -> terminate
4699 -- declarations -> terminate
4701 if Nkind (Parent (Start)) = N_Compilation_Unit then
4704 -- Otherwise the input node is still within some list
4707 Curr := Prev (Start);
4711 -----------------------------------
4712 -- Is_OK_Preelaborable_Construct --
4713 -----------------------------------
4715 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is
4717 -- Assignment statements are acceptable as long as they were produced
4718 -- by the ABE mechanism to update elaboration flags.
4720 if Nkind (N) = N_Assignment_Statement then
4721 return Is_Elaboration_Code (N);
4723 -- Block statements are acceptable even though they directly violate
4724 -- preelaborability. The intention is not to penalize the early call
4725 -- region when a block contains only preelaborable constructs.
4728 -- Val : constant Integer := 1;
4730 -- pragma Assert (Val = 1);
4734 -- Note that the Advancement phase does enter blocks, and will detect
4735 -- any non-preelaborable declarations or statements within.
4737 elsif Nkind (N) = N_Block_Statement then
4741 -- Otherwise the construct must be preelaborable. The check must take
4742 -- the syntactic and semantic structure of the construct. DO NOT use
4743 -- Is_Preelaborable_Construct here.
4745 return not Is_Non_Preelaborable_Construct (N);
4746 end Is_OK_Preelaborable_Construct;
4748 ---------------------------
4749 -- Is_Suitable_Construct --
4750 ---------------------------
4752 function Is_Suitable_Construct (N : Node_Id) return Boolean is
4753 Context : constant Node_Id := Parent (N);
4756 -- An internally-generated statement sequence which contains only a
4757 -- single null statement is not a suitable construct because it is a
4758 -- byproduct of the parser. Such a null statement should be excluded
4759 -- from the early call region because it carries the source location
4760 -- of the "end" keyword, and may lead to confusing diagnistics.
4762 if Nkind (N) = N_Null_Statement
4763 and then not Comes_From_Source (N)
4764 and then Present (Context)
4765 and then Nkind (Context) = N_Handled_Sequence_Of_Statements
4766 and then not Comes_From_Source (N)
4771 -- Otherwise only constructs which correspond to pure Ada constructs
4772 -- are considered suitable.
4777 | N_Freeze_Generic_Entity
4778 | N_Implicit_Label_Declaration
4780 | N_Pop_Constraint_Error_Label
4781 | N_Pop_Program_Error_Label
4782 | N_Pop_Storage_Error_Label
4783 | N_Push_Constraint_Error_Label
4784 | N_Push_Program_Error_Label
4785 | N_Push_Storage_Error_Label
4786 | N_SCIL_Dispatch_Table_Tag_Init
4787 | N_SCIL_Dispatching_Call
4788 | N_SCIL_Membership_Test
4789 | N_Variable_Reference_Marker
4796 end Is_Suitable_Construct;
4798 ----------------------------------
4799 -- Transition_Body_Declarations --
4800 ----------------------------------
4802 procedure Transition_Body_Declarations
4806 Decls : constant List_Id := Declarations (Bod);
4809 -- The search must come from the declarations of the body
4812 (Is_Non_Empty_List (Decls)
4813 and then List_Containing (Start) = Decls);
4815 -- The search finished inspecting the declarations. The construct
4816 -- to inspect is the node which precedes the handled body, unless
4817 -- the body is a compilation unit. The transitions are:
4819 -- declarations -> upper level
4820 -- declarations -> corresponding package spec (Elab_Body)
4821 -- declarations -> terminate
4823 Transition_Unit (Bod, Curr);
4824 end Transition_Body_Declarations;
4826 -----------------------------------
4827 -- Transition_Handled_Statements --
4828 -----------------------------------
4830 procedure Transition_Handled_Statements
4834 Bod : constant Node_Id := Parent (HSS);
4835 Decls : constant List_Id := Declarations (Bod);
4836 Stmts : constant List_Id := Statements (HSS);
4839 -- The search must come from the statements of certain bodies or
4842 pragma Assert (Nkind_In (Bod, N_Block_Statement,
4849 -- The search must come from the statements of the handled sequence
4852 (Is_Non_Empty_List (Stmts)
4853 and then List_Containing (Start) = Stmts);
4855 -- The search finished inspecting the statements. The handled body
4856 -- has non-empty declarations. The construct to inspect is the last
4857 -- declaration. The transitions are:
4859 -- statements -> declarations
4861 if Has_Suitable_Construct (Decls) then
4862 Curr := Last (Decls);
4864 -- Otherwise the handled body lacks declarations. The construct to
4865 -- inspect is the node which precedes the handled body, unless the
4866 -- body is a compilation unit. The transitions are:
4868 -- statements -> upper level
4869 -- statements -> corresponding package spec (Elab_Body)
4870 -- statements -> terminate
4873 Transition_Unit (Bod, Curr);
4875 end Transition_Handled_Statements;
4877 ----------------------------------
4878 -- Transition_Spec_Declarations --
4879 ----------------------------------
4881 procedure Transition_Spec_Declarations
4885 Prv_Decls : constant List_Id := Private_Declarations (Spec);
4886 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
4889 pragma Assert (Present (Start) and then Is_List_Member (Start));
4891 -- The search came from the private declarations and finished their
4894 if Has_Suitable_Construct (Prv_Decls)
4895 and then List_Containing (Start) = Prv_Decls
4897 -- The context has non-empty visible declarations. The node to
4898 -- inspect is the last visible declaration. The transitions are:
4900 -- private declarations -> visible declarations
4902 if Has_Suitable_Construct (Vis_Decls) then
4903 Curr := Last (Vis_Decls);
4905 -- Otherwise the context lacks visible declarations. The construct
4906 -- to inspect is the node which precedes the context unless the
4907 -- context is a compilation unit. The transitions are:
4909 -- private declarations -> upper level
4910 -- private declarations -> terminate
4913 Transition_Unit (Parent (Spec), Curr);
4916 -- The search came from the visible declarations and finished their
4917 -- inspections. The construct to inspect is the node which precedes
4918 -- the context, unless the context is a compilaton unit. The
4921 -- visible declarations -> upper level
4922 -- visible declarations -> terminate
4924 elsif Has_Suitable_Construct (Vis_Decls)
4925 and then List_Containing (Start) = Vis_Decls
4927 Transition_Unit (Parent (Spec), Curr);
4929 -- At this point both declarative lists are empty, but the traversal
4930 -- still came from within the spec. This indicates that the invariant
4931 -- of the algorithm has been violated.
4934 pragma Assert (False);
4937 end Transition_Spec_Declarations;
4939 ---------------------
4940 -- Transition_Unit --
4941 ---------------------
4943 procedure Transition_Unit
4947 Context : constant Node_Id := Parent (Unit);
4950 -- The unit is a compilation unit. This terminates the search because
4951 -- there are no more lists to inspect and there are no more enclosing
4952 -- constructs to climb up to.
4954 if Nkind (Context) = N_Compilation_Unit then
4956 -- A package body with a corresponding spec subject to pragma
4957 -- Elaborate_Body is an exception to the above. The annotation
4958 -- allows the search to continue into the package declaration.
4959 -- The transitions are:
4961 -- statements -> corresponding package spec (Elab_Body)
4962 -- declarations -> corresponding package spec (Elab_Body)
4964 if Nkind (Unit) = N_Package_Body
4965 and then (Assume_Elab_Body
4966 or else Has_Pragma_Elaborate_Body
4967 (Corresponding_Spec (Unit)))
4969 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit));
4970 Enter_Package_Declaration (Curr);
4972 -- Otherwise terminate the search. The transitions are:
4974 -- private declarations -> terminate
4975 -- visible declarations -> terminate
4976 -- statements -> terminate
4977 -- declarations -> terminate
4983 -- The unit is a subunit. The construct to inspect is the node which
4984 -- precedes the corresponding stub. Update the early call region to
4985 -- include the unit.
4987 elsif Nkind (Context) = N_Subunit then
4989 Curr := Corresponding_Stub (Context);
4991 -- Otherwise the unit is nested. The construct to inspect is the node
4992 -- which precedes the unit. Update the early call region to include
4996 Include (Unit, Curr);
4998 end Transition_Unit;
5002 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
5005 -- Start of processing for Find_Early_Call_Region
5008 -- The caller demands the start of the early call region without saving
5009 -- or retrieving it to/from internal data structures.
5011 if Skip_Memoization then
5012 Region := Find_ECR (Body_Decl);
5017 -- Check whether the early call region of the subprogram body is
5020 Region := Early_Call_Region (Body_Id);
5024 -- Traverse the declarations in reverse order, starting from the
5025 -- subprogram body, searching for the nearest non-preelaborable
5026 -- construct. The early call region starts after this construct
5027 -- and ends at the subprogram body.
5029 Region := Find_ECR (Body_Decl);
5031 -- Associate the early call region with the subprogram body in
5032 -- case other scenarios need it.
5034 Set_Early_Call_Region (Body_Id, Region);
5038 -- A subprogram body must always have an early call region
5040 pragma Assert (Present (Region));
5043 end Find_Early_Call_Region;
5045 ---------------------------
5046 -- Find_Elaborated_Units --
5047 ---------------------------
5049 procedure Find_Elaborated_Units is
5050 procedure Add_Pragma (Prag : Node_Id);
5051 -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma.
5052 -- If this is the case, add the related unit to the elaboration context.
5053 -- For pragma Elaborate_All, include recursively all units withed by the
5057 (Unit_Id : Entity_Id;
5059 Full_Context : Boolean);
5060 -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma
5061 -- which prompted the inclusion of the unit to the elaboration context.
5062 -- If flag Full_Context is set, examine the nonlimited clauses of unit
5063 -- Unit_Id and add each withed unit to the context.
5065 procedure Find_Elaboration_Context (Comp_Unit : Node_Id);
5066 -- Examine the context items of compilation unit Comp_Unit for suitable
5067 -- elaboration-related pragmas and add all related units to the context.
5073 procedure Add_Pragma (Prag : Node_Id) is
5074 Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag);
5075 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
5079 -- Nothing to do if the pragma is not related to elaboration
5081 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then
5084 -- Nothing to do when the pragma is illegal
5086 elsif Error_Posted (Prag) then
5090 Unit_Arg := Get_Pragma_Arg (First (Prag_Args));
5092 -- The argument of the pragma may appear in package.package form
5094 if Nkind (Unit_Arg) = N_Selected_Component then
5095 Unit_Arg := Selector_Name (Unit_Arg);
5099 (Unit_Id => Entity (Unit_Arg),
5101 Full_Context => Prag_Nam = Name_Elaborate_All);
5109 (Unit_Id : Entity_Id;
5111 Full_Context : Boolean)
5114 Elab_Attrs : Elaboration_Attributes;
5117 -- Nothing to do when some previous error left a with clause or a
5118 -- pragma in a bad state.
5120 if No (Unit_Id) then
5124 Elab_Attrs := Elaboration_Status (Unit_Id);
5126 -- The unit is already included in the context by means of pragma
5129 if Present (Elab_Attrs.Source_Pragma) then
5131 -- Upgrade an existing pragma Elaborate when the unit is subject
5132 -- to Elaborate_All because the new pragma covers a larger set of
5135 if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate
5136 and then Pragma_Name (Prag) = Name_Elaborate_All
5138 Elab_Attrs.Source_Pragma := Prag;
5140 -- Otherwise the unit retains its existing pragma and does not
5141 -- need to be included in the context again.
5147 -- The current unit is not part of the context. Prepare a new set of
5152 Elaboration_Attributes'(Source_Pragma
=> Prag
,
5153 With_Clause
=> Empty
);
5156 -- Add or update the attributes of the unit
5158 Set_Elaboration_Status
(Unit_Id
, Elab_Attrs
);
5160 -- Includes all units withed by the current one when computing the
5163 if Full_Context
then
5165 -- Process all nonlimited with clauses found in the context of
5166 -- the current unit. Note that limited clauses do not impose an
5167 -- elaboration order.
5169 Clause
:= First
(Context_Items
(Compilation_Unit
(Unit_Id
)));
5170 while Present
(Clause
) loop
5171 if Nkind
(Clause
) = N_With_Clause
5172 and then not Error_Posted
(Clause
)
5173 and then not Limited_Present
(Clause
)
5176 (Unit_Id
=> Entity
(Name
(Clause
)),
5178 Full_Context
=> Full_Context
);
5186 ------------------------------
5187 -- Find_Elaboration_Context --
5188 ------------------------------
5190 procedure Find_Elaboration_Context
(Comp_Unit
: Node_Id
) is
5194 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
5196 -- Process all elaboration-related pragmas found in the context of
5197 -- the compilation unit.
5199 Prag
:= First
(Context_Items
(Comp_Unit
));
5200 while Present
(Prag
) loop
5201 if Nkind
(Prag
) = N_Pragma
then
5207 end Find_Elaboration_Context
;
5214 -- Start of processing for Find_Elaborated_Units
5217 -- Perform a traversal which examines the context of the main unit and
5218 -- populates the Elaboration_Context table with all units elaborated
5219 -- prior to the main unit. The traversal performs the following jumps:
5221 -- subunit -> parent subunit
5222 -- parent subunit -> body
5224 -- spec -> parent spec
5225 -- parent spec -> grandparent spec and so on
5227 -- The traversal relies on units rather than scopes because the scope of
5228 -- a subunit is some spec, while this traversal must process the body as
5229 -- well. Given that protected and task bodies can also be subunits, this
5230 -- complicates the scope approach even further.
5232 Unt
:= Unit
(Cunit
(Main_Unit
));
5234 -- Perform the following traversals when the main unit is a subunit
5236 -- subunit -> parent subunit
5237 -- parent subunit -> body
5239 while Present
(Unt
) and then Nkind
(Unt
) = N_Subunit
loop
5240 Find_Elaboration_Context
(Parent
(Unt
));
5242 -- Continue the traversal by going to the unit which contains the
5243 -- corresponding stub.
5245 if Present
(Corresponding_Stub
(Unt
)) then
5246 Unt
:= Unit
(Cunit
(Get_Source_Unit
(Corresponding_Stub
(Unt
))));
5248 -- Otherwise the subunit may be erroneous or left in a bad state
5255 -- Perform the following traversal now that subunits have been taken
5256 -- care of, or the main unit is a body.
5261 and then Nkind_In
(Unt
, N_Package_Body
, N_Subprogram_Body
)
5263 Find_Elaboration_Context
(Parent
(Unt
));
5265 -- Continue the traversal by going to the unit which contains the
5266 -- corresponding spec.
5268 if Present
(Corresponding_Spec
(Unt
)) then
5269 Unt
:= Unit
(Cunit
(Get_Source_Unit
(Corresponding_Spec
(Unt
))));
5273 -- Perform the following traversals now that the body has been taken
5274 -- care of, or the main unit is a spec.
5276 -- spec -> parent spec
5277 -- parent spec -> grandparent spec and so on
5280 and then Nkind_In
(Unt
, N_Generic_Package_Declaration
,
5281 N_Generic_Subprogram_Declaration
,
5282 N_Package_Declaration
,
5283 N_Subprogram_Declaration
)
5285 Find_Elaboration_Context
(Parent
(Unt
));
5287 -- Process a potential chain of parent units which ends with the
5288 -- main unit spec. The traversal can now safely rely on the scope
5291 Par_Id
:= Scope
(Defining_Entity
(Unt
));
5292 while Present
(Par_Id
) and then Par_Id
/= Standard_Standard
loop
5293 Find_Elaboration_Context
(Compilation_Unit
(Par_Id
));
5295 Par_Id
:= Scope
(Par_Id
);
5298 end Find_Elaborated_Units
;
5300 -----------------------------
5301 -- Find_Enclosing_Instance --
5302 -----------------------------
5304 function Find_Enclosing_Instance
(N
: Node_Id
) return Node_Id
is
5306 Spec_Id
: Entity_Id
;
5309 -- Climb the parent chain looking for an enclosing instance spec or body
5312 while Present
(Par
) loop
5314 -- Generic package or subprogram spec
5316 if Nkind_In
(Par
, N_Package_Declaration
,
5317 N_Subprogram_Declaration
)
5318 and then Is_Generic_Instance
(Defining_Entity
(Par
))
5322 -- Generic package or subprogram body
5324 elsif Nkind_In
(Par
, N_Package_Body
, N_Subprogram_Body
) then
5325 Spec_Id
:= Corresponding_Spec
(Par
);
5327 if Present
(Spec_Id
) and then Is_Generic_Instance
(Spec_Id
) then
5332 Par
:= Parent
(Par
);
5336 end Find_Enclosing_Instance
;
5338 --------------------------
5339 -- Find_Enclosing_Level --
5340 --------------------------
5342 function Find_Enclosing_Level
(N
: Node_Id
) return Enclosing_Level_Kind
is
5343 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
;
5344 -- Obtain the corresponding level of unit Unit
5350 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
is
5351 Spec_Id
: Entity_Id
;
5354 if Nkind
(Unit
) in N_Generic_Instantiation
then
5355 return Instantiation
;
5357 elsif Nkind
(Unit
) = N_Generic_Package_Declaration
then
5358 return Generic_Package_Spec
;
5360 elsif Nkind
(Unit
) = N_Package_Declaration
then
5361 return Package_Spec
;
5363 elsif Nkind
(Unit
) = N_Package_Body
then
5364 Spec_Id
:= Corresponding_Spec
(Unit
);
5366 -- The body belongs to a generic package
5368 if Present
(Spec_Id
)
5369 and then Ekind
(Spec_Id
) = E_Generic_Package
5371 return Generic_Package_Body
;
5373 -- Otherwise the body belongs to a non-generic package. This also
5374 -- treats an illegal package body without a corresponding spec as
5375 -- a non-generic package body.
5378 return Package_Body
;
5391 -- Start of processing for Find_Enclosing_Level
5394 -- Call markers and instantiations which appear at the declaration level
5395 -- but are later relocated in a different context retain their original
5396 -- declaration level.
5398 if Nkind_In
(N
, N_Call_Marker
,
5399 N_Function_Instantiation
,
5400 N_Package_Instantiation
,
5401 N_Procedure_Instantiation
)
5402 and then Is_Declaration_Level_Node
(N
)
5404 return Declaration_Level
;
5407 -- Climb the parent chain looking at the enclosing levels
5410 Curr
:= Parent
(Prev
);
5411 while Present
(Curr
) loop
5413 -- A traversal from a subunit continues via the corresponding stub
5415 if Nkind
(Curr
) = N_Subunit
then
5416 Curr
:= Corresponding_Stub
(Curr
);
5418 -- The current construct is a package. Packages are ignored because
5419 -- they are always elaborated when the enclosing context is invoked
5422 elsif Nkind_In
(Curr
, N_Package_Body
, N_Package_Declaration
) then
5425 -- The current construct is a block statement
5427 elsif Nkind
(Curr
) = N_Block_Statement
then
5429 -- Ignore internally generated blocks created by the expander for
5430 -- various purposes such as abort defer/undefer.
5432 if not Comes_From_Source
(Curr
) then
5435 -- If the traversal came from the handled sequence of statments,
5436 -- then the node appears at the level of the enclosing construct.
5437 -- This is a more reliable test because transients scopes within
5438 -- the declarative region of the encapsulator are hard to detect.
5440 elsif Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
5441 and then Handled_Statement_Sequence
(Curr
) = Prev
5443 return Find_Enclosing_Level
(Parent
(Curr
));
5445 -- Otherwise the traversal came from the declarations, the node is
5446 -- at the declaration level.
5449 return Declaration_Level
;
5452 -- The current construct is a declaration-level encapsulator
5454 elsif Nkind_In
(Curr
, N_Entry_Body
,
5458 -- If the traversal came from the handled sequence of statments,
5459 -- then the node cannot possibly appear at any level. This is
5460 -- a more reliable test because transients scopes within the
5461 -- declarative region of the encapsulator are hard to detect.
5463 if Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
5464 and then Handled_Statement_Sequence
(Curr
) = Prev
5468 -- Otherwise the traversal came from the declarations, the node is
5469 -- at the declaration level.
5472 return Declaration_Level
;
5475 -- The current construct is a non-library-level encapsulator which
5476 -- indicates that the node cannot possibly appear at any level.
5477 -- Note that this check must come after the declaration-level check
5478 -- because both predicates share certain nodes.
5480 elsif Is_Non_Library_Level_Encapsulator
(Curr
) then
5481 Context
:= Parent
(Curr
);
5483 -- The sole exception is when the encapsulator is the compilation
5484 -- utit itself because the compilation unit node requires special
5485 -- processing (see below).
5487 if Present
(Context
)
5488 and then Nkind
(Context
) = N_Compilation_Unit
5492 -- Otherwise the node is not at any level
5498 -- The current construct is a compilation unit. The node appears at
5499 -- the [generic] library level when the unit is a [generic] package.
5501 elsif Nkind
(Curr
) = N_Compilation_Unit
then
5502 return Level_Of
(Unit
(Curr
));
5506 Curr
:= Parent
(Prev
);
5510 end Find_Enclosing_Level
;
5516 function Find_Top_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
is
5518 return Find_Unit_Entity
(Unit
(Cunit
(Get_Top_Level_Code_Unit
(N
))));
5521 ----------------------
5522 -- Find_Unit_Entity --
5523 ----------------------
5525 function Find_Unit_Entity
(N
: Node_Id
) return Entity_Id
is
5526 Context
: constant Node_Id
:= Parent
(N
);
5527 Orig_N
: constant Node_Id
:= Original_Node
(N
);
5530 -- The unit denotes a package body of an instantiation which acts as
5531 -- a compilation unit. The proper entity is that of the package spec.
5533 if Nkind
(N
) = N_Package_Body
5534 and then Nkind
(Orig_N
) = N_Package_Instantiation
5535 and then Nkind
(Context
) = N_Compilation_Unit
5537 return Corresponding_Spec
(N
);
5539 -- The unit denotes an anonymous package created to wrap a subprogram
5540 -- instantiation which acts as a compilation unit. The proper entity is
5541 -- that of the "related instance".
5543 elsif Nkind
(N
) = N_Package_Declaration
5544 and then Nkind_In
(Orig_N
, N_Function_Instantiation
,
5545 N_Procedure_Instantiation
)
5546 and then Nkind
(Context
) = N_Compilation_Unit
5549 Related_Instance
(Defining_Entity
(N
, Concurrent_Subunit
=> True));
5551 -- Otherwise the proper entity is the defining entity
5554 return Defining_Entity
(N
, Concurrent_Subunit
=> True);
5556 end Find_Unit_Entity
;
5558 -----------------------
5559 -- First_Formal_Type --
5560 -----------------------
5562 function First_Formal_Type
(Subp_Id
: Entity_Id
) return Entity_Id
is
5563 Formal_Id
: constant Entity_Id
:= First_Formal
(Subp_Id
);
5567 if Present
(Formal_Id
) then
5568 Typ
:= Etype
(Formal_Id
);
5570 -- Handle various combinations of concurrent and private types
5573 if Ekind_In
(Typ
, E_Protected_Type
, E_Task_Type
)
5574 and then Present
(Anonymous_Object
(Typ
))
5576 Typ
:= Anonymous_Object
(Typ
);
5578 elsif Is_Concurrent_Record_Type
(Typ
) then
5579 Typ
:= Corresponding_Concurrent_Type
(Typ
);
5581 elsif Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
5582 Typ
:= Full_View
(Typ
);
5593 end First_Formal_Type
;
5599 function Has_Body
(Pack_Decl
: Node_Id
) return Boolean is
5600 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
;
5601 -- Try to locate the corresponding body of spec Spec_Id. If no body is
5602 -- found, return Empty.
5605 (Spec_Id
: Entity_Id
;
5606 From
: Node_Id
) return Node_Id
;
5607 -- Try to locate the corresponding body of spec Spec_Id in the node list
5608 -- which follows arbitrary node From. If no body is found, return Empty.
5610 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
;
5611 -- Attempt to load the body of unit Unit_Nam. If the load failed, return
5612 -- Empty. If the compilation will not generate code, return Empty.
5614 -----------------------------
5615 -- Find_Corresponding_Body --
5616 -----------------------------
5618 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
is
5619 Context
: constant Entity_Id
:= Scope
(Spec_Id
);
5620 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
5621 Body_Decl
: Node_Id
;
5622 Body_Id
: Entity_Id
;
5625 if Is_Compilation_Unit
(Spec_Id
) then
5626 Body_Id
:= Corresponding_Body
(Spec_Decl
);
5628 if Present
(Body_Id
) then
5629 return Unit_Declaration_Node
(Body_Id
);
5631 -- The package is at the library and requires a body. Load the
5632 -- corresponding body because the optional body may be declared
5635 elsif Unit_Requires_Body
(Spec_Id
) then
5638 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec_Decl
))));
5640 -- Otherwise there is no optional body
5646 -- The immediate context is a package. The optional body may be
5647 -- within the body of that package.
5649 -- procedure Proc is
5650 -- package Nested_1 is
5651 -- package Nested_2 is
5658 -- package body Nested_1 is
5659 -- package body Nested_2 is separate;
5662 -- separate (Proc.Nested_1.Nested_2)
5663 -- package body Nested_2 is
5664 -- package body Pack is -- optional body
5669 elsif Is_Package_Or_Generic_Package
(Context
) then
5670 Body_Decl
:= Find_Corresponding_Body
(Context
);
5672 -- The optional body is within the body of the enclosing package
5674 if Present
(Body_Decl
) then
5677 (Spec_Id
=> Spec_Id
,
5678 From
=> First
(Declarations
(Body_Decl
)));
5680 -- Otherwise the enclosing package does not have a body. This may
5681 -- be the result of an error or a genuine lack of a body.
5687 -- Otherwise the immediate context is a body. The optional body may
5688 -- be within the same list as the spec.
5690 -- procedure Proc is
5695 -- package body Pack is -- optional body
5702 (Spec_Id
=> Spec_Id
,
5703 From
=> Next
(Spec_Decl
));
5705 end Find_Corresponding_Body
;
5712 (Spec_Id
: Entity_Id
;
5713 From
: Node_Id
) return Node_Id
5715 Spec_Nam
: constant Name_Id
:= Chars
(Spec_Id
);
5721 while Present
(Item
) loop
5723 -- The current item denotes the optional body
5725 if Nkind
(Item
) = N_Package_Body
5726 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
5730 -- The current item denotes a stub, the optional body may be in
5733 elsif Nkind
(Item
) = N_Package_Body_Stub
5734 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
5736 Lib_Unit
:= Library_Unit
(Item
);
5738 -- The corresponding subunit was previously loaded
5740 if Present
(Lib_Unit
) then
5743 -- Otherwise attempt to load the corresponding subunit
5746 return Load_Package_Body
(Get_Unit_Name
(Item
));
5756 -----------------------
5757 -- Load_Package_Body --
5758 -----------------------
5760 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
is
5761 Body_Decl
: Node_Id
;
5762 Unit_Num
: Unit_Number_Type
;
5765 -- The load is performed only when the compilation will generate code
5767 if Operating_Mode
= Generate_Code
then
5770 (Load_Name
=> Unit_Nam
,
5773 Error_Node
=> Pack_Decl
);
5775 -- The load failed most likely because the physical file is
5778 if Unit_Num
= No_Unit
then
5781 -- Otherwise the load was successful, return the body of the unit
5784 Body_Decl
:= Unit
(Cunit
(Unit_Num
));
5786 -- If the unit is a subunit with an available proper body,
5787 -- return the proper body.
5789 if Nkind
(Body_Decl
) = N_Subunit
5790 and then Present
(Proper_Body
(Body_Decl
))
5792 Body_Decl
:= Proper_Body
(Body_Decl
);
5800 end Load_Package_Body
;
5804 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
5806 -- Start of processing for Has_Body
5809 -- The body is available
5811 if Present
(Corresponding_Body
(Pack_Decl
)) then
5814 -- The body is required if the package spec contains a construct which
5815 -- requires a completion in a body.
5817 elsif Unit_Requires_Body
(Pack_Id
) then
5820 -- The body may be optional
5823 return Present
(Find_Corresponding_Body
(Pack_Id
));
5827 ---------------------------
5828 -- Has_Prior_Elaboration --
5829 ---------------------------
5831 function Has_Prior_Elaboration
5832 (Unit_Id
: Entity_Id
;
5833 Context_OK
: Boolean := False;
5834 Elab_Body_OK
: Boolean := False;
5835 Same_Unit_OK
: Boolean := False) return Boolean
5837 Main_Id
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
5840 -- A preelaborated unit is always elaborated prior to the main unit
5842 if Is_Preelaborated_Unit
(Unit_Id
) then
5845 -- An internal unit is always elaborated prior to a non-internal main
5848 elsif In_Internal_Unit
(Unit_Id
)
5849 and then not In_Internal_Unit
(Main_Id
)
5853 -- A unit has prior elaboration if it appears within the context of the
5854 -- main unit. Consider this case only when requested by the caller.
5857 and then Elaboration_Status
(Unit_Id
) /= No_Elaboration_Attributes
5861 -- A unit whose body is elaborated together with its spec has prior
5862 -- elaboration except with respect to itself. Consider this case only
5863 -- when requested by the caller.
5866 and then Has_Pragma_Elaborate_Body
(Unit_Id
)
5867 and then not Is_Same_Unit
(Unit_Id
, Main_Id
)
5871 -- A unit has no prior elaboration with respect to itself, but does not
5872 -- require any means of ensuring its own elaboration either. Treat this
5873 -- case as valid prior elaboration only when requested by the caller.
5875 elsif Same_Unit_OK
and then Is_Same_Unit
(Unit_Id
, Main_Id
) then
5880 end Has_Prior_Elaboration
;
5882 --------------------------
5883 -- In_External_Instance --
5884 --------------------------
5886 function In_External_Instance
5888 Target_Decl
: Node_Id
) return Boolean
5891 Inst_Body
: Node_Id
;
5892 Inst_Decl
: Node_Id
;
5895 -- Performance note: parent traversal
5897 Inst_Decl
:= Find_Enclosing_Instance
(Target_Decl
);
5899 -- The target declaration appears within an instance spec. Visibility is
5900 -- ignored because internally generated primitives for private types may
5901 -- reside in the private declarations and still be invoked from outside.
5903 if Present
(Inst_Decl
)
5904 and then Nkind
(Inst_Decl
) = N_Package_Declaration
5906 -- The scenario comes from the main unit and the instance does not
5908 if In_Extended_Main_Code_Unit
(N
)
5909 and then not In_Extended_Main_Code_Unit
(Inst_Decl
)
5913 -- Otherwise the scenario must not appear within the instance spec or
5917 Extract_Instance_Attributes
5918 (Exp_Inst
=> Inst_Decl
,
5919 Inst_Body
=> Inst_Body
,
5920 Inst_Decl
=> Dummy
);
5922 -- Performance note: parent traversal
5924 return not In_Subtree
5927 Root2
=> Inst_Body
);
5932 end In_External_Instance
;
5934 ---------------------
5935 -- In_Main_Context --
5936 ---------------------
5938 function In_Main_Context
(N
: Node_Id
) return Boolean is
5940 -- Scenarios outside the main unit are not considered because the ALI
5941 -- information supplied to binde is for the main unit only.
5943 if not In_Extended_Main_Code_Unit
(N
) then
5946 -- Scenarios within internal units are not considered unless switch
5947 -- -gnatdE (elaboration checks on predefined units) is in effect.
5949 elsif not Debug_Flag_EE
and then In_Internal_Unit
(N
) then
5954 end In_Main_Context
;
5956 ---------------------
5957 -- In_Same_Context --
5958 ---------------------
5960 function In_Same_Context
5963 Nested_OK
: Boolean := False) return Boolean
5965 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
;
5966 -- Return the nearest enclosing non-library-level or compilation unit
5967 -- node which which encapsulates arbitrary node N. Return Empty is no
5968 -- such context is available.
5970 function In_Nested_Context
5972 Inner
: Node_Id
) return Boolean;
5973 -- Determine whether arbitrary node Outer encapsulates arbitrary node
5976 ----------------------------
5977 -- Find_Enclosing_Context --
5978 ----------------------------
5980 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
is
5986 while Present
(Par
) loop
5988 -- A traversal from a subunit continues via the corresponding stub
5990 if Nkind
(Par
) = N_Subunit
then
5991 Par
:= Corresponding_Stub
(Par
);
5993 -- Stop the traversal when the nearest enclosing non-library-level
5994 -- encapsulator has been reached.
5996 elsif Is_Non_Library_Level_Encapsulator
(Par
) then
5997 Context
:= Parent
(Par
);
5999 -- The sole exception is when the encapsulator is the unit of
6000 -- compilation because this case requires special processing
6003 if Present
(Context
)
6004 and then Nkind
(Context
) = N_Compilation_Unit
6012 -- Reaching a compilation unit node without hitting a non-library-
6013 -- level encapsulator indicates that N is at the library level in
6014 -- which case the compilation unit is the context.
6016 elsif Nkind
(Par
) = N_Compilation_Unit
then
6020 Par
:= Parent
(Par
);
6024 end Find_Enclosing_Context
;
6026 -----------------------
6027 -- In_Nested_Context --
6028 -----------------------
6030 function In_Nested_Context
6032 Inner
: Node_Id
) return Boolean
6038 while Present
(Par
) loop
6040 -- A traversal from a subunit continues via the corresponding stub
6042 if Nkind
(Par
) = N_Subunit
then
6043 Par
:= Corresponding_Stub
(Par
);
6045 elsif Par
= Outer
then
6049 Par
:= Parent
(Par
);
6053 end In_Nested_Context
;
6057 Context_1
: constant Node_Id
:= Find_Enclosing_Context
(N1
);
6058 Context_2
: constant Node_Id
:= Find_Enclosing_Context
(N2
);
6060 -- Start of processing for In_Same_Context
6063 -- Both nodes appear within the same context
6065 if Context_1
= Context_2
then
6068 -- Both nodes appear in compilation units. Determine whether one unit
6069 -- is the body of the other.
6071 elsif Nkind
(Context_1
) = N_Compilation_Unit
6072 and then Nkind
(Context_2
) = N_Compilation_Unit
6076 (Unit_1
=> Defining_Entity
(Unit
(Context_1
)),
6077 Unit_2
=> Defining_Entity
(Unit
(Context_2
)));
6079 -- The context of N1 encloses the context of N2
6081 elsif Nested_OK
and then In_Nested_Context
(Context_1
, Context_2
) then
6086 end In_Same_Context
;
6092 function In_Task_Body
(N
: Node_Id
) return Boolean is
6096 -- Climb the parent chain looking for a task body [procedure]
6099 while Present
(Par
) loop
6100 if Nkind
(Par
) = N_Task_Body
then
6103 elsif Nkind
(Par
) = N_Subprogram_Body
6104 and then Is_Task_Body_Procedure
(Par
)
6108 -- Prevent the search from going too far. Note that this predicate
6109 -- shares nodes with the two cases above, and must come last.
6111 elsif Is_Body_Or_Package_Declaration
(Par
) then
6115 Par
:= Parent
(Par
);
6125 procedure Initialize
is
6127 -- Set the soft link which enables Atree.Rewrite to update a top-level
6128 -- scenario each time it is transformed into another node.
6130 Set_Rewriting_Proc
(Update_Elaboration_Scenario
'Access);
6139 Target_Id
: Entity_Id
;
6143 procedure Info_Accept_Alternative
;
6144 pragma Inline
(Info_Accept_Alternative
);
6145 -- Output information concerning an accept alternative
6147 procedure Info_Simple_Call
;
6148 pragma Inline
(Info_Simple_Call
);
6149 -- Output information concerning the call
6151 procedure Info_Type_Actions
(Action
: String);
6152 pragma Inline
(Info_Type_Actions
);
6153 -- Output information concerning action Action of a type
6155 procedure Info_Verification_Call
6159 pragma Inline
(Info_Verification_Call
);
6160 -- Output information concerning the verification of predicate Pred
6161 -- applied to related entity Id with kind Id_Kind.
6163 -----------------------------
6164 -- Info_Accept_Alternative --
6165 -----------------------------
6167 procedure Info_Accept_Alternative
is
6168 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Target_Id
);
6171 pragma Assert
(Present
(Entry_Id
));
6174 (Msg
=> "accept for entry & during elaboration",
6177 Info_Msg
=> Info_Msg
,
6178 In_SPARK
=> In_SPARK
);
6179 end Info_Accept_Alternative
;
6181 ----------------------
6182 -- Info_Simple_Call --
6183 ----------------------
6185 procedure Info_Simple_Call
is
6188 (Msg
=> "call to & during elaboration",
6191 Info_Msg
=> Info_Msg
,
6192 In_SPARK
=> In_SPARK
);
6193 end Info_Simple_Call
;
6195 -----------------------
6196 -- Info_Type_Actions --
6197 -----------------------
6199 procedure Info_Type_Actions
(Action
: String) is
6200 Typ
: constant Entity_Id
:= First_Formal_Type
(Target_Id
);
6203 pragma Assert
(Present
(Typ
));
6206 (Msg
=> Action
& " actions for type & during elaboration",
6209 Info_Msg
=> Info_Msg
,
6210 In_SPARK
=> In_SPARK
);
6211 end Info_Type_Actions
;
6213 ----------------------------
6214 -- Info_Verification_Call --
6215 ----------------------------
6217 procedure Info_Verification_Call
6223 pragma Assert
(Present
(Id
));
6227 "verification of " & Pred
& " of " & Id_Kind
& " & during "
6231 Info_Msg
=> Info_Msg
,
6232 In_SPARK
=> In_SPARK
);
6233 end Info_Verification_Call
;
6235 -- Start of processing for Info_Call
6238 -- Do not output anything for targets defined in internal units because
6239 -- this creates noise.
6241 if not In_Internal_Unit
(Target_Id
) then
6243 -- Accept alternative
6245 if Is_Accept_Alternative_Proc
(Target_Id
) then
6246 Info_Accept_Alternative
;
6250 elsif Is_TSS
(Target_Id
, TSS_Deep_Adjust
) then
6251 Info_Type_Actions
("adjustment");
6253 -- Default_Initial_Condition
6255 elsif Is_Default_Initial_Condition_Proc
(Target_Id
) then
6256 Info_Verification_Call
6257 (Pred
=> "Default_Initial_Condition",
6258 Id
=> First_Formal_Type
(Target_Id
),
6263 elsif Is_Protected_Entry
(Target_Id
) then
6266 -- Task entry calls are never processed because the entry being
6267 -- invoked does not have a corresponding "body", it has a select.
6269 elsif Is_Task_Entry
(Target_Id
) then
6274 elsif Is_TSS
(Target_Id
, TSS_Deep_Finalize
) then
6275 Info_Type_Actions
("finalization");
6277 -- Calls to _Finalizer procedures must not appear in the output
6278 -- because this creates confusing noise.
6280 elsif Is_Finalizer_Proc
(Target_Id
) then
6283 -- Initial_Condition
6285 elsif Is_Initial_Condition_Proc
(Target_Id
) then
6286 Info_Verification_Call
6287 (Pred
=> "Initial_Condition",
6288 Id
=> Find_Enclosing_Scope
(Call
),
6289 Id_Kind
=> "package");
6293 elsif Is_Init_Proc
(Target_Id
)
6294 or else Is_TSS
(Target_Id
, TSS_Deep_Initialize
)
6296 Info_Type_Actions
("initialization");
6300 elsif Is_Invariant_Proc
(Target_Id
) then
6301 Info_Verification_Call
6302 (Pred
=> "invariants",
6303 Id
=> First_Formal_Type
(Target_Id
),
6306 -- Partial invariant calls must not appear in the output because this
6307 -- creates confusing noise.
6309 elsif Is_Partial_Invariant_Proc
(Target_Id
) then
6314 elsif Is_Postconditions_Proc
(Target_Id
) then
6315 Info_Verification_Call
6316 (Pred
=> "postconditions",
6317 Id
=> Find_Enclosing_Scope
(Call
),
6318 Id_Kind
=> "subprogram");
6320 -- Subprograms must come last because some of the previous cases fall
6321 -- under this category.
6323 elsif Ekind
(Target_Id
) = E_Function
then
6326 elsif Ekind
(Target_Id
) = E_Procedure
then
6330 pragma Assert
(False);
6336 ------------------------
6337 -- Info_Instantiation --
6338 ------------------------
6340 procedure Info_Instantiation
6348 (Msg
=> "instantiation of & during elaboration",
6351 Info_Msg
=> Info_Msg
,
6352 In_SPARK
=> In_SPARK
);
6353 end Info_Instantiation
;
6355 -----------------------------
6356 -- Info_Variable_Reference --
6357 -----------------------------
6359 procedure Info_Variable_Reference
6366 if Is_Read
(Ref
) then
6368 (Msg
=> "read of variable & during elaboration",
6371 Info_Msg
=> Info_Msg
,
6372 In_SPARK
=> In_SPARK
);
6374 end Info_Variable_Reference
;
6376 --------------------
6377 -- Insertion_Node --
6378 --------------------
6380 function Insertion_Node
(N
: Node_Id
; Ins_Nod
: Node_Id
) return Node_Id
is
6382 -- When the scenario denotes an instantiation, the proper insertion node
6383 -- is the instance spec. This ensures that the generic actuals will not
6384 -- be evaluated prior to a potential ABE.
6386 if Nkind
(N
) in N_Generic_Instantiation
6387 and then Present
(Instance_Spec
(N
))
6389 return Instance_Spec
(N
);
6391 -- Otherwise the proper insertion node is the candidate insertion node
6398 -----------------------
6399 -- Install_ABE_Check --
6400 -----------------------
6402 procedure Install_ABE_Check
6407 Check_Ins_Nod
: constant Node_Id
:= Insertion_Node
(N
, Ins_Nod
);
6408 -- Insert the check prior to this node
6410 Loc
: constant Source_Ptr
:= Sloc
(N
);
6411 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Id
);
6412 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Id
);
6413 Scop_Id
: Entity_Id
;
6416 -- Nothing to do when compiling for GNATprove because raise statements
6417 -- are not supported.
6419 if GNATprove_Mode
then
6422 -- Nothing to do when the compilation will not produce an executable
6424 elsif Serious_Errors_Detected
> 0 then
6427 -- Nothing to do for a compilation unit because there is no executable
6428 -- environment at that level.
6430 elsif Nkind
(Parent
(Check_Ins_Nod
)) = N_Compilation_Unit
then
6433 -- Nothing to do when the unit is elaborated prior to the main unit.
6434 -- This check must also consider the following cases:
6436 -- * Id's unit appears in the context of the main unit
6438 -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST
6439 -- NOT be generated because Id's unit is always elaborated prior to
6442 -- * Id's unit is the main unit. An ABE check MUST be generated in this
6443 -- case because a conditional ABE may be raised depending on the flow
6444 -- of execution within the main unit (flag Same_Unit_OK is False).
6446 elsif Has_Prior_Elaboration
6447 (Unit_Id
=> Unit_Id
,
6449 Elab_Body_OK
=> True)
6454 -- Prevent multiple scenarios from installing the same ABE check
6456 Set_Is_Elaboration_Checks_OK_Node
(N
, False);
6458 -- Install the nearest enclosing scope of the scenario as there must be
6459 -- something on the scope stack.
6461 -- Performance note: parent traversal
6463 Scop_Id
:= Find_Enclosing_Scope
(Check_Ins_Nod
);
6464 pragma Assert
(Present
(Scop_Id
));
6466 Push_Scope
(Scop_Id
);
6469 -- if not Spec_Id'Elaborated then
6470 -- raise Program_Error with "access before elaboration";
6473 Insert_Action
(Check_Ins_Nod
,
6474 Make_Raise_Program_Error
(Loc
,
6478 Make_Attribute_Reference
(Loc
,
6479 Prefix
=> New_Occurrence_Of
(Spec_Id
, Loc
),
6480 Attribute_Name
=> Name_Elaborated
)),
6481 Reason
=> PE_Access_Before_Elaboration
));
6484 end Install_ABE_Check
;
6486 -----------------------
6487 -- Install_ABE_Check --
6488 -----------------------
6490 procedure Install_ABE_Check
6492 Target_Id
: Entity_Id
;
6493 Target_Decl
: Node_Id
;
6494 Target_Body
: Node_Id
;
6497 procedure Build_Elaboration_Entity
;
6498 pragma Inline
(Build_Elaboration_Entity
);
6499 -- Create a new elaboration flag for Target_Id, insert it prior to
6500 -- Target_Decl, and set it after Body_Decl.
6502 ------------------------------
6503 -- Build_Elaboration_Entity --
6504 ------------------------------
6506 procedure Build_Elaboration_Entity
is
6507 Loc
: constant Source_Ptr
:= Sloc
(Target_Id
);
6508 Flag_Id
: Entity_Id
;
6511 -- Create the declaration of the elaboration flag. The name carries a
6512 -- unique counter in case of name overloading.
6515 Make_Defining_Identifier
(Loc
,
6516 Chars
=> New_External_Name
(Chars
(Target_Id
), 'E', -1));
6518 Set_Elaboration_Entity
(Target_Id
, Flag_Id
);
6519 Set_Elaboration_Entity_Required
(Target_Id
);
6521 Push_Scope
(Scope
(Target_Id
));
6524 -- Enn : Short_Integer := 0;
6526 Insert_Action
(Target_Decl
,
6527 Make_Object_Declaration
(Loc
,
6528 Defining_Identifier
=> Flag_Id
,
6529 Object_Definition
=>
6530 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
6531 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
)));
6536 Set_Elaboration_Flag
(Target_Body
, Target_Id
);
6539 end Build_Elaboration_Entity
;
6543 Target_Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Target_Id
);
6545 -- Start for processing for Install_ABE_Check
6548 -- Nothing to do when compiling for GNATprove because raise statements
6549 -- are not supported.
6551 if GNATprove_Mode
then
6554 -- Nothing to do when the compilation will not produce an executable
6556 elsif Serious_Errors_Detected
> 0 then
6559 -- Nothing to do when the target is a protected subprogram because the
6560 -- check is associated with the protected body subprogram.
6562 elsif Is_Protected_Subp
(Target_Id
) then
6565 -- Nothing to do when the target is elaborated prior to the main unit.
6566 -- This check must also consider the following cases:
6568 -- * The unit of the target appears in the context of the main unit
6570 -- * The unit of the target is subject to pragma Elaborate_Body. An ABE
6571 -- check MUST NOT be generated because the unit is always elaborated
6572 -- prior to the main unit.
6574 -- * The unit of the target is the main unit. An ABE check MUST be added
6575 -- in this case because a conditional ABE may be raised depending on
6576 -- the flow of execution within the main unit (flag Same_Unit_OK is
6579 elsif Has_Prior_Elaboration
6580 (Unit_Id
=> Target_Unit_Id
,
6582 Elab_Body_OK
=> True)
6586 -- Create an elaboration flag for the target when it does not have one
6588 elsif No
(Elaboration_Entity
(Target_Id
)) then
6589 Build_Elaboration_Entity
;
6596 end Install_ABE_Check
;
6598 -------------------------
6599 -- Install_ABE_Failure --
6600 -------------------------
6602 procedure Install_ABE_Failure
(N
: Node_Id
; Ins_Nod
: Node_Id
) is
6603 Fail_Ins_Nod
: constant Node_Id
:= Insertion_Node
(N
, Ins_Nod
);
6604 -- Insert the failure prior to this node
6606 Loc
: constant Source_Ptr
:= Sloc
(N
);
6607 Scop_Id
: Entity_Id
;
6610 -- Nothing to do when compiling for GNATprove because raise statements
6611 -- are not supported.
6613 if GNATprove_Mode
then
6616 -- Nothing to do when the compilation will not produce an executable
6618 elsif Serious_Errors_Detected
> 0 then
6621 -- Do not install an ABE check for a compilation unit because there is
6622 -- no executable environment at that level.
6624 elsif Nkind
(Parent
(Fail_Ins_Nod
)) = N_Compilation_Unit
then
6628 -- Prevent multiple scenarios from installing the same ABE failure
6630 Set_Is_Elaboration_Checks_OK_Node
(N
, False);
6632 -- Install the nearest enclosing scope of the scenario as there must be
6633 -- something on the scope stack.
6635 -- Performance note: parent traversal
6637 Scop_Id
:= Find_Enclosing_Scope
(Fail_Ins_Nod
);
6638 pragma Assert
(Present
(Scop_Id
));
6640 Push_Scope
(Scop_Id
);
6643 -- raise Program_Error with "access before elaboration";
6645 Insert_Action
(Fail_Ins_Nod
,
6646 Make_Raise_Program_Error
(Loc
,
6647 Reason
=> PE_Access_Before_Elaboration
));
6650 end Install_ABE_Failure
;
6652 --------------------------------
6653 -- Is_Accept_Alternative_Proc --
6654 --------------------------------
6656 function Is_Accept_Alternative_Proc
(Id
: Entity_Id
) return Boolean is
6658 -- To qualify, the entity must denote a procedure with a receiving entry
6660 return Ekind
(Id
) = E_Procedure
and then Present
(Receiving_Entry
(Id
));
6661 end Is_Accept_Alternative_Proc
;
6663 ------------------------
6664 -- Is_Activation_Proc --
6665 ------------------------
6667 function Is_Activation_Proc
(Id
: Entity_Id
) return Boolean is
6669 -- To qualify, the entity must denote one of the runtime procedures in
6670 -- charge of task activation.
6672 if Ekind
(Id
) = E_Procedure
then
6673 if Restricted_Profile
then
6674 return Is_RTE
(Id
, RE_Activate_Restricted_Tasks
);
6676 return Is_RTE
(Id
, RE_Activate_Tasks
);
6681 end Is_Activation_Proc
;
6683 ----------------------------
6684 -- Is_Ada_Semantic_Target --
6685 ----------------------------
6687 function Is_Ada_Semantic_Target
(Id
: Entity_Id
) return Boolean is
6690 Is_Activation_Proc
(Id
)
6691 or else Is_Controlled_Proc
(Id
, Name_Adjust
)
6692 or else Is_Controlled_Proc
(Id
, Name_Finalize
)
6693 or else Is_Controlled_Proc
(Id
, Name_Initialize
)
6694 or else Is_Init_Proc
(Id
)
6695 or else Is_Invariant_Proc
(Id
)
6696 or else Is_Protected_Entry
(Id
)
6697 or else Is_Protected_Subp
(Id
)
6698 or else Is_Protected_Body_Subp
(Id
)
6699 or else Is_Task_Entry
(Id
);
6700 end Is_Ada_Semantic_Target
;
6702 --------------------------------
6703 -- Is_Assertion_Pragma_Target --
6704 --------------------------------
6706 function Is_Assertion_Pragma_Target
(Id
: Entity_Id
) return Boolean is
6709 Is_Default_Initial_Condition_Proc
(Id
)
6710 or else Is_Initial_Condition_Proc
(Id
)
6711 or else Is_Invariant_Proc
(Id
)
6712 or else Is_Partial_Invariant_Proc
(Id
)
6713 or else Is_Postconditions_Proc
(Id
);
6714 end Is_Assertion_Pragma_Target
;
6716 ----------------------------
6717 -- Is_Bodiless_Subprogram --
6718 ----------------------------
6720 function Is_Bodiless_Subprogram
(Subp_Id
: Entity_Id
) return Boolean is
6722 -- An abstract subprogram does not have a body
6724 if Ekind_In
(Subp_Id
, E_Function
,
6727 and then Is_Abstract_Subprogram
(Subp_Id
)
6731 -- A formal subprogram does not have a body
6733 elsif Is_Formal_Subprogram
(Subp_Id
) then
6736 -- An imported subprogram may have a body, however it is not known at
6737 -- compile or bind time where the body resides and whether it will be
6738 -- elaborated on time.
6740 elsif Is_Imported
(Subp_Id
) then
6745 end Is_Bodiless_Subprogram
;
6747 ------------------------
6748 -- Is_Controlled_Proc --
6749 ------------------------
6751 function Is_Controlled_Proc
6752 (Subp_Id
: Entity_Id
;
6753 Subp_Nam
: Name_Id
) return Boolean
6755 Formal_Id
: Entity_Id
;
6758 pragma Assert
(Nam_In
(Subp_Nam
, Name_Adjust
,
6762 -- To qualify, the subprogram must denote a source procedure with name
6763 -- Adjust, Finalize, or Initialize where the sole formal is controlled.
6765 if Comes_From_Source
(Subp_Id
)
6766 and then Ekind
(Subp_Id
) = E_Procedure
6767 and then Chars
(Subp_Id
) = Subp_Nam
6769 Formal_Id
:= First_Formal
(Subp_Id
);
6773 and then Is_Controlled
(Etype
(Formal_Id
))
6774 and then No
(Next_Formal
(Formal_Id
));
6778 end Is_Controlled_Proc
;
6780 ---------------------------------------
6781 -- Is_Default_Initial_Condition_Proc --
6782 ---------------------------------------
6784 function Is_Default_Initial_Condition_Proc
6785 (Id
: Entity_Id
) return Boolean
6788 -- To qualify, the entity must denote a Default_Initial_Condition
6791 return Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
);
6792 end Is_Default_Initial_Condition_Proc
;
6794 -----------------------
6795 -- Is_Finalizer_Proc --
6796 -----------------------
6798 function Is_Finalizer_Proc
(Id
: Entity_Id
) return Boolean is
6800 -- To qualify, the entity must denote a _Finalizer procedure
6802 return Ekind
(Id
) = E_Procedure
and then Chars
(Id
) = Name_uFinalizer
;
6803 end Is_Finalizer_Proc
;
6805 -----------------------
6806 -- Is_Guaranteed_ABE --
6807 -----------------------
6809 function Is_Guaranteed_ABE
6811 Target_Decl
: Node_Id
;
6812 Target_Body
: Node_Id
) return Boolean
6815 -- Avoid cascaded errors if there were previous serious infractions.
6816 -- As a result the scenario will not be treated as a guaranteed ABE.
6817 -- This behaviour parallels that of the old ABE mechanism.
6819 if Serious_Errors_Detected
> 0 then
6822 -- The scenario and the target appear within the same context ignoring
6823 -- enclosing library levels.
6825 -- Performance note: parent traversal
6827 elsif In_Same_Context
(N
, Target_Decl
) then
6829 -- The target body has already been encountered. The scenario results
6830 -- in a guaranteed ABE if it appears prior to the body.
6832 if Present
(Target_Body
) then
6833 return Earlier_In_Extended_Unit
(N
, Target_Body
);
6835 -- Otherwise the body has not been encountered yet. The scenario is
6836 -- a guaranteed ABE since the body will appear later. It is assumed
6837 -- that the caller has already checked whether the scenario is ABE-
6838 -- safe as optional bodies are not considered here.
6846 end Is_Guaranteed_ABE
;
6848 -------------------------------
6849 -- Is_Initial_Condition_Proc --
6850 -------------------------------
6852 function Is_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean is
6854 -- To qualify, the entity must denote an Initial_Condition procedure
6857 Ekind
(Id
) = E_Procedure
and then Is_Initial_Condition_Procedure
(Id
);
6858 end Is_Initial_Condition_Proc
;
6860 --------------------
6861 -- Is_Initialized --
6862 --------------------
6864 function Is_Initialized
(Obj_Decl
: Node_Id
) return Boolean is
6866 -- To qualify, the object declaration must have an expression
6869 Present
(Expression
(Obj_Decl
)) or else Has_Init_Expression
(Obj_Decl
);
6872 -----------------------
6873 -- Is_Invariant_Proc --
6874 -----------------------
6876 function Is_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
6878 -- To qualify, the entity must denote the "full" invariant procedure
6880 return Ekind
(Id
) = E_Procedure
and then Is_Invariant_Procedure
(Id
);
6881 end Is_Invariant_Proc
;
6883 ---------------------------------------
6884 -- Is_Non_Library_Level_Encapsulator --
6885 ---------------------------------------
6887 function Is_Non_Library_Level_Encapsulator
(N
: Node_Id
) return Boolean is
6890 when N_Abstract_Subprogram_Declaration
6891 | N_Aspect_Specification
6892 | N_Component_Declaration
6894 | N_Entry_Declaration
6895 | N_Expression_Function
6896 | N_Formal_Abstract_Subprogram_Declaration
6897 | N_Formal_Concrete_Subprogram_Declaration
6898 | N_Formal_Object_Declaration
6899 | N_Formal_Package_Declaration
6900 | N_Formal_Type_Declaration
6901 | N_Generic_Association
6902 | N_Implicit_Label_Declaration
6903 | N_Incomplete_Type_Declaration
6904 | N_Private_Extension_Declaration
6905 | N_Private_Type_Declaration
6907 | N_Protected_Type_Declaration
6908 | N_Single_Protected_Declaration
6909 | N_Single_Task_Declaration
6911 | N_Subprogram_Declaration
6913 | N_Task_Type_Declaration
6918 return Is_Generic_Declaration_Or_Body
(N
);
6920 end Is_Non_Library_Level_Encapsulator
;
6922 -------------------------------
6923 -- Is_Partial_Invariant_Proc --
6924 -------------------------------
6926 function Is_Partial_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
6928 -- To qualify, the entity must denote the "partial" invariant procedure
6931 Ekind
(Id
) = E_Procedure
and then Is_Partial_Invariant_Procedure
(Id
);
6932 end Is_Partial_Invariant_Proc
;
6934 ----------------------------
6935 -- Is_Postconditions_Proc --
6936 ----------------------------
6938 function Is_Postconditions_Proc
(Id
: Entity_Id
) return Boolean is
6940 -- To qualify, the entity must denote a _Postconditions procedure
6943 Ekind
(Id
) = E_Procedure
and then Chars
(Id
) = Name_uPostconditions
;
6944 end Is_Postconditions_Proc
;
6946 ---------------------------
6947 -- Is_Preelaborated_Unit --
6948 ---------------------------
6950 function Is_Preelaborated_Unit
(Id
: Entity_Id
) return Boolean is
6953 Is_Preelaborated
(Id
)
6954 or else Is_Pure
(Id
)
6955 or else Is_Remote_Call_Interface
(Id
)
6956 or else Is_Remote_Types
(Id
)
6957 or else Is_Shared_Passive
(Id
);
6958 end Is_Preelaborated_Unit
;
6960 ------------------------
6961 -- Is_Protected_Entry --
6962 ------------------------
6964 function Is_Protected_Entry
(Id
: Entity_Id
) return Boolean is
6966 -- To qualify, the entity must denote an entry defined in a protected
6971 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
6972 end Is_Protected_Entry
;
6974 -----------------------
6975 -- Is_Protected_Subp --
6976 -----------------------
6978 function Is_Protected_Subp
(Id
: Entity_Id
) return Boolean is
6980 -- To qualify, the entity must denote a subprogram defined within a
6984 Ekind_In
(Id
, E_Function
, E_Procedure
)
6985 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
6986 end Is_Protected_Subp
;
6988 ----------------------------
6989 -- Is_Protected_Body_Subp --
6990 ----------------------------
6992 function Is_Protected_Body_Subp
(Id
: Entity_Id
) return Boolean is
6994 -- To qualify, the entity must denote a subprogram with attribute
6995 -- Protected_Subprogram set.
6998 Ekind_In
(Id
, E_Function
, E_Procedure
)
6999 and then Present
(Protected_Subprogram
(Id
));
7000 end Is_Protected_Body_Subp
;
7002 --------------------------------
7003 -- Is_Recorded_SPARK_Scenario --
7004 --------------------------------
7006 function Is_Recorded_SPARK_Scenario
(N
: Node_Id
) return Boolean is
7008 if Recorded_SPARK_Scenarios_In_Use
then
7009 return Recorded_SPARK_Scenarios
.Get
(N
);
7012 return Recorded_SPARK_Scenarios_No_Element
;
7013 end Is_Recorded_SPARK_Scenario
;
7015 ------------------------------------
7016 -- Is_Recorded_Top_Level_Scenario --
7017 ------------------------------------
7019 function Is_Recorded_Top_Level_Scenario
(N
: Node_Id
) return Boolean is
7021 if Recorded_Top_Level_Scenarios_In_Use
then
7022 return Recorded_Top_Level_Scenarios
.Get
(N
);
7025 return Recorded_Top_Level_Scenarios_No_Element
;
7026 end Is_Recorded_Top_Level_Scenario
;
7028 ------------------------
7029 -- Is_Safe_Activation --
7030 ------------------------
7032 function Is_Safe_Activation
7034 Task_Decl
: Node_Id
) return Boolean
7037 -- The activation of a task coming from an external instance cannot
7038 -- cause an ABE because the generic was already instantiated. Note
7039 -- that the instantiation itself may lead to an ABE.
7042 In_External_Instance
7044 Target_Decl
=> Task_Decl
);
7045 end Is_Safe_Activation
;
7051 function Is_Safe_Call
7053 Target_Attrs
: Target_Attributes
) return Boolean
7056 -- The target is either an abstract subprogram, formal subprogram, or
7057 -- imported, in which case it does not have a body at compile or bind
7058 -- time. Assume that the call is ABE-safe.
7060 if Is_Bodiless_Subprogram
(Target_Attrs
.Spec_Id
) then
7063 -- The target is an instantiation of a generic subprogram. The call
7064 -- cannot cause an ABE because the generic was already instantiated.
7065 -- Note that the instantiation itself may lead to an ABE.
7067 elsif Is_Generic_Instance
(Target_Attrs
.Spec_Id
) then
7070 -- The invocation of a target coming from an external instance cannot
7071 -- cause an ABE because the generic was already instantiated. Note that
7072 -- the instantiation itself may lead to an ABE.
7074 elsif In_External_Instance
7076 Target_Decl
=> Target_Attrs
.Spec_Decl
)
7080 -- The target is a subprogram body without a previous declaration. The
7081 -- call cannot cause an ABE because the body has already been seen.
7083 elsif Nkind
(Target_Attrs
.Spec_Decl
) = N_Subprogram_Body
7084 and then No
(Corresponding_Spec
(Target_Attrs
.Spec_Decl
))
7088 -- The target is a subprogram body stub without a prior declaration.
7089 -- The call cannot cause an ABE because the proper body substitutes
7092 elsif Nkind
(Target_Attrs
.Spec_Decl
) = N_Subprogram_Body_Stub
7093 and then No
(Corresponding_Spec_Of_Stub
(Target_Attrs
.Spec_Decl
))
7097 -- Subprogram bodies which wrap attribute references used as actuals
7098 -- in instantiations are always ABE-safe. These bodies are artifacts
7101 elsif Present
(Target_Attrs
.Body_Decl
)
7102 and then Nkind
(Target_Attrs
.Body_Decl
) = N_Subprogram_Body
7103 and then Was_Attribute_Reference
(Target_Attrs
.Body_Decl
)
7111 ---------------------------
7112 -- Is_Safe_Instantiation --
7113 ---------------------------
7115 function Is_Safe_Instantiation
7117 Gen_Attrs
: Target_Attributes
) return Boolean
7120 -- The generic is an intrinsic subprogram in which case it does not
7121 -- have a body at compile or bind time. Assume that the instantiation
7124 if Is_Bodiless_Subprogram
(Gen_Attrs
.Spec_Id
) then
7127 -- The instantiation of an external nested generic cannot cause an ABE
7128 -- if the outer generic was already instantiated. Note that the instance
7129 -- of the outer generic may lead to an ABE.
7131 elsif In_External_Instance
7133 Target_Decl
=> Gen_Attrs
.Spec_Decl
)
7137 -- The generic is a package. The instantiation cannot cause an ABE when
7138 -- the package has no body.
7140 elsif Ekind
(Gen_Attrs
.Spec_Id
) = E_Generic_Package
7141 and then not Has_Body
(Gen_Attrs
.Spec_Decl
)
7147 end Is_Safe_Instantiation
;
7153 function Is_Same_Unit
7154 (Unit_1
: Entity_Id
;
7155 Unit_2
: Entity_Id
) return Boolean
7158 return Unit_Entity
(Unit_1
) = Unit_Entity
(Unit_2
);
7165 function Is_Scenario
(N
: Node_Id
) return Boolean is
7168 when N_Assignment_Statement
7169 | N_Attribute_Reference
7171 | N_Entry_Call_Statement
7174 | N_Function_Instantiation
7176 | N_Package_Instantiation
7177 | N_Procedure_Call_Statement
7178 | N_Procedure_Instantiation
7179 | N_Requeue_Statement
7188 ------------------------------
7189 -- Is_SPARK_Semantic_Target --
7190 ------------------------------
7192 function Is_SPARK_Semantic_Target
(Id
: Entity_Id
) return Boolean is
7195 Is_Default_Initial_Condition_Proc
(Id
)
7196 or else Is_Initial_Condition_Proc
(Id
);
7197 end Is_SPARK_Semantic_Target
;
7199 ------------------------
7200 -- Is_Suitable_Access --
7201 ------------------------
7203 function Is_Suitable_Access
(N
: Node_Id
) return Boolean is
7206 Subp_Id
: Entity_Id
;
7209 -- This scenario is relevant only when the static model is in effect
7210 -- because it is graph-dependent and does not involve any run-time
7211 -- checks. Allowing it in the dynamic model would create confusing
7214 if not Static_Elaboration_Checks
then
7217 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
7219 elsif Debug_Flag_Dot_UU
then
7222 -- Nothing to do when the scenario is not an attribute reference
7224 elsif Nkind
(N
) /= N_Attribute_Reference
then
7227 -- Nothing to do for internally-generated attributes because they are
7228 -- assumed to be ABE safe.
7230 elsif not Comes_From_Source
(N
) then
7234 Nam
:= Attribute_Name
(N
);
7237 -- Sanitize the prefix of the attribute
7239 if not Is_Entity_Name
(Pref
) then
7242 elsif No
(Entity
(Pref
)) then
7246 Subp_Id
:= Entity
(Pref
);
7248 if not Is_Subprogram_Or_Entry
(Subp_Id
) then
7252 -- Traverse a possible chain of renamings to obtain the original entry
7253 -- or subprogram which the prefix may rename.
7255 Subp_Id
:= Get_Renamed_Entity
(Subp_Id
);
7257 -- To qualify, the attribute must meet the following prerequisites:
7261 -- The prefix must denote a source entry, operator, or subprogram
7262 -- which is not imported.
7264 Comes_From_Source
(Subp_Id
)
7265 and then Is_Subprogram_Or_Entry
(Subp_Id
)
7266 and then not Is_Bodiless_Subprogram
(Subp_Id
)
7268 -- The attribute name must be one of the 'Access forms. Note that
7269 -- 'Unchecked_Access cannot apply to a subprogram.
7271 and then Nam_In
(Nam
, Name_Access
, Name_Unrestricted_Access
);
7272 end Is_Suitable_Access
;
7274 ----------------------
7275 -- Is_Suitable_Call --
7276 ----------------------
7278 function Is_Suitable_Call
(N
: Node_Id
) return Boolean is
7280 -- Entry and subprogram calls are intentionally ignored because they
7281 -- may undergo expansion depending on the compilation mode, previous
7282 -- errors, generic context, etc. Call markers play the role of calls
7283 -- and provide a uniform foundation for ABE processing.
7285 return Nkind
(N
) = N_Call_Marker
;
7286 end Is_Suitable_Call
;
7288 -------------------------------
7289 -- Is_Suitable_Instantiation --
7290 -------------------------------
7292 function Is_Suitable_Instantiation
(N
: Node_Id
) return Boolean is
7293 Orig_N
: constant Node_Id
:= Original_Node
(N
);
7294 -- Use the original node in case an instantiation library unit is
7295 -- rewritten as a package or subprogram.
7298 -- To qualify, the instantiation must come from source
7301 Comes_From_Source
(Orig_N
)
7302 and then Nkind
(Orig_N
) in N_Generic_Instantiation
;
7303 end Is_Suitable_Instantiation
;
7305 --------------------------
7306 -- Is_Suitable_Scenario --
7307 --------------------------
7309 function Is_Suitable_Scenario
(N
: Node_Id
) return Boolean is
7311 -- NOTE: Derived types and pragma Refined_State are intentionally left
7312 -- out because they are not executable during elaboration.
7315 Is_Suitable_Access
(N
)
7316 or else Is_Suitable_Call
(N
)
7317 or else Is_Suitable_Instantiation
(N
)
7318 or else Is_Suitable_Variable_Assignment
(N
)
7319 or else Is_Suitable_Variable_Reference
(N
);
7320 end Is_Suitable_Scenario
;
7322 ------------------------------------
7323 -- Is_Suitable_SPARK_Derived_Type --
7324 ------------------------------------
7326 function Is_Suitable_SPARK_Derived_Type
(N
: Node_Id
) return Boolean is
7331 -- To qualify, the type declaration must denote a derived tagged type
7332 -- with primitive operations, subject to pragma SPARK_Mode On.
7334 if Nkind
(N
) = N_Full_Type_Declaration
7335 and then Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
7337 Typ
:= Defining_Entity
(N
);
7338 Prag
:= SPARK_Pragma
(Typ
);
7341 Is_Tagged_Type
(Typ
)
7342 and then Has_Primitive_Operations
(Typ
)
7343 and then Present
(Prag
)
7344 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
;
7348 end Is_Suitable_SPARK_Derived_Type
;
7350 -------------------------------------
7351 -- Is_Suitable_SPARK_Instantiation --
7352 -------------------------------------
7354 function Is_Suitable_SPARK_Instantiation
(N
: Node_Id
) return Boolean is
7355 Gen_Attrs
: Target_Attributes
;
7358 Inst_Attrs
: Instantiation_Attributes
;
7359 Inst_Id
: Entity_Id
;
7362 -- To qualify, both the instantiation and the generic must be subject to
7365 if Is_Suitable_Instantiation
(N
) then
7366 Extract_Instantiation_Attributes
7371 Attrs
=> Inst_Attrs
);
7373 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
7375 return Inst_Attrs
.SPARK_Mode_On
and Gen_Attrs
.SPARK_Mode_On
;
7379 end Is_Suitable_SPARK_Instantiation
;
7381 --------------------------------------------
7382 -- Is_Suitable_SPARK_Refined_State_Pragma --
7383 --------------------------------------------
7385 function Is_Suitable_SPARK_Refined_State_Pragma
7386 (N
: Node_Id
) return Boolean
7389 -- To qualfy, the pragma must denote Refined_State
7392 Nkind
(N
) = N_Pragma
7393 and then Pragma_Name
(N
) = Name_Refined_State
;
7394 end Is_Suitable_SPARK_Refined_State_Pragma
;
7396 -------------------------------------
7397 -- Is_Suitable_Variable_Assignment --
7398 -------------------------------------
7400 function Is_Suitable_Variable_Assignment
(N
: Node_Id
) return Boolean is
7402 N_Unit_Id
: Entity_Id
;
7407 Var_Unit_Id
: Entity_Id
;
7410 -- This scenario is relevant only when the static model is in effect
7411 -- because it is graph-dependent and does not involve any run-time
7412 -- checks. Allowing it in the dynamic model would create confusing
7415 if not Static_Elaboration_Checks
then
7418 -- Nothing to do when the scenario is not an assignment
7420 elsif Nkind
(N
) /= N_Assignment_Statement
then
7423 -- Nothing to do for internally-generated assignments because they are
7424 -- assumed to be ABE safe.
7426 elsif not Comes_From_Source
(N
) then
7429 -- Assignments are ignored in GNAT mode on the assumption that they are
7430 -- ABE-safe. This behaviour parallels that of the old ABE mechanism.
7432 elsif GNAT_Mode
then
7436 Nam
:= Extract_Assignment_Name
(N
);
7438 -- Sanitize the left hand side of the assignment
7440 if not Is_Entity_Name
(Nam
) then
7443 elsif No
(Entity
(Nam
)) then
7447 Var_Id
:= Entity
(Nam
);
7449 -- Sanitize the variable
7451 if Var_Id
= Any_Id
then
7454 elsif Ekind
(Var_Id
) /= E_Variable
then
7458 Var_Decl
:= Declaration_Node
(Var_Id
);
7460 if Nkind
(Var_Decl
) /= N_Object_Declaration
then
7464 N_Unit_Id
:= Find_Top_Unit
(N
);
7465 N_Unit
:= Unit_Declaration_Node
(N_Unit_Id
);
7467 Var_Unit_Id
:= Find_Top_Unit
(Var_Decl
);
7468 Var_Unit
:= Unit_Declaration_Node
(Var_Unit_Id
);
7470 -- To qualify, the assignment must meet the following prerequisites:
7473 Comes_From_Source
(Var_Id
)
7475 -- The variable must be declared in the spec of compilation unit U
7477 and then Nkind
(Var_Unit
) = N_Package_Declaration
7479 -- Performance note: parent traversal
7481 and then Find_Enclosing_Level
(Var_Decl
) = Package_Spec
7483 -- The assignment must occur in the body of compilation unit U
7485 and then Nkind
(N_Unit
) = N_Package_Body
7486 and then Present
(Corresponding_Body
(Var_Unit
))
7487 and then Corresponding_Body
(Var_Unit
) = N_Unit_Id
;
7488 end Is_Suitable_Variable_Assignment
;
7490 ------------------------------------
7491 -- Is_Suitable_Variable_Reference --
7492 ------------------------------------
7494 function Is_Suitable_Variable_Reference
(N
: Node_Id
) return Boolean is
7496 -- Expanded names and identifiers are intentionally ignored because they
7497 -- be folded, optimized away, etc. Variable references markers play the
7498 -- role of variable references and provide a uniform foundation for ABE
7501 return Nkind
(N
) = N_Variable_Reference_Marker
;
7502 end Is_Suitable_Variable_Reference
;
7504 ------------------------------------
7505 -- Is_Synchronous_Suspension_Call --
7506 ------------------------------------
7508 function Is_Synchronous_Suspension_Call
(N
: Node_Id
) return Boolean is
7509 Call_Attrs
: Call_Attributes
;
7510 Target_Id
: Entity_Id
;
7513 -- To qualify, the call must invoke one of the runtime routines which
7514 -- perform synchronous suspension.
7516 if Is_Suitable_Call
(N
) then
7517 Extract_Call_Attributes
7519 Target_Id
=> Target_Id
,
7520 Attrs
=> Call_Attrs
);
7523 Is_RTE
(Target_Id
, RE_Suspend_Until_True
)
7525 Is_RTE
(Target_Id
, RE_Wait_For_Release
);
7529 end Is_Synchronous_Suspension_Call
;
7535 function Is_Task_Entry
(Id
: Entity_Id
) return Boolean is
7537 -- To qualify, the entity must denote an entry defined in a task type
7540 Is_Entry
(Id
) and then Is_Task_Type
(Non_Private_View
(Scope
(Id
)));
7543 ------------------------
7544 -- Is_Up_Level_Target --
7545 ------------------------
7547 function Is_Up_Level_Target
(Target_Decl
: Node_Id
) return Boolean is
7548 Root
: constant Node_Id
:= Root_Scenario
;
7551 -- The root appears within the declaratons of a block statement, entry
7552 -- body, subprogram body, or task body ignoring enclosing packages. The
7553 -- root is always within the main unit. An up-level target is a notion
7554 -- applicable only to the static model because scenarios are reached by
7555 -- means of graph traversal started from a fixed declarative or library
7558 -- Performance note: parent traversal
7560 if Static_Elaboration_Checks
7561 and then Find_Enclosing_Level
(Root
) = Declaration_Level
7563 -- The target is within the main unit. It acts as an up-level target
7564 -- when it appears within a context which encloses the root.
7566 -- package body Main_Unit is
7567 -- function Func ...; -- target
7569 -- procedure Proc is
7570 -- X : ... := Func; -- root scenario
7572 if In_Extended_Main_Code_Unit
(Target_Decl
) then
7574 -- Performance note: parent traversal
7576 return not In_Same_Context
(Root
, Target_Decl
, Nested_OK
=> True);
7578 -- Otherwise the target is external to the main unit which makes it
7579 -- an up-level target.
7587 end Is_Up_Level_Target
;
7589 ---------------------
7590 -- Is_Visited_Body --
7591 ---------------------
7593 function Is_Visited_Body
(Body_Decl
: Node_Id
) return Boolean is
7595 if Visited_Bodies_In_Use
then
7596 return Visited_Bodies
.Get
(Body_Decl
);
7599 return Visited_Bodies_No_Element
;
7600 end Is_Visited_Body
;
7602 -------------------------------
7603 -- Kill_Elaboration_Scenario --
7604 -------------------------------
7606 procedure Kill_Elaboration_Scenario
(N
: Node_Id
) is
7607 procedure Kill_SPARK_Scenario
;
7608 pragma Inline
(Kill_SPARK_Scenario
);
7609 -- Eliminate scenario N from table SPARK_Scenarios if it is recorded
7612 procedure Kill_Top_Level_Scenario
;
7613 pragma Inline
(Kill_Top_Level_Scenario
);
7614 -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded
7617 -------------------------
7618 -- Kill_SPARK_Scenario --
7619 -------------------------
7621 procedure Kill_SPARK_Scenario
is
7622 package Scenarios
renames SPARK_Scenarios
;
7625 if Is_Recorded_SPARK_Scenario
(N
) then
7627 -- Performance note: list traversal
7629 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
7630 if Scenarios
.Table
(Index
) = N
then
7631 Scenarios
.Table
(Index
) := Empty
;
7633 -- The SPARK scenario is no longer recorded
7635 Set_Is_Recorded_SPARK_Scenario
(N
, False);
7640 -- A recorded SPARK scenario must be in the table of recorded
7643 pragma Assert
(False);
7645 end Kill_SPARK_Scenario
;
7647 -----------------------------
7648 -- Kill_Top_Level_Scenario --
7649 -----------------------------
7651 procedure Kill_Top_Level_Scenario
is
7652 package Scenarios
renames Top_Level_Scenarios
;
7655 if Is_Recorded_Top_Level_Scenario
(N
) then
7657 -- Performance node: list traversal
7659 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
7660 if Scenarios
.Table
(Index
) = N
then
7661 Scenarios
.Table
(Index
) := Empty
;
7663 -- The top-level scenario is no longer recorded
7665 Set_Is_Recorded_Top_Level_Scenario
(N
, False);
7670 -- A recorded top-level scenario must be in the table of recorded
7671 -- top-level scenarios.
7673 pragma Assert
(False);
7675 end Kill_Top_Level_Scenario
;
7677 -- Start of processing for Kill_Elaboration_Scenario
7680 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
7681 -- enabled) is in effect because the legacy ABE lechanism does not need
7682 -- to carry out this action.
7684 if Legacy_Elaboration_Checks
then
7688 -- Eliminate a recorded scenario when it appears within dead code
7689 -- because it will not be executed at elaboration time.
7691 if Is_Scenario
(N
) then
7692 Kill_SPARK_Scenario
;
7693 Kill_Top_Level_Scenario
;
7695 end Kill_Elaboration_Scenario
;
7697 ----------------------------------
7698 -- Meet_Elaboration_Requirement --
7699 ----------------------------------
7701 procedure Meet_Elaboration_Requirement
7703 Target_Id
: Entity_Id
;
7706 Main_Id
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
7707 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Target_Id
);
7709 function Find_Preelaboration_Pragma
7710 (Prag_Nam
: Name_Id
) return Node_Id
;
7711 pragma Inline
(Find_Preelaboration_Pragma
);
7712 -- Traverse the visible declarations of unit Unit_Id and locate a source
7713 -- preelaboration-related pragma with name Prag_Nam.
7715 procedure Info_Requirement_Met
(Prag
: Node_Id
);
7716 pragma Inline
(Info_Requirement_Met
);
7717 -- Output information concerning pragma Prag which meets requirement
7720 procedure Info_Scenario
;
7721 pragma Inline
(Info_Scenario
);
7722 -- Output information concerning scenario N
7724 --------------------------------
7725 -- Find_Preelaboration_Pragma --
7726 --------------------------------
7728 function Find_Preelaboration_Pragma
7729 (Prag_Nam
: Name_Id
) return Node_Id
7731 Spec
: constant Node_Id
:= Parent
(Unit_Id
);
7735 -- A preelaboration-related pragma comes from source and appears at
7736 -- the top of the visible declarations of a package.
7738 if Nkind
(Spec
) = N_Package_Specification
then
7739 Decl
:= First
(Visible_Declarations
(Spec
));
7740 while Present
(Decl
) loop
7741 if Comes_From_Source
(Decl
) then
7742 if Nkind
(Decl
) = N_Pragma
7743 and then Pragma_Name
(Decl
) = Prag_Nam
7747 -- Otherwise the construct terminates the region where the
7748 -- preelaboration-related pragma may appear.
7760 end Find_Preelaboration_Pragma
;
7762 --------------------------
7763 -- Info_Requirement_Met --
7764 --------------------------
7766 procedure Info_Requirement_Met
(Prag
: Node_Id
) is
7768 pragma Assert
(Present
(Prag
));
7770 Error_Msg_Name_1
:= Req_Nam
;
7771 Error_Msg_Sloc
:= Sloc
(Prag
);
7773 ("\\% requirement for unit & met by pragma #", N
, Unit_Id
);
7774 end Info_Requirement_Met
;
7780 procedure Info_Scenario
is
7782 if Is_Suitable_Call
(N
) then
7785 Target_Id
=> Target_Id
,
7789 elsif Is_Suitable_Instantiation
(N
) then
7792 Gen_Id
=> Target_Id
,
7796 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
7798 ("read of refinement constituents during elaboration in SPARK",
7801 elsif Is_Suitable_Variable_Reference
(N
) then
7802 Info_Variable_Reference
7804 Var_Id
=> Target_Id
,
7808 -- No other scenario may impose a requirement on the context of the
7812 pragma Assert
(False);
7819 Elab_Attrs
: Elaboration_Attributes
;
7823 -- Start of processing for Meet_Elaboration_Requirement
7826 pragma Assert
(Nam_In
(Req_Nam
, Name_Elaborate
, Name_Elaborate_All
));
7828 -- Assume that the requirement has not been met
7832 -- Elaboration requirements are verified only when the static model is
7833 -- in effect because this diagnostic is graph-dependent.
7835 if not Static_Elaboration_Checks
then
7838 -- If the target is within the main unit, either at the source level or
7839 -- through an instantiation, then there is no real requirement to meet
7840 -- because the main unit cannot force its own elaboration by means of an
7841 -- Elaborate[_All] pragma. Treat this case as valid coverage.
7843 elsif In_Extended_Main_Code_Unit
(Target_Id
) then
7846 -- Otherwise the target resides in an external unit
7848 -- The requirement is met when the target comes from an internal unit
7849 -- because such a unit is elaborated prior to a non-internal unit.
7851 elsif In_Internal_Unit
(Unit_Id
)
7852 and then not In_Internal_Unit
(Main_Id
)
7856 -- The requirement is met when the target comes from a preelaborated
7857 -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
7859 elsif Is_Preelaborated_Unit
(Unit_Id
) then
7862 -- Output extra information when switch -gnatel (info messages on
7863 -- implicit Elaborate[_All] pragmas.
7865 if Elab_Info_Messages
then
7866 if Is_Preelaborated
(Unit_Id
) then
7867 Elab_Nam
:= Name_Preelaborate
;
7869 elsif Is_Pure
(Unit_Id
) then
7870 Elab_Nam
:= Name_Pure
;
7872 elsif Is_Remote_Call_Interface
(Unit_Id
) then
7873 Elab_Nam
:= Name_Remote_Call_Interface
;
7875 elsif Is_Remote_Types
(Unit_Id
) then
7876 Elab_Nam
:= Name_Remote_Types
;
7879 pragma Assert
(Is_Shared_Passive
(Unit_Id
));
7880 Elab_Nam
:= Name_Shared_Passive
;
7883 Info_Requirement_Met
(Find_Preelaboration_Pragma
(Elab_Nam
));
7886 -- Determine whether the context of the main unit has a pragma strong
7887 -- enough to meet the requirement.
7890 Elab_Attrs
:= Elaboration_Status
(Unit_Id
);
7892 -- The pragma must be either Elaborate_All or be as strong as the
7895 if Present
(Elab_Attrs
.Source_Pragma
)
7896 and then Nam_In
(Pragma_Name
(Elab_Attrs
.Source_Pragma
),
7902 -- Output extra information when switch -gnatel (info messages on
7903 -- implicit Elaborate[_All] pragmas.
7905 if Elab_Info_Messages
then
7906 Info_Requirement_Met
(Elab_Attrs
.Source_Pragma
);
7911 -- The requirement was not met by the context of the main unit, issue an
7917 Error_Msg_Name_1
:= Req_Nam
;
7918 Error_Msg_Node_2
:= Unit_Id
;
7919 Error_Msg_NE
("\\unit & requires pragma % for &", N
, Main_Id
);
7921 Output_Active_Scenarios
(N
);
7923 end Meet_Elaboration_Requirement
;
7925 ----------------------
7926 -- Non_Private_View --
7927 ----------------------
7929 function Non_Private_View
(Typ
: Entity_Id
) return Entity_Id
is
7931 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
7932 return Full_View
(Typ
);
7936 end Non_Private_View
;
7938 -----------------------------
7939 -- Output_Active_Scenarios --
7940 -----------------------------
7942 procedure Output_Active_Scenarios
(Error_Nod
: Node_Id
) is
7943 procedure Output_Access
(N
: Node_Id
);
7944 -- Emit a specific diagnostic message for 'Access denote by N
7946 procedure Output_Activation_Call
(N
: Node_Id
);
7947 -- Emit a specific diagnostic message for task activation N
7949 procedure Output_Call
(N
: Node_Id
; Target_Id
: Entity_Id
);
7950 -- Emit a specific diagnostic message for call N which invokes target
7953 procedure Output_Header
;
7954 -- Emit a specific diagnostic message for the unit of the root scenario
7956 procedure Output_Instantiation
(N
: Node_Id
);
7957 -- Emit a specific diagnostic message for instantiation N
7959 procedure Output_SPARK_Refined_State_Pragma
(N
: Node_Id
);
7960 -- Emit a specific diagnostic message for Refined_State pragma N
7962 procedure Output_Variable_Assignment
(N
: Node_Id
);
7963 -- Emit a specific diagnostic message for assignment statement N
7965 procedure Output_Variable_Reference
(N
: Node_Id
);
7966 -- Emit a specific diagnostic message for reference N which mentions a
7973 procedure Output_Access
(N
: Node_Id
) is
7974 Subp_Id
: constant Entity_Id
:= Entity
(Prefix
(N
));
7977 Error_Msg_Name_1
:= Attribute_Name
(N
);
7978 Error_Msg_Sloc
:= Sloc
(N
);
7979 Error_Msg_NE
("\\ % of & taken #", Error_Nod
, Subp_Id
);
7982 ----------------------------
7983 -- Output_Activation_Call --
7984 ----------------------------
7986 procedure Output_Activation_Call
(N
: Node_Id
) is
7987 function Find_Activator
(Call
: Node_Id
) return Entity_Id
;
7988 -- Find the nearest enclosing construct which houses call Call
7990 --------------------
7991 -- Find_Activator --
7992 --------------------
7994 function Find_Activator
(Call
: Node_Id
) return Entity_Id
is
7998 -- Climb the parent chain looking for a package [body] or a
7999 -- construct with a statement sequence.
8001 Par
:= Parent
(Call
);
8002 while Present
(Par
) loop
8003 if Nkind_In
(Par
, N_Package_Body
, N_Package_Declaration
) then
8004 return Defining_Entity
(Par
);
8006 elsif Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
8007 return Defining_Entity
(Parent
(Par
));
8010 Par
:= Parent
(Par
);
8018 Activator
: constant Entity_Id
:= Find_Activator
(N
);
8020 -- Start of processing for Output_Activation_Call
8023 pragma Assert
(Present
(Activator
));
8025 Error_Msg_NE
("\\ local tasks of & activated", Error_Nod
, Activator
);
8026 end Output_Activation_Call
;
8032 procedure Output_Call
(N
: Node_Id
; Target_Id
: Entity_Id
) is
8033 procedure Output_Accept_Alternative
;
8034 pragma Inline
(Output_Accept_Alternative
);
8035 -- Emit a specific diagnostic message concerning an accept
8038 procedure Output_Call
(Kind
: String);
8039 pragma Inline
(Output_Call
);
8040 -- Emit a specific diagnostic message concerning a call of kind Kind
8042 procedure Output_Type_Actions
(Action
: String);
8043 pragma Inline
(Output_Type_Actions
);
8044 -- Emit a specific diagnostic message concerning action Action of a
8047 procedure Output_Verification_Call
8051 pragma Inline
(Output_Verification_Call
);
8052 -- Emit a specific diagnostic message concerning the verification of
8053 -- predicate Pred applied to related entity Id with kind Id_Kind.
8055 -------------------------------
8056 -- Output_Accept_Alternative --
8057 -------------------------------
8059 procedure Output_Accept_Alternative
is
8060 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Target_Id
);
8063 pragma Assert
(Present
(Entry_Id
));
8065 Error_Msg_NE
("\\ entry & selected #", Error_Nod
, Entry_Id
);
8066 end Output_Accept_Alternative
;
8072 procedure Output_Call
(Kind
: String) is
8074 Error_Msg_NE
("\\ " & Kind
& " & called #", Error_Nod
, Target_Id
);
8077 -------------------------
8078 -- Output_Type_Actions --
8079 -------------------------
8081 procedure Output_Type_Actions
(Action
: String) is
8082 Typ
: constant Entity_Id
:= First_Formal_Type
(Target_Id
);
8085 pragma Assert
(Present
(Typ
));
8088 ("\\ " & Action
& " actions for type & #", Error_Nod
, Typ
);
8089 end Output_Type_Actions
;
8091 ------------------------------
8092 -- Output_Verification_Call --
8093 ------------------------------
8095 procedure Output_Verification_Call
8101 pragma Assert
(Present
(Id
));
8104 ("\\ " & Pred
& " of " & Id_Kind
& " & verified #",
8106 end Output_Verification_Call
;
8108 -- Start of processing for Output_Call
8111 Error_Msg_Sloc
:= Sloc
(N
);
8113 -- Accept alternative
8115 if Is_Accept_Alternative_Proc
(Target_Id
) then
8116 Output_Accept_Alternative
;
8120 elsif Is_TSS
(Target_Id
, TSS_Deep_Adjust
) then
8121 Output_Type_Actions
("adjustment");
8123 -- Default_Initial_Condition
8125 elsif Is_Default_Initial_Condition_Proc
(Target_Id
) then
8126 Output_Verification_Call
8127 (Pred
=> "Default_Initial_Condition",
8128 Id
=> First_Formal_Type
(Target_Id
),
8133 elsif Is_Protected_Entry
(Target_Id
) then
8134 Output_Call
("entry");
8136 -- Task entry calls are never processed because the entry being
8137 -- invoked does not have a corresponding "body", it has a select. A
8138 -- task entry call appears in the stack of active scenarios for the
8139 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
8142 elsif Is_Task_Entry
(Target_Id
) then
8147 elsif Is_TSS
(Target_Id
, TSS_Deep_Finalize
) then
8148 Output_Type_Actions
("finalization");
8150 -- Calls to _Finalizer procedures must not appear in the output
8151 -- because this creates confusing noise.
8153 elsif Is_Finalizer_Proc
(Target_Id
) then
8156 -- Initial_Condition
8158 elsif Is_Initial_Condition_Proc
(Target_Id
) then
8159 Output_Verification_Call
8160 (Pred
=> "Initial_Condition",
8161 Id
=> Find_Enclosing_Scope
(N
),
8162 Id_Kind
=> "package");
8166 elsif Is_Init_Proc
(Target_Id
)
8167 or else Is_TSS
(Target_Id
, TSS_Deep_Initialize
)
8169 Output_Type_Actions
("initialization");
8173 elsif Is_Invariant_Proc
(Target_Id
) then
8174 Output_Verification_Call
8175 (Pred
=> "invariants",
8176 Id
=> First_Formal_Type
(Target_Id
),
8179 -- Partial invariant calls must not appear in the output because this
8180 -- creates confusing noise. Note that a partial invariant is always
8181 -- invoked by the "full" invariant which is already placed on the
8184 elsif Is_Partial_Invariant_Proc
(Target_Id
) then
8189 elsif Is_Postconditions_Proc
(Target_Id
) then
8190 Output_Verification_Call
8191 (Pred
=> "postconditions",
8192 Id
=> Find_Enclosing_Scope
(N
),
8193 Id_Kind
=> "subprogram");
8195 -- Subprograms must come last because some of the previous cases fall
8196 -- under this category.
8198 elsif Ekind
(Target_Id
) = E_Function
then
8199 Output_Call
("function");
8201 elsif Ekind
(Target_Id
) = E_Procedure
then
8202 Output_Call
("procedure");
8205 pragma Assert
(False);
8214 procedure Output_Header
is
8215 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Root_Scenario
);
8218 if Ekind
(Unit_Id
) = E_Package
then
8219 Error_Msg_NE
("\\ spec of unit & elaborated", Error_Nod
, Unit_Id
);
8221 elsif Ekind
(Unit_Id
) = E_Package_Body
then
8222 Error_Msg_NE
("\\ body of unit & elaborated", Error_Nod
, Unit_Id
);
8225 Error_Msg_NE
("\\ in body of unit &", Error_Nod
, Unit_Id
);
8229 --------------------------
8230 -- Output_Instantiation --
8231 --------------------------
8233 procedure Output_Instantiation
(N
: Node_Id
) is
8234 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String);
8235 pragma Inline
(Output_Instantiation
);
8236 -- Emit a specific diagnostic message concerning an instantiation of
8237 -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
8239 --------------------------
8240 -- Output_Instantiation --
8241 --------------------------
8243 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String) is
8246 ("\\ " & Kind
& " & instantiated as & #", Error_Nod
, Gen_Id
);
8247 end Output_Instantiation
;
8252 Inst_Attrs
: Instantiation_Attributes
;
8253 Inst_Id
: Entity_Id
;
8256 -- Start of processing for Output_Instantiation
8259 Extract_Instantiation_Attributes
8264 Attrs
=> Inst_Attrs
);
8266 Error_Msg_Node_2
:= Inst_Id
;
8267 Error_Msg_Sloc
:= Sloc
(Inst
);
8269 if Nkind
(Inst
) = N_Function_Instantiation
then
8270 Output_Instantiation
(Gen_Id
, "function");
8272 elsif Nkind
(Inst
) = N_Package_Instantiation
then
8273 Output_Instantiation
(Gen_Id
, "package");
8275 elsif Nkind
(Inst
) = N_Procedure_Instantiation
then
8276 Output_Instantiation
(Gen_Id
, "procedure");
8279 pragma Assert
(False);
8282 end Output_Instantiation
;
8284 ---------------------------------------
8285 -- Output_SPARK_Refined_State_Pragma --
8286 ---------------------------------------
8288 procedure Output_SPARK_Refined_State_Pragma
(N
: Node_Id
) is
8290 Error_Msg_Sloc
:= Sloc
(N
);
8291 Error_Msg_N
("\\ refinement constituents read #", Error_Nod
);
8292 end Output_SPARK_Refined_State_Pragma
;
8294 --------------------------------
8295 -- Output_Variable_Assignment --
8296 --------------------------------
8298 procedure Output_Variable_Assignment
(N
: Node_Id
) is
8299 Var_Id
: constant Entity_Id
:= Entity
(Extract_Assignment_Name
(N
));
8302 Error_Msg_Sloc
:= Sloc
(N
);
8303 Error_Msg_NE
("\\ variable & assigned #", Error_Nod
, Var_Id
);
8304 end Output_Variable_Assignment
;
8306 -------------------------------
8307 -- Output_Variable_Reference --
8308 -------------------------------
8310 procedure Output_Variable_Reference
(N
: Node_Id
) is
8311 Dummy
: Variable_Attributes
;
8315 Extract_Variable_Reference_Attributes
8320 Error_Msg_Sloc
:= Sloc
(N
);
8323 Error_Msg_NE
("\\ variable & read #", Error_Nod
, Var_Id
);
8326 pragma Assert
(False);
8329 end Output_Variable_Reference
;
8333 package Stack
renames Scenario_Stack
;
8335 Dummy
: Call_Attributes
;
8338 Target_Id
: Entity_Id
;
8340 -- Start of processing for Output_Active_Scenarios
8343 -- Active scenarios are emitted only when the static model is in effect
8344 -- because there is an inherent order by which all these scenarios were
8345 -- reached from the declaration or library level.
8347 if not Static_Elaboration_Checks
then
8353 for Index
in Stack
.First
.. Stack
.Last
loop
8354 N
:= Stack
.Table
(Index
);
8363 if Nkind
(N
) = N_Attribute_Reference
then
8368 elsif Is_Suitable_Call
(N
) then
8369 Extract_Call_Attributes
8371 Target_Id
=> Target_Id
,
8374 if Is_Activation_Proc
(Target_Id
) then
8375 Output_Activation_Call
(N
);
8377 Output_Call
(N
, Target_Id
);
8382 elsif Is_Suitable_Instantiation
(N
) then
8383 Output_Instantiation
(N
);
8385 -- Pragma Refined_State
8387 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
8388 Output_SPARK_Refined_State_Pragma
(N
);
8390 -- Variable assignments
8392 elsif Nkind
(N
) = N_Assignment_Statement
then
8393 Output_Variable_Assignment
(N
);
8395 -- Variable references
8397 elsif Is_Suitable_Variable_Reference
(N
) then
8398 Output_Variable_Reference
(N
);
8401 pragma Assert
(False);
8405 end Output_Active_Scenarios
;
8407 -------------------------
8408 -- Pop_Active_Scenario --
8409 -------------------------
8411 procedure Pop_Active_Scenario
(N
: Node_Id
) is
8412 Top
: Node_Id
renames Scenario_Stack
.Table
(Scenario_Stack
.Last
);
8415 pragma Assert
(Top
= N
);
8416 Scenario_Stack
.Decrement_Last
;
8417 end Pop_Active_Scenario
;
8419 --------------------------------
8420 -- Process_Activation_Generic --
8421 --------------------------------
8423 procedure Process_Activation_Generic
8425 Call_Attrs
: Call_Attributes
;
8426 State
: Processing_Attributes
)
8428 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
);
8429 -- Perform ABE checks and diagnostics for object Obj_Id with type Typ.
8430 -- Typ may be a task type or a composite type with at least one task
8433 procedure Process_Task_Objects
(List
: List_Id
);
8434 -- Perform ABE checks and diagnostics for all task objects found in the
8437 -------------------------
8438 -- Process_Task_Object --
8439 -------------------------
8441 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
) is
8442 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
8444 Comp_Id
: Entity_Id
;
8445 Task_Attrs
: Task_Attributes
;
8447 New_State
: Processing_Attributes
:= State
;
8448 -- Each step of the Processing phase constitutes a new state
8451 if Is_Task_Type
(Typ
) then
8452 Extract_Task_Attributes
8454 Attrs
=> Task_Attrs
);
8456 -- Warnings are suppressed when a prior scenario is already in
8457 -- that mode, or when the object, activation call, or task type
8458 -- have warnings suppressed. Update the state of the Processing
8459 -- phase to reflect this.
8461 New_State
.Suppress_Warnings
:=
8462 New_State
.Suppress_Warnings
8463 or else not Is_Elaboration_Warnings_OK_Id
(Obj_Id
)
8464 or else not Call_Attrs
.Elab_Warnings_OK
8465 or else not Task_Attrs
.Elab_Warnings_OK
;
8467 -- Update the state of the Processing phase to indicate that any
8468 -- further traversal is now within a task body.
8470 New_State
.Within_Task_Body
:= True;
8472 Process_Single_Activation
8474 Call_Attrs
=> Call_Attrs
,
8476 Task_Attrs
=> Task_Attrs
,
8477 State
=> New_State
);
8479 -- Examine the component type when the object is an array
8481 elsif Is_Array_Type
(Typ
) and then Has_Task
(Base_Typ
) then
8484 Typ
=> Component_Type
(Typ
));
8486 -- Examine individual component types when the object is a record
8488 elsif Is_Record_Type
(Typ
) and then Has_Task
(Base_Typ
) then
8489 Comp_Id
:= First_Component
(Typ
);
8490 while Present
(Comp_Id
) loop
8493 Typ
=> Etype
(Comp_Id
));
8495 Next_Component
(Comp_Id
);
8498 end Process_Task_Object
;
8500 --------------------------
8501 -- Process_Task_Objects --
8502 --------------------------
8504 procedure Process_Task_Objects
(List
: List_Id
) is
8506 Item_Id
: Entity_Id
;
8507 Item_Typ
: Entity_Id
;
8510 -- Examine the contents of the list looking for an object declaration
8511 -- of a task type or one that contains a task within.
8513 Item
:= First
(List
);
8514 while Present
(Item
) loop
8515 if Nkind
(Item
) = N_Object_Declaration
then
8516 Item_Id
:= Defining_Entity
(Item
);
8517 Item_Typ
:= Etype
(Item_Id
);
8519 if Has_Task
(Item_Typ
) then
8528 end Process_Task_Objects
;
8535 -- Start of processing for Process_Activation_Generic
8538 -- Nothing to do when the activation is a guaranteed ABE
8540 if Is_Known_Guaranteed_ABE
(Call
) then
8544 -- Find the proper context of the activation call where all task objects
8545 -- being activated are declared. This is usually the immediate parent of
8548 Context
:= Parent
(Call
);
8550 -- In the case of package bodies, the activation call is in the handled
8551 -- sequence of statements, but the task objects are in the declaration
8552 -- list of the body.
8554 if Nkind
(Context
) = N_Handled_Sequence_Of_Statements
8555 and then Nkind
(Parent
(Context
)) = N_Package_Body
8557 Context
:= Parent
(Context
);
8560 -- Process all task objects defined in both the spec and body when the
8561 -- activation call precedes the "begin" of a package body.
8563 if Nkind
(Context
) = N_Package_Body
then
8566 (Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
8568 Process_Task_Objects
(Visible_Declarations
(Spec
));
8569 Process_Task_Objects
(Private_Declarations
(Spec
));
8570 Process_Task_Objects
(Declarations
(Context
));
8572 -- Process all task objects defined in the spec when the activation call
8573 -- appears at the end of a package spec.
8575 elsif Nkind
(Context
) = N_Package_Specification
then
8576 Process_Task_Objects
(Visible_Declarations
(Context
));
8577 Process_Task_Objects
(Private_Declarations
(Context
));
8579 -- Otherwise the context of the activation is some construct with a
8580 -- declarative part. Note that the corresponding record type of a task
8581 -- type is controlled. Because of this, the finalization machinery must
8582 -- relocate the task object to the handled statements of the construct
8583 -- to perform proper finalization in case of an exception. Examine the
8584 -- statements of the construct rather than the declarations.
8587 pragma Assert
(Nkind
(Context
) = N_Handled_Sequence_Of_Statements
);
8589 Process_Task_Objects
(Statements
(Context
));
8591 end Process_Activation_Generic
;
8593 ------------------------------------
8594 -- Process_Conditional_ABE_Access --
8595 ------------------------------------
8597 procedure Process_Conditional_ABE_Access
8599 State
: Processing_Attributes
)
8601 function Build_Access_Marker
(Target_Id
: Entity_Id
) return Node_Id
;
8602 pragma Inline
(Build_Access_Marker
);
8603 -- Create a suitable call marker which invokes target Target_Id
8605 -------------------------
8606 -- Build_Access_Marker --
8607 -------------------------
8609 function Build_Access_Marker
(Target_Id
: Entity_Id
) return Node_Id
is
8613 Marker
:= Make_Call_Marker
(Sloc
(Attr
));
8615 -- Inherit relevant attributes from the attribute
8617 -- Performance note: parent traversal
8619 Set_Target
(Marker
, Target_Id
);
8620 Set_Is_Declaration_Level_Node
8621 (Marker
, Find_Enclosing_Level
(Attr
) = Declaration_Level
);
8622 Set_Is_Dispatching_Call
8624 Set_Is_Elaboration_Checks_OK_Node
8625 (Marker
, Is_Elaboration_Checks_OK_Node
(Attr
));
8626 Set_Is_Elaboration_Warnings_OK_Node
8627 (Marker
, Is_Elaboration_Warnings_OK_Node
(Attr
));
8629 (Marker
, Comes_From_Source
(Attr
));
8630 Set_Is_SPARK_Mode_On_Node
8631 (Marker
, Is_SPARK_Mode_On_Node
(Attr
));
8633 -- Partially insert the call marker into the tree by setting its
8636 Set_Parent
(Marker
, Attr
);
8639 end Build_Access_Marker
;
8643 Root
: constant Node_Id
:= Root_Scenario
;
8644 Target_Id
: constant Entity_Id
:= Entity
(Prefix
(Attr
));
8646 Target_Attrs
: Target_Attributes
;
8648 New_State
: Processing_Attributes
:= State
;
8649 -- Each step of the Processing phase constitutes a new state
8651 -- Start of processing for Process_Conditional_ABE_Access
8654 -- Output relevant information when switch -gnatel (info messages on
8655 -- implicit Elaborate[_All] pragmas) is in effect.
8657 if Elab_Info_Messages
then
8659 ("info: access to & during elaboration", Attr
, Target_Id
);
8662 Extract_Target_Attributes
8663 (Target_Id
=> Target_Id
,
8664 Attrs
=> Target_Attrs
);
8666 -- Warnings are suppressed when a prior scenario is already in that
8667 -- mode, or when the attribute or the target have warnings suppressed.
8668 -- Update the state of the Processing phase to reflect this.
8670 New_State
.Suppress_Warnings
:=
8671 New_State
.Suppress_Warnings
8672 or else not Is_Elaboration_Warnings_OK_Node
(Attr
)
8673 or else not Target_Attrs
.Elab_Warnings_OK
;
8675 -- Do not emit any ABE diagnostics when the current or previous scenario
8676 -- in this traversal has suppressed elaboration warnings.
8678 if New_State
.Suppress_Warnings
then
8681 -- Both the attribute and the corresponding body are in the same unit.
8682 -- The corresponding body must appear prior to the root scenario which
8683 -- started the recursive search. If this is not the case, then there is
8684 -- a potential ABE if the access value is used to call the subprogram.
8685 -- Emit a warning only when switch -gnatw.f (warnings on suspucious
8686 -- 'Access) is in effect.
8688 elsif Warn_On_Elab_Access
8689 and then Present
(Target_Attrs
.Body_Decl
)
8690 and then In_Extended_Main_Code_Unit
(Target_Attrs
.Body_Decl
)
8691 and then Earlier_In_Extended_Unit
(Root
, Target_Attrs
.Body_Decl
)
8693 Error_Msg_Name_1
:= Attribute_Name
(Attr
);
8694 Error_Msg_NE
("??% attribute of & before body seen", Attr
, Target_Id
);
8695 Error_Msg_N
("\possible Program_Error on later references", Attr
);
8697 Output_Active_Scenarios
(Attr
);
8700 -- Treat the attribute as an immediate invocation of the target when
8701 -- switch -gnatd.o (conservative elaboration order for indirect calls)
8702 -- is in effect. Note that the prior elaboration of the unit containing
8703 -- the target is ensured processing the corresponding call marker.
8705 if Debug_Flag_Dot_O
then
8706 Process_Conditional_ABE
8707 (N
=> Build_Access_Marker
(Target_Id
),
8708 State
=> New_State
);
8710 -- Otherwise ensure that the unit with the corresponding body is
8711 -- elaborated prior to the main unit.
8714 Ensure_Prior_Elaboration
8716 Unit_Id
=> Target_Attrs
.Unit_Id
,
8717 Prag_Nam
=> Name_Elaborate_All
,
8718 State
=> New_State
);
8720 end Process_Conditional_ABE_Access
;
8722 ---------------------------------------------
8723 -- Process_Conditional_ABE_Activation_Impl --
8724 ---------------------------------------------
8726 procedure Process_Conditional_ABE_Activation_Impl
8728 Call_Attrs
: Call_Attributes
;
8730 Task_Attrs
: Task_Attributes
;
8731 State
: Processing_Attributes
)
8733 Check_OK
: constant Boolean :=
8734 not Is_Ignored_Ghost_Entity
(Obj_Id
)
8735 and then not Task_Attrs
.Ghost_Mode_Ignore
8736 and then Is_Elaboration_Checks_OK_Id
(Obj_Id
)
8737 and then Task_Attrs
.Elab_Checks_OK
;
8738 -- A run-time ABE check may be installed only when the object and the
8739 -- task type have active elaboration checks, and both are not ignored
8740 -- Ghost constructs.
8742 Root
: constant Node_Id
:= Root_Scenario
;
8744 New_State
: Processing_Attributes
:= State
;
8745 -- Each step of the Processing phase constitutes a new state
8748 -- Output relevant information when switch -gnatel (info messages on
8749 -- implicit Elaborate[_All] pragmas) is in effect.
8751 if Elab_Info_Messages
then
8753 ("info: activation of & during elaboration", Call
, Obj_Id
);
8756 -- Nothing to do when the call activates a task whose type is defined
8757 -- within an instance and switch -gnatd_i (ignore activations and calls
8758 -- to instances for elaboration) is in effect.
8760 if Debug_Flag_Underscore_I
8761 and then In_External_Instance
8763 Target_Decl
=> Task_Attrs
.Task_Decl
)
8767 -- Nothing to do when the activation is a guaranteed ABE
8769 elsif Is_Known_Guaranteed_ABE
(Call
) then
8772 -- Nothing to do when the root scenario appears at the declaration
8773 -- level and the task is in the same unit, but outside this context.
8775 -- task type Task_Typ; -- task declaration
8777 -- procedure Proc is
8778 -- function A ... is
8780 -- if Some_Condition then
8784 -- <activation call> -- activation site
8789 -- X : ... := A; -- root scenario
8792 -- task body Task_Typ is
8796 -- In the example above, the context of X is the declarative list of
8797 -- Proc. The "elaboration" of X may reach the activation of T whose body
8798 -- is defined outside of X's context. The task body is relevant only
8799 -- when Proc is invoked, but this happens only in "normal" elaboration,
8800 -- therefore the task body must not be considered if this is not the
8803 -- Performance note: parent traversal
8805 elsif Is_Up_Level_Target
(Task_Attrs
.Task_Decl
) then
8808 -- Nothing to do when the activation is ABE-safe
8812 -- task type Task_Typ;
8815 -- package body Gen is
8816 -- task body Task_Typ is
8823 -- procedure Main is
8824 -- package Nested is
8825 -- package Inst is new Gen;
8826 -- T : Inst.Task_Typ;
8827 -- <activation call> -- safe activation
8831 elsif Is_Safe_Activation
(Call
, Task_Attrs
.Task_Decl
) then
8833 -- Note that the task body must still be examined for any nested
8838 -- The activation call and the task body are both in the main unit
8840 elsif Present
(Task_Attrs
.Body_Decl
)
8841 and then In_Extended_Main_Code_Unit
(Task_Attrs
.Body_Decl
)
8843 -- If the root scenario appears prior to the task body, then this is
8844 -- a possible ABE with respect to the root scenario.
8846 -- task type Task_Typ;
8848 -- function A ... is
8850 -- if Some_Condition then
8854 -- end Pack; -- activation of T
8858 -- X : ... := A; -- root scenario
8860 -- task body Task_Typ is -- task body
8864 -- Y : ... := A; -- root scenario
8866 -- IMPORTANT: The activation of T is a possible ABE for X, but
8867 -- not for Y. Intalling an unconditional ABE raise prior to the
8868 -- activation call would be wrong as it will fail for Y as well
8869 -- but in Y's case the activation of T is never an ABE.
8871 if Earlier_In_Extended_Unit
(Root
, Task_Attrs
.Body_Decl
) then
8873 -- Do not emit any ABE diagnostics when a previous scenario in
8874 -- this traversal has suppressed elaboration warnings.
8876 if State
.Suppress_Warnings
then
8879 -- Do not emit any ABE diagnostics when the activation occurs in
8880 -- a partial finalization context because this leads to confusing
8883 elsif State
.Within_Partial_Finalization
then
8886 -- ABE diagnostics are emitted only in the static model because
8887 -- there is a well-defined order to visiting scenarios. Without
8888 -- this order diagnostics appear jumbled and result in unwanted
8891 elsif Static_Elaboration_Checks
then
8892 Error_Msg_Sloc
:= Sloc
(Call
);
8894 ("??task & will be activated # before elaboration of its "
8897 ("\Program_Error may be raised at run time", Obj_Id
);
8899 Output_Active_Scenarios
(Obj_Id
);
8902 -- Install a conditional run-time ABE check to verify that the
8903 -- task body has been elaborated prior to the activation call.
8909 Target_Id
=> Task_Attrs
.Spec_Id
,
8910 Target_Decl
=> Task_Attrs
.Task_Decl
,
8911 Target_Body
=> Task_Attrs
.Body_Decl
);
8913 -- Update the state of the Processing phase to indicate that
8914 -- no implicit Elaborate[_All] pragmas must be generated from
8917 -- task type Task_Typ;
8919 -- function A ... is
8921 -- if Some_Condition then
8926 -- end Pack; -- activation of T
8932 -- task body Task_Typ is
8934 -- External.Subp; -- imparts Elaborate_All
8937 -- If Some_Condition is True, then the ABE check will fail at
8938 -- runtime and the call to External.Subp will never take place,
8939 -- rendering the implicit Elaborate_All useless.
8941 -- If Some_Condition is False, then the call to External.Subp
8942 -- will never take place, rendering the implicit Elaborate_All
8945 New_State
.Suppress_Implicit_Pragmas
:= True;
8949 -- Otherwise the task body is not available in this compilation or it
8950 -- resides in an external unit. Install a run-time ABE check to verify
8951 -- that the task body has been elaborated prior to the activation call
8952 -- when the dynamic model is in effect.
8954 elsif Dynamic_Elaboration_Checks
and then Check_OK
then
8958 Id
=> Task_Attrs
.Unit_Id
);
8961 -- Both the activation call and task type are subject to SPARK_Mode
8962 -- On, this triggers the SPARK rules for task activation. Compared to
8963 -- calls and instantiations, task activation in SPARK does not require
8964 -- the presence of Elaborate[_All] pragmas in case the task type is
8965 -- defined outside the main unit. This is because SPARK utilizes a
8966 -- special policy which activates all tasks after the main unit has
8967 -- finished its elaboration.
8969 if Call_Attrs
.SPARK_Mode_On
and Task_Attrs
.SPARK_Mode_On
then
8972 -- Otherwise the Ada rules are in effect. Ensure that the unit with the
8973 -- task body is elaborated prior to the main unit.
8976 Ensure_Prior_Elaboration
8978 Unit_Id
=> Task_Attrs
.Unit_Id
,
8979 Prag_Nam
=> Name_Elaborate_All
,
8980 State
=> New_State
);
8984 (N
=> Task_Attrs
.Body_Decl
,
8985 State
=> New_State
);
8986 end Process_Conditional_ABE_Activation_Impl
;
8988 procedure Process_Conditional_ABE_Activation
is
8989 new Process_Activation_Generic
(Process_Conditional_ABE_Activation_Impl
);
8991 ----------------------------------
8992 -- Process_Conditional_ABE_Call --
8993 ----------------------------------
8995 procedure Process_Conditional_ABE_Call
8997 Call_Attrs
: Call_Attributes
;
8998 Target_Id
: Entity_Id
;
8999 State
: Processing_Attributes
)
9001 function In_Initialization_Context
(N
: Node_Id
) return Boolean;
9002 -- Determine whether arbitrary node N appears within a type init proc,
9003 -- primitive [Deep_]Initialize, or a block created for initialization
9006 function Is_Partial_Finalization_Proc
return Boolean;
9007 pragma Inline
(Is_Partial_Finalization_Proc
);
9008 -- Determine whether call Call with target Target_Id invokes a partial
9009 -- finalization procedure.
9011 -------------------------------
9012 -- In_Initialization_Context --
9013 -------------------------------
9015 function In_Initialization_Context
(N
: Node_Id
) return Boolean is
9017 Spec_Id
: Entity_Id
;
9020 -- Climb the parent chain looking for initialization actions
9023 while Present
(Par
) loop
9025 -- A block may be part of the initialization actions of a default
9026 -- initialized object.
9028 if Nkind
(Par
) = N_Block_Statement
9029 and then Is_Initialization_Block
(Par
)
9033 -- A subprogram body may denote an initialization routine
9035 elsif Nkind
(Par
) = N_Subprogram_Body
then
9036 Spec_Id
:= Unique_Defining_Entity
(Par
);
9038 -- The current subprogram body denotes a type init proc or
9039 -- primitive [Deep_]Initialize.
9041 if Is_Init_Proc
(Spec_Id
)
9042 or else Is_Controlled_Proc
(Spec_Id
, Name_Initialize
)
9043 or else Is_TSS
(Spec_Id
, TSS_Deep_Initialize
)
9048 -- Prevent the search from going too far
9050 elsif Is_Body_Or_Package_Declaration
(Par
) then
9054 Par
:= Parent
(Par
);
9058 end In_Initialization_Context
;
9060 ----------------------------------
9061 -- Is_Partial_Finalization_Proc --
9062 ----------------------------------
9064 function Is_Partial_Finalization_Proc
return Boolean is
9066 -- To qualify, the target must denote primitive [Deep_]Finalize or a
9067 -- finalizer procedure, and the call must appear in an initialization
9071 (Is_Controlled_Proc
(Target_Id
, Name_Finalize
)
9072 or else Is_Finalizer_Proc
(Target_Id
)
9073 or else Is_TSS
(Target_Id
, TSS_Deep_Finalize
))
9074 and then In_Initialization_Context
(Call
);
9075 end Is_Partial_Finalization_Proc
;
9079 SPARK_Rules_On
: Boolean;
9080 Target_Attrs
: Target_Attributes
;
9082 New_State
: Processing_Attributes
:= State
;
9083 -- Each step of the Processing phase constitutes a new state
9085 -- Start of processing for Process_Conditional_ABE_Call
9088 Extract_Target_Attributes
9089 (Target_Id
=> Target_Id
,
9090 Attrs
=> Target_Attrs
);
9092 -- The SPARK rules are in effect when both the call and target are
9093 -- subject to SPARK_Mode On.
9096 Call_Attrs
.SPARK_Mode_On
and Target_Attrs
.SPARK_Mode_On
;
9098 -- Output relevant information when switch -gnatel (info messages on
9099 -- implicit Elaborate[_All] pragmas) is in effect.
9101 if Elab_Info_Messages
then
9104 Target_Id
=> Target_Id
,
9106 In_SPARK
=> SPARK_Rules_On
);
9109 -- Check whether the invocation of an entry clashes with an existing
9112 if Is_Protected_Entry
(Target_Id
) then
9113 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
9115 elsif Is_Task_Entry
(Target_Id
) then
9116 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
9118 -- Task entry calls are never processed because the entry being
9119 -- invoked does not have a corresponding "body", it has a select.
9124 -- Nothing to do when the call invokes a target defined within an
9125 -- instance and switch -gnatd_i (ignore activations and calls to
9126 -- instances for elaboration) is in effect.
9128 if Debug_Flag_Underscore_I
9129 and then In_External_Instance
9131 Target_Decl
=> Target_Attrs
.Spec_Decl
)
9135 -- Nothing to do when the call is a guaranteed ABE
9137 elsif Is_Known_Guaranteed_ABE
(Call
) then
9140 -- Nothing to do when the root scenario appears at the declaration level
9141 -- and the target is in the same unit, but outside this context.
9143 -- function B ...; -- target declaration
9145 -- procedure Proc is
9146 -- function A ... is
9148 -- if Some_Condition then
9149 -- return B; -- call site
9153 -- X : ... := A; -- root scenario
9156 -- function B ... is
9160 -- In the example above, the context of X is the declarative region of
9161 -- Proc. The "elaboration" of X may eventually reach B which is defined
9162 -- outside of X's context. B is relevant only when Proc is invoked, but
9163 -- this happens only by means of "normal" elaboration, therefore B must
9164 -- not be considered if this is not the case.
9166 -- Performance note: parent traversal
9168 elsif Is_Up_Level_Target
(Target_Attrs
.Spec_Decl
) then
9172 -- Warnings are suppressed when a prior scenario is already in that
9173 -- mode, or the call or target have warnings suppressed. Update the
9174 -- state of the Processing phase to reflect this.
9176 New_State
.Suppress_Warnings
:=
9177 New_State
.Suppress_Warnings
9178 or else not Call_Attrs
.Elab_Warnings_OK
9179 or else not Target_Attrs
.Elab_Warnings_OK
;
9181 -- The call occurs in an initial condition context when a prior scenario
9182 -- is already in that mode, or when the target is an Initial_Condition
9183 -- procedure. Update the state of the Processing phase to reflect this.
9185 New_State
.Within_Initial_Condition
:=
9186 New_State
.Within_Initial_Condition
9187 or else Is_Initial_Condition_Proc
(Target_Id
);
9189 -- The call occurs in a partial finalization context when a prior
9190 -- scenario is already in that mode, or when the target denotes a
9191 -- [Deep_]Finalize primitive or a finalizer within an initialization
9192 -- context. Update the state of the Processing phase to reflect this.
9194 New_State
.Within_Partial_Finalization
:=
9195 New_State
.Within_Partial_Finalization
9196 or else Is_Partial_Finalization_Proc
;
9198 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK
9199 -- elaboration rules in SPARK code) is intentionally not taken into
9200 -- account here because Process_Conditional_ABE_Call_SPARK has two
9201 -- separate modes of operation.
9203 if SPARK_Rules_On
then
9204 Process_Conditional_ABE_Call_SPARK
9206 Target_Id
=> Target_Id
,
9207 Target_Attrs
=> Target_Attrs
,
9208 State
=> New_State
);
9210 -- Otherwise the Ada rules are in effect
9213 Process_Conditional_ABE_Call_Ada
9215 Call_Attrs
=> Call_Attrs
,
9216 Target_Id
=> Target_Id
,
9217 Target_Attrs
=> Target_Attrs
,
9218 State
=> New_State
);
9221 -- Inspect the target body (and barried function) for other suitable
9222 -- elaboration scenarios.
9225 (N
=> Target_Attrs
.Body_Barf
,
9226 State
=> New_State
);
9229 (N
=> Target_Attrs
.Body_Decl
,
9230 State
=> New_State
);
9231 end Process_Conditional_ABE_Call
;
9233 --------------------------------------
9234 -- Process_Conditional_ABE_Call_Ada --
9235 --------------------------------------
9237 procedure Process_Conditional_ABE_Call_Ada
9239 Call_Attrs
: Call_Attributes
;
9240 Target_Id
: Entity_Id
;
9241 Target_Attrs
: Target_Attributes
;
9242 State
: Processing_Attributes
)
9244 Check_OK
: constant Boolean :=
9245 not Call_Attrs
.Ghost_Mode_Ignore
9246 and then not Target_Attrs
.Ghost_Mode_Ignore
9247 and then Call_Attrs
.Elab_Checks_OK
9248 and then Target_Attrs
.Elab_Checks_OK
;
9249 -- A run-time ABE check may be installed only when both the call and the
9250 -- target have active elaboration checks, and both are not ignored Ghost
9253 Root
: constant Node_Id
:= Root_Scenario
;
9255 New_State
: Processing_Attributes
:= State
;
9256 -- Each step of the Processing phase constitutes a new state
9259 -- Nothing to do for an Ada dispatching call because there are no ABE
9260 -- diagnostics for either models. ABE checks for the dynamic model are
9261 -- handled by Install_Primitive_Elaboration_Check.
9263 if Call_Attrs
.Is_Dispatching
then
9266 -- Nothing to do when the call is ABE-safe
9269 -- function Gen ...;
9271 -- function Gen ... is
9277 -- procedure Main is
9278 -- function Inst is new Gen;
9279 -- X : ... := Inst; -- safe call
9282 elsif Is_Safe_Call
(Call
, Target_Attrs
) then
9285 -- The call and the target body are both in the main unit
9287 elsif Present
(Target_Attrs
.Body_Decl
)
9288 and then In_Extended_Main_Code_Unit
(Target_Attrs
.Body_Decl
)
9290 -- If the root scenario appears prior to the target body, then this
9291 -- is a possible ABE with respect to the root scenario.
9295 -- function A ... is
9297 -- if Some_Condition then
9298 -- return B; -- call site
9302 -- X : ... := A; -- root scenario
9304 -- function B ... is -- target body
9308 -- Y : ... := A; -- root scenario
9310 -- IMPORTANT: The call to B from A is a possible ABE for X, but not
9311 -- for Y. Installing an unconditional ABE raise prior to the call to
9312 -- B would be wrong as it will fail for Y as well, but in Y's case
9313 -- the call to B is never an ABE.
9315 if Earlier_In_Extended_Unit
(Root
, Target_Attrs
.Body_Decl
) then
9317 -- Do not emit any ABE diagnostics when a previous scenario in
9318 -- this traversal has suppressed elaboration warnings.
9320 if State
.Suppress_Warnings
then
9323 -- Do not emit any ABE diagnostics when the call occurs in a
9324 -- partial finalization context because this leads to confusing
9327 elsif State
.Within_Partial_Finalization
then
9330 -- ABE diagnostics are emitted only in the static model because
9331 -- there is a well-defined order to visiting scenarios. Without
9332 -- this order diagnostics appear jumbled and result in unwanted
9335 elsif Static_Elaboration_Checks
then
9337 ("??cannot call & before body seen", Call
, Target_Id
);
9338 Error_Msg_N
("\Program_Error may be raised at run time", Call
);
9340 Output_Active_Scenarios
(Call
);
9343 -- Install a conditional run-time ABE check to verify that the
9344 -- target body has been elaborated prior to the call.
9350 Target_Id
=> Target_Attrs
.Spec_Id
,
9351 Target_Decl
=> Target_Attrs
.Spec_Decl
,
9352 Target_Body
=> Target_Attrs
.Body_Decl
);
9354 -- Update the state of the Processing phase to indicate that
9355 -- no implicit Elaborate[_All] pragmas must be generated from
9360 -- function A ... is
9362 -- if Some_Condition then
9370 -- function B ... is
9371 -- External.Subp; -- imparts Elaborate_All
9374 -- If Some_Condition is True, then the ABE check will fail at
9375 -- runtime and the call to External.Subp will never take place,
9376 -- rendering the implicit Elaborate_All useless.
9378 -- If Some_Condition is False, then the call to External.Subp
9379 -- will never take place, rendering the implicit Elaborate_All
9382 New_State
.Suppress_Implicit_Pragmas
:= True;
9386 -- Otherwise the target body is not available in this compilation or it
9387 -- resides in an external unit. Install a run-time ABE check to verify
9388 -- that the target body has been elaborated prior to the call site when
9389 -- the dynamic model is in effect.
9391 elsif Dynamic_Elaboration_Checks
and then Check_OK
then
9395 Id
=> Target_Attrs
.Unit_Id
);
9398 -- Ensure that the unit with the target body is elaborated prior to the
9399 -- main unit. The implicit Elaborate[_All] is generated only when the
9400 -- call has elaboration checks enabled. This behaviour parallels that of
9401 -- the old ABE mechanism.
9403 if Call_Attrs
.Elab_Checks_OK
then
9404 Ensure_Prior_Elaboration
9406 Unit_Id
=> Target_Attrs
.Unit_Id
,
9407 Prag_Nam
=> Name_Elaborate_All
,
9408 State
=> New_State
);
9410 end Process_Conditional_ABE_Call_Ada
;
9412 ----------------------------------------
9413 -- Process_Conditional_ABE_Call_SPARK --
9414 ----------------------------------------
9416 procedure Process_Conditional_ABE_Call_SPARK
9418 Target_Id
: Entity_Id
;
9419 Target_Attrs
: Target_Attributes
;
9420 State
: Processing_Attributes
)
9425 -- Ensure that a suitable elaboration model is in effect for SPARK rule
9428 Check_SPARK_Model_In_Effect
(Call
);
9430 -- The call and the target body are both in the main unit
9432 if Present
(Target_Attrs
.Body_Decl
)
9433 and then In_Extended_Main_Code_Unit
(Target_Attrs
.Body_Decl
)
9435 -- If the call appears prior to the target body, then the call must
9436 -- appear within the early call region of the target body.
9440 -- X : ... := B; -- call site
9442 -- <preelaborable construct 1> --+
9443 -- ... | early call region
9444 -- <preelaborable construct N> --+
9446 -- function B ... is -- target body
9450 -- When the call to B is not nested within some other scenario, the
9451 -- call is automatically illegal because it can never appear in the
9452 -- early call region of B's body. This is equivalent to a guaranteed
9455 -- <preelaborable construct 1> --+
9457 -- function B ...; |
9459 -- function A ... is |
9460 -- begin | early call region
9461 -- if Some_Condition then
9462 -- return B; -- call site
9466 -- <preelaborable construct N> --+
9468 -- function B ... is -- target body
9472 -- When the call to B is nested within some other scenario, the call
9473 -- is always ABE-safe. It is not immediately obvious why this is the
9474 -- case. The elaboration safety follows from the early call region
9475 -- rule being applied to ALL calls preceding their associated bodies.
9477 -- In the example above, the call to B is safe as long as the call to
9478 -- A is safe. There are several cases to consider:
9484 -- function A ... is
9486 -- if Some_Condition then
9492 -- function B ... is
9496 -- * Call 1 - This call is either nested within some scenario or not,
9497 -- which falls under the two general cases outlined above.
9499 -- * Call 2 - This is the same case as Call 1.
9501 -- * Call 3 - The placement of this call limits the range of B's
9502 -- early call region unto call 3, therefore the call to B is no
9503 -- longer within the early call region of B's body, making it ABE-
9504 -- unsafe and therefore illegal.
9506 if Earlier_In_Extended_Unit
(Call
, Target_Attrs
.Body_Decl
) then
9508 -- Do not emit any ABE diagnostics when a previous scenario in
9509 -- this traversal has suppressed elaboration warnings.
9511 if State
.Suppress_Warnings
then
9514 -- Do not emit any ABE diagnostics when the call occurs in an
9515 -- initial condition context because this leads to incorrect
9518 elsif State
.Within_Initial_Condition
then
9521 -- Do not emit any ABE diagnostics when the call occurs in a
9522 -- partial finalization context because this leads to confusing
9525 elsif State
.Within_Partial_Finalization
then
9528 -- ABE diagnostics are emitted only in the static model because
9529 -- there is a well-defined order to visiting scenarios. Without
9530 -- this order diagnostics appear jumbled and result in unwanted
9533 elsif Static_Elaboration_Checks
then
9535 -- Ensure that a call which textually precedes the subprogram
9536 -- body it invokes appears within the early call region of the
9539 -- IMPORTANT: This check must always be performed even when
9540 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is
9541 -- not specified because the static model cannot guarantee the
9542 -- absence of elaboration issues in the presence of dispatching
9545 Region
:= Find_Early_Call_Region
(Target_Attrs
.Body_Decl
);
9547 if Earlier_In_Extended_Unit
(Call
, Region
) then
9549 ("call must appear within early call region of subprogram "
9550 & "body & (SPARK RM 7.7(3))", Call
, Target_Id
);
9552 Error_Msg_Sloc
:= Sloc
(Region
);
9553 Error_Msg_N
("\region starts #", Call
);
9555 Error_Msg_Sloc
:= Sloc
(Target_Attrs
.Body_Decl
);
9556 Error_Msg_N
("\region ends #", Call
);
9558 Output_Active_Scenarios
(Call
);
9562 -- Otherwise the call appears after the target body. The call is
9563 -- ABE-safe as a consequence of applying the early call region rule
9564 -- to ALL calls preceding their associated bodies.
9571 -- A call to a source target or to a target which emulates Ada or SPARK
9572 -- semantics imposes an Elaborate_All requirement on the context of the
9573 -- main unit. Determine whether the context has a pragma strong enough
9574 -- to meet the requirement.
9576 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce
9577 -- SPARK elaboration rules in SPARK code) is active because the static
9578 -- model can ensure the prior elaboration of the unit which contains a
9579 -- body by installing an implicit Elaborate[_All] pragma.
9581 if Debug_Flag_Dot_V
then
9582 if Target_Attrs
.From_Source
9583 or else Is_Ada_Semantic_Target
(Target_Id
)
9584 or else Is_SPARK_Semantic_Target
(Target_Id
)
9586 Meet_Elaboration_Requirement
9588 Target_Id
=> Target_Id
,
9589 Req_Nam
=> Name_Elaborate_All
);
9592 -- Otherwise ensure that the unit with the target body is elaborated
9593 -- prior to the main unit.
9596 Ensure_Prior_Elaboration
9598 Unit_Id
=> Target_Attrs
.Unit_Id
,
9599 Prag_Nam
=> Name_Elaborate_All
,
9602 end Process_Conditional_ABE_Call_SPARK
;
9604 -------------------------------------------
9605 -- Process_Conditional_ABE_Instantiation --
9606 -------------------------------------------
9608 procedure Process_Conditional_ABE_Instantiation
9609 (Exp_Inst
: Node_Id
;
9610 State
: Processing_Attributes
)
9612 Gen_Attrs
: Target_Attributes
;
9615 Inst_Attrs
: Instantiation_Attributes
;
9616 Inst_Id
: Entity_Id
;
9618 SPARK_Rules_On
: Boolean;
9619 -- This flag is set when the SPARK rules are in effect
9621 New_State
: Processing_Attributes
:= State
;
9622 -- Each step of the Processing phase constitutes a new state
9625 Extract_Instantiation_Attributes
9626 (Exp_Inst
=> Exp_Inst
,
9630 Attrs
=> Inst_Attrs
);
9632 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
9634 -- The SPARK rules are in effect when both the instantiation and generic
9635 -- are subject to SPARK_Mode On.
9637 SPARK_Rules_On
:= Inst_Attrs
.SPARK_Mode_On
and Gen_Attrs
.SPARK_Mode_On
;
9639 -- Output relevant information when switch -gnatel (info messages on
9640 -- implicit Elaborate[_All] pragmas) is in effect.
9642 if Elab_Info_Messages
then
9647 In_SPARK
=> SPARK_Rules_On
);
9650 -- Nothing to do when the instantiation is a guaranteed ABE
9652 if Is_Known_Guaranteed_ABE
(Inst
) then
9655 -- Nothing to do when the root scenario appears at the declaration level
9656 -- and the generic is in the same unit, but outside this context.
9659 -- procedure Gen is ...; -- generic declaration
9661 -- procedure Proc is
9662 -- function A ... is
9664 -- if Some_Condition then
9666 -- procedure I is new Gen; -- instantiation site
9671 -- X : ... := A; -- root scenario
9678 -- In the example above, the context of X is the declarative region of
9679 -- Proc. The "elaboration" of X may eventually reach Gen which appears
9680 -- outside of X's context. Gen is relevant only when Proc is invoked,
9681 -- but this happens only by means of "normal" elaboration, therefore
9682 -- Gen must not be considered if this is not the case.
9684 -- Performance note: parent traversal
9686 elsif Is_Up_Level_Target
(Gen_Attrs
.Spec_Decl
) then
9690 -- Warnings are suppressed when a prior scenario is already in that
9691 -- mode, or when the instantiation has warnings suppressed. Update
9692 -- the state of the processing phase to reflect this.
9694 New_State
.Suppress_Warnings
:=
9695 New_State
.Suppress_Warnings
or else not Inst_Attrs
.Elab_Warnings_OK
;
9697 -- The SPARK rules are in effect
9699 if SPARK_Rules_On
then
9700 Process_Conditional_ABE_Instantiation_SPARK
9703 Gen_Attrs
=> Gen_Attrs
,
9704 State
=> New_State
);
9706 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
9707 -- violate the SPARK rules.
9710 Process_Conditional_ABE_Instantiation_Ada
9711 (Exp_Inst
=> Exp_Inst
,
9713 Inst_Attrs
=> Inst_Attrs
,
9715 Gen_Attrs
=> Gen_Attrs
,
9716 State
=> New_State
);
9718 end Process_Conditional_ABE_Instantiation
;
9720 -----------------------------------------------
9721 -- Process_Conditional_ABE_Instantiation_Ada --
9722 -----------------------------------------------
9724 procedure Process_Conditional_ABE_Instantiation_Ada
9725 (Exp_Inst
: Node_Id
;
9727 Inst_Attrs
: Instantiation_Attributes
;
9729 Gen_Attrs
: Target_Attributes
;
9730 State
: Processing_Attributes
)
9732 Check_OK
: constant Boolean :=
9733 not Inst_Attrs
.Ghost_Mode_Ignore
9734 and then not Gen_Attrs
.Ghost_Mode_Ignore
9735 and then Inst_Attrs
.Elab_Checks_OK
9736 and then Gen_Attrs
.Elab_Checks_OK
;
9737 -- A run-time ABE check may be installed only when both the instance and
9738 -- the generic have active elaboration checks and both are not ignored
9739 -- Ghost constructs.
9741 Root
: constant Node_Id
:= Root_Scenario
;
9743 New_State
: Processing_Attributes
:= State
;
9744 -- Each step of the Processing phase constitutes a new state
9747 -- Nothing to do when the instantiation is ABE-safe
9754 -- package body Gen is
9759 -- procedure Main is
9760 -- package Inst is new Gen (ABE); -- safe instantiation
9763 if Is_Safe_Instantiation
(Inst
, Gen_Attrs
) then
9766 -- The instantiation and the generic body are both in the main unit
9768 elsif Present
(Gen_Attrs
.Body_Decl
)
9769 and then In_Extended_Main_Code_Unit
(Gen_Attrs
.Body_Decl
)
9771 -- If the root scenario appears prior to the generic body, then this
9772 -- is a possible ABE with respect to the root scenario.
9779 -- function A ... is
9781 -- if Some_Condition then
9783 -- package Inst is new Gen; -- instantiation site
9787 -- X : ... := A; -- root scenario
9789 -- package body Gen is -- generic body
9793 -- Y : ... := A; -- root scenario
9795 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but
9796 -- not for Y. Installing an unconditional ABE raise prior to the
9797 -- instance site would be wrong as it will fail for Y as well, but in
9798 -- Y's case the instantiation of Gen is never an ABE.
9800 if Earlier_In_Extended_Unit
(Root
, Gen_Attrs
.Body_Decl
) then
9802 -- Do not emit any ABE diagnostics when a previous scenario in
9803 -- this traversal has suppressed elaboration warnings.
9805 if State
.Suppress_Warnings
then
9808 -- Do not emit any ABE diagnostics when the instantiation occurs
9809 -- in partial finalization context because this leads to unwanted
9812 elsif State
.Within_Partial_Finalization
then
9815 -- ABE diagnostics are emitted only in the static model because
9816 -- there is a well-defined order to visiting scenarios. Without
9817 -- this order diagnostics appear jumbled and result in unwanted
9820 elsif Static_Elaboration_Checks
then
9822 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
9823 Error_Msg_N
("\Program_Error may be raised at run time", Inst
);
9825 Output_Active_Scenarios
(Inst
);
9828 -- Install a conditional run-time ABE check to verify that the
9829 -- generic body has been elaborated prior to the instantiation.
9834 Ins_Nod
=> Exp_Inst
,
9835 Target_Id
=> Gen_Attrs
.Spec_Id
,
9836 Target_Decl
=> Gen_Attrs
.Spec_Decl
,
9837 Target_Body
=> Gen_Attrs
.Body_Decl
);
9839 -- Update the state of the Processing phase to indicate that
9840 -- no implicit Elaborate[_All] pragmas must be generated from
9848 -- function A ... is
9850 -- if Some_Condition then
9852 -- declare Inst is new Gen;
9858 -- package body Gen is
9860 -- External.Subp; -- imparts Elaborate_All
9863 -- If Some_Condition is True, then the ABE check will fail at
9864 -- runtime and the call to External.Subp will never take place,
9865 -- rendering the implicit Elaborate_All useless.
9867 -- If Some_Condition is False, then the call to External.Subp
9868 -- will never take place, rendering the implicit Elaborate_All
9871 New_State
.Suppress_Implicit_Pragmas
:= True;
9875 -- Otherwise the generic body is not available in this compilation or it
9876 -- resides in an external unit. Install a run-time ABE check to verify
9877 -- that the generic body has been elaborated prior to the instantiation
9878 -- when the dynamic model is in effect.
9880 elsif Dynamic_Elaboration_Checks
and then Check_OK
then
9883 Ins_Nod
=> Exp_Inst
,
9884 Id
=> Gen_Attrs
.Unit_Id
);
9887 -- Ensure that the unit with the generic body is elaborated prior to
9888 -- the main unit. No implicit pragma is generated if the instantiation
9889 -- has elaboration checks suppressed. This behaviour parallels that of
9890 -- the old ABE mechanism.
9892 if Inst_Attrs
.Elab_Checks_OK
then
9893 Ensure_Prior_Elaboration
9895 Unit_Id
=> Gen_Attrs
.Unit_Id
,
9896 Prag_Nam
=> Name_Elaborate
,
9897 State
=> New_State
);
9899 end Process_Conditional_ABE_Instantiation_Ada
;
9901 -------------------------------------------------
9902 -- Process_Conditional_ABE_Instantiation_SPARK --
9903 -------------------------------------------------
9905 procedure Process_Conditional_ABE_Instantiation_SPARK
9908 Gen_Attrs
: Target_Attributes
;
9909 State
: Processing_Attributes
)
9914 -- Ensure that a suitable elaboration model is in effect for SPARK rule
9917 Check_SPARK_Model_In_Effect
(Inst
);
9919 -- A source instantiation imposes an Elaborate[_All] requirement on the
9920 -- context of the main unit. Determine whether the context has a pragma
9921 -- strong enough to meet the requirement. The check is orthogonal to the
9922 -- ABE ramifications of the instantiation.
9924 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce
9925 -- SPARK elaboration rules in SPARK code) is active because the static
9926 -- model can ensure the prior elaboration of the unit which contains a
9927 -- body by installing an implicit Elaborate[_All] pragma.
9929 if Debug_Flag_Dot_V
then
9930 if Nkind
(Inst
) = N_Package_Instantiation
then
9931 Req_Nam
:= Name_Elaborate_All
;
9933 Req_Nam
:= Name_Elaborate
;
9936 Meet_Elaboration_Requirement
9938 Target_Id
=> Gen_Id
,
9939 Req_Nam
=> Req_Nam
);
9941 -- Otherwise ensure that the unit with the target body is elaborated
9942 -- prior to the main unit.
9945 Ensure_Prior_Elaboration
9947 Unit_Id
=> Gen_Attrs
.Unit_Id
,
9948 Prag_Nam
=> Name_Elaborate
,
9951 end Process_Conditional_ABE_Instantiation_SPARK
;
9953 -------------------------------------------------
9954 -- Process_Conditional_ABE_Variable_Assignment --
9955 -------------------------------------------------
9957 procedure Process_Conditional_ABE_Variable_Assignment
(Asmt
: Node_Id
) is
9958 Var_Id
: constant Entity_Id
:= Entity
(Extract_Assignment_Name
(Asmt
));
9959 Prag
: constant Node_Id
:= SPARK_Pragma
(Var_Id
);
9961 SPARK_Rules_On
: Boolean;
9962 -- This flag is set when the SPARK rules are in effect
9965 -- The SPARK rules are in effect when both the assignment and the
9966 -- variable are subject to SPARK_Mode On.
9970 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
9971 and then Is_SPARK_Mode_On_Node
(Asmt
);
9973 -- Output relevant information when switch -gnatel (info messages on
9974 -- implicit Elaborate[_All] pragmas) is in effect.
9976 if Elab_Info_Messages
then
9978 (Msg
=> "assignment to & during elaboration",
9982 In_SPARK
=> SPARK_Rules_On
);
9985 -- The SPARK rules are in effect. These rules are applied regardless of
9986 -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is
9987 -- in effect because the static model cannot ensure safe assignment of
9990 if SPARK_Rules_On
then
9991 Process_Conditional_ABE_Variable_Assignment_SPARK
9995 -- Otherwise the Ada rules are in effect
9998 Process_Conditional_ABE_Variable_Assignment_Ada
10002 end Process_Conditional_ABE_Variable_Assignment
;
10004 -----------------------------------------------------
10005 -- Process_Conditional_ABE_Variable_Assignment_Ada --
10006 -----------------------------------------------------
10008 procedure Process_Conditional_ABE_Variable_Assignment_Ada
10010 Var_Id
: Entity_Id
)
10012 Var_Decl
: constant Node_Id
:= Declaration_Node
(Var_Id
);
10013 Spec_Id
: constant Entity_Id
:= Find_Top_Unit
(Var_Decl
);
10016 -- Emit a warning when an uninitialized variable declared in a package
10017 -- spec without a pragma Elaborate_Body is initialized by elaboration
10018 -- code within the corresponding body.
10020 if Is_Elaboration_Warnings_OK_Id
(Var_Id
)
10021 and then not Is_Initialized
(Var_Decl
)
10022 and then not Has_Pragma_Elaborate_Body
(Spec_Id
)
10025 ("??variable & can be accessed by clients before this "
10026 & "initialization", Asmt
, Var_Id
);
10029 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
10030 & "initialization", Asmt
, Spec_Id
);
10032 Output_Active_Scenarios
(Asmt
);
10034 -- Generate an implicit Elaborate_Body in the spec
10036 Set_Elaborate_Body_Desirable
(Spec_Id
);
10038 end Process_Conditional_ABE_Variable_Assignment_Ada
;
10040 -------------------------------------------------------
10041 -- Process_Conditional_ABE_Variable_Assignment_SPARK --
10042 -------------------------------------------------------
10044 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
10046 Var_Id
: Entity_Id
)
10048 Var_Decl
: constant Node_Id
:= Declaration_Node
(Var_Id
);
10049 Spec_Id
: constant Entity_Id
:= Find_Top_Unit
(Var_Decl
);
10052 -- Ensure that a suitable elaboration model is in effect for SPARK rule
10055 Check_SPARK_Model_In_Effect
(Asmt
);
10057 -- Emit an error when an initialized variable declared in a package spec
10058 -- without pragma Elaborate_Body is further modified by elaboration code
10059 -- within the corresponding body.
10061 if Is_Elaboration_Warnings_OK_Id
(Var_Id
)
10062 and then Is_Initialized
(Var_Decl
)
10063 and then not Has_Pragma_Elaborate_Body
(Spec_Id
)
10066 ("variable & modified by elaboration code in package body",
10070 ("\add pragma ""Elaborate_Body"" to spec & to ensure full "
10071 & "initialization", Asmt
, Spec_Id
);
10073 Output_Active_Scenarios
(Asmt
);
10075 end Process_Conditional_ABE_Variable_Assignment_SPARK
;
10077 ------------------------------------------------
10078 -- Process_Conditional_ABE_Variable_Reference --
10079 ------------------------------------------------
10081 procedure Process_Conditional_ABE_Variable_Reference
(Ref
: Node_Id
) is
10082 Var_Attrs
: Variable_Attributes
;
10083 Var_Id
: Entity_Id
;
10086 Extract_Variable_Reference_Attributes
10089 Attrs
=> Var_Attrs
);
10091 if Is_Read
(Ref
) then
10092 Process_Conditional_ABE_Variable_Reference_Read
10095 Attrs
=> Var_Attrs
);
10097 end Process_Conditional_ABE_Variable_Reference
;
10099 -----------------------------------------------------
10100 -- Process_Conditional_ABE_Variable_Reference_Read --
10101 -----------------------------------------------------
10103 procedure Process_Conditional_ABE_Variable_Reference_Read
10105 Var_Id
: Entity_Id
;
10106 Attrs
: Variable_Attributes
)
10109 -- Output relevant information when switch -gnatel (info messages on
10110 -- implicit Elaborate[_All] pragmas) is in effect.
10112 if Elab_Info_Messages
then
10114 (Msg
=> "read of variable & during elaboration",
10121 -- Nothing to do when the variable appears within the main unit because
10122 -- diagnostics on reads are relevant only for external variables.
10124 if Is_Same_Unit
(Attrs
.Unit_Id
, Cunit_Entity
(Main_Unit
)) then
10127 -- Nothing to do when the variable is already initialized. Note that the
10128 -- variable may be further modified by the external unit.
10130 elsif Is_Initialized
(Declaration_Node
(Var_Id
)) then
10133 -- Nothing to do when the external unit guarantees the initialization of
10134 -- the variable by means of pragma Elaborate_Body.
10136 elsif Has_Pragma_Elaborate_Body
(Attrs
.Unit_Id
) then
10139 -- A variable read imposes an Elaborate requirement on the context of
10140 -- the main unit. Determine whether the context has a pragma strong
10141 -- enough to meet the requirement.
10144 Meet_Elaboration_Requirement
10146 Target_Id
=> Var_Id
,
10147 Req_Nam
=> Name_Elaborate
);
10149 end Process_Conditional_ABE_Variable_Reference_Read
;
10151 -----------------------------
10152 -- Process_Conditional_ABE --
10153 -----------------------------
10155 -- NOTE: The body of this routine is intentionally out of order because it
10156 -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation).
10157 -- Placing the body in alphabetical order will result in a guaranteed ABE.
10159 procedure Process_Conditional_ABE
10161 State
: Processing_Attributes
:= Initial_State
)
10163 Call_Attrs
: Call_Attributes
;
10164 Target_Id
: Entity_Id
;
10167 -- Add the current scenario to the stack of active scenarios
10169 Push_Active_Scenario
(N
);
10173 if Is_Suitable_Access
(N
) then
10174 Process_Conditional_ABE_Access
10178 -- Activations and calls
10180 elsif Is_Suitable_Call
(N
) then
10182 -- In general, only calls found within the main unit are processed
10183 -- because the ALI information supplied to binde is for the main
10184 -- unit only. However, to preserve the consistency of the tree and
10185 -- ensure proper serialization of internal names, external calls
10186 -- also receive corresponding call markers (see Build_Call_Marker).
10187 -- Regardless of the reason, external calls must not be processed.
10189 if In_Main_Context
(N
) then
10190 Extract_Call_Attributes
10192 Target_Id
=> Target_Id
,
10193 Attrs
=> Call_Attrs
);
10195 if Is_Activation_Proc
(Target_Id
) then
10196 Process_Conditional_ABE_Activation
10198 Call_Attrs
=> Call_Attrs
,
10202 Process_Conditional_ABE_Call
10204 Call_Attrs
=> Call_Attrs
,
10205 Target_Id
=> Target_Id
,
10212 elsif Is_Suitable_Instantiation
(N
) then
10213 Process_Conditional_ABE_Instantiation
10217 -- Variable assignments
10219 elsif Is_Suitable_Variable_Assignment
(N
) then
10220 Process_Conditional_ABE_Variable_Assignment
(N
);
10222 -- Variable references
10224 elsif Is_Suitable_Variable_Reference
(N
) then
10226 -- In general, only variable references found within the main unit
10227 -- are processed because the ALI information supplied to binde is for
10228 -- the main unit only. However, to preserve the consistency of the
10229 -- tree and ensure proper serialization of internal names, external
10230 -- variable references also receive corresponding variable reference
10231 -- markers (see Build_Varaible_Reference_Marker). Regardless of the
10232 -- reason, external variable references must not be processed.
10234 if In_Main_Context
(N
) then
10235 Process_Conditional_ABE_Variable_Reference
(N
);
10239 -- Remove the current scenario from the stack of active scenarios once
10240 -- all ABE diagnostics and checks have been performed.
10242 Pop_Active_Scenario
(N
);
10243 end Process_Conditional_ABE
;
10245 --------------------------------------------
10246 -- Process_Guaranteed_ABE_Activation_Impl --
10247 --------------------------------------------
10249 procedure Process_Guaranteed_ABE_Activation_Impl
10251 Call_Attrs
: Call_Attributes
;
10252 Obj_Id
: Entity_Id
;
10253 Task_Attrs
: Task_Attributes
;
10254 State
: Processing_Attributes
)
10256 pragma Unreferenced
(State
);
10258 Check_OK
: constant Boolean :=
10259 not Is_Ignored_Ghost_Entity
(Obj_Id
)
10260 and then not Task_Attrs
.Ghost_Mode_Ignore
10261 and then Is_Elaboration_Checks_OK_Id
(Obj_Id
)
10262 and then Task_Attrs
.Elab_Checks_OK
;
10263 -- A run-time ABE check may be installed only when the object and the
10264 -- task type have active elaboration checks, and both are not ignored
10265 -- Ghost constructs.
10268 -- Nothing to do when the root scenario appears at the declaration
10269 -- level and the task is in the same unit, but outside this context.
10271 -- task type Task_Typ; -- task declaration
10273 -- procedure Proc is
10274 -- function A ... is
10276 -- if Some_Condition then
10280 -- <activation call> -- activation site
10285 -- X : ... := A; -- root scenario
10288 -- task body Task_Typ is
10292 -- In the example above, the context of X is the declarative list of
10293 -- Proc. The "elaboration" of X may reach the activation of T whose body
10294 -- is defined outside of X's context. The task body is relevant only
10295 -- when Proc is invoked, but this happens only in "normal" elaboration,
10296 -- therefore the task body must not be considered if this is not the
10299 -- Performance note: parent traversal
10301 if Is_Up_Level_Target
(Task_Attrs
.Task_Decl
) then
10304 -- Nothing to do when the activation is ABE-safe
10308 -- task type Task_Typ;
10311 -- package body Gen is
10312 -- task body Task_Typ is
10319 -- procedure Main is
10320 -- package Nested is
10321 -- package Inst is new Gen;
10322 -- T : Inst.Task_Typ;
10323 -- end Nested; -- safe activation
10326 elsif Is_Safe_Activation
(Call
, Task_Attrs
.Task_Decl
) then
10329 -- An activation call leads to a guaranteed ABE when the activation
10330 -- call and the task appear within the same context ignoring library
10331 -- levels, and the body of the task has not been seen yet or appears
10332 -- after the activation call.
10334 -- procedure Guaranteed_ABE is
10335 -- task type Task_Typ;
10337 -- package Nested is
10339 -- <activation call> -- guaranteed ABE
10342 -- task body Task_Typ is
10347 -- Performance note: parent traversal
10349 elsif Is_Guaranteed_ABE
10351 Target_Decl
=> Task_Attrs
.Task_Decl
,
10352 Target_Body
=> Task_Attrs
.Body_Decl
)
10354 if Call_Attrs
.Elab_Warnings_OK
then
10355 Error_Msg_Sloc
:= Sloc
(Call
);
10357 ("??task & will be activated # before elaboration of its body",
10359 Error_Msg_N
("\Program_Error will be raised at run time", Obj_Id
);
10362 -- Mark the activation call as a guaranteed ABE
10364 Set_Is_Known_Guaranteed_ABE
(Call
);
10366 -- Install a run-time ABE failue because this activation call will
10367 -- always result in an ABE.
10370 Install_ABE_Failure
10375 end Process_Guaranteed_ABE_Activation_Impl
;
10377 procedure Process_Guaranteed_ABE_Activation
is
10378 new Process_Activation_Generic
(Process_Guaranteed_ABE_Activation_Impl
);
10380 ---------------------------------
10381 -- Process_Guaranteed_ABE_Call --
10382 ---------------------------------
10384 procedure Process_Guaranteed_ABE_Call
10386 Call_Attrs
: Call_Attributes
;
10387 Target_Id
: Entity_Id
)
10389 Target_Attrs
: Target_Attributes
;
10392 Extract_Target_Attributes
10393 (Target_Id
=> Target_Id
,
10394 Attrs
=> Target_Attrs
);
10396 -- Nothing to do when the root scenario appears at the declaration level
10397 -- and the target is in the same unit, but outside this context.
10399 -- function B ...; -- target declaration
10401 -- procedure Proc is
10402 -- function A ... is
10404 -- if Some_Condition then
10405 -- return B; -- call site
10409 -- X : ... := A; -- root scenario
10412 -- function B ... is
10416 -- In the example above, the context of X is the declarative region of
10417 -- Proc. The "elaboration" of X may eventually reach B which is defined
10418 -- outside of X's context. B is relevant only when Proc is invoked, but
10419 -- this happens only by means of "normal" elaboration, therefore B must
10420 -- not be considered if this is not the case.
10422 -- Performance note: parent traversal
10424 if Is_Up_Level_Target
(Target_Attrs
.Spec_Decl
) then
10427 -- Nothing to do when the call is ABE-safe
10430 -- function Gen ...;
10432 -- function Gen ... is
10438 -- procedure Main is
10439 -- function Inst is new Gen;
10440 -- X : ... := Inst; -- safe call
10443 elsif Is_Safe_Call
(Call
, Target_Attrs
) then
10446 -- A call leads to a guaranteed ABE when the call and the target appear
10447 -- within the same context ignoring library levels, and the body of the
10448 -- target has not been seen yet or appears after the call.
10450 -- procedure Guaranteed_ABE is
10451 -- function Func ...;
10453 -- package Nested is
10454 -- Obj : ... := Func; -- guaranteed ABE
10457 -- function Func ... is
10462 -- Performance note: parent traversal
10464 elsif Is_Guaranteed_ABE
10466 Target_Decl
=> Target_Attrs
.Spec_Decl
,
10467 Target_Body
=> Target_Attrs
.Body_Decl
)
10469 if Call_Attrs
.Elab_Warnings_OK
then
10470 Error_Msg_NE
("??cannot call & before body seen", Call
, Target_Id
);
10471 Error_Msg_N
("\Program_Error will be raised at run time", Call
);
10474 -- Mark the call as a guarnateed ABE
10476 Set_Is_Known_Guaranteed_ABE
(Call
);
10478 -- Install a run-time ABE failure because the call will always result
10479 -- in an ABE. The failure is installed when both the call and target
10480 -- have enabled elaboration checks, and both are not ignored Ghost
10483 if Call_Attrs
.Elab_Checks_OK
10484 and then Target_Attrs
.Elab_Checks_OK
10485 and then not Call_Attrs
.Ghost_Mode_Ignore
10486 and then not Target_Attrs
.Ghost_Mode_Ignore
10488 Install_ABE_Failure
10493 end Process_Guaranteed_ABE_Call
;
10495 ------------------------------------------
10496 -- Process_Guaranteed_ABE_Instantiation --
10497 ------------------------------------------
10499 procedure Process_Guaranteed_ABE_Instantiation
(Exp_Inst
: Node_Id
) is
10500 Gen_Attrs
: Target_Attributes
;
10501 Gen_Id
: Entity_Id
;
10503 Inst_Attrs
: Instantiation_Attributes
;
10504 Inst_Id
: Entity_Id
;
10507 Extract_Instantiation_Attributes
10508 (Exp_Inst
=> Exp_Inst
,
10510 Inst_Id
=> Inst_Id
,
10512 Attrs
=> Inst_Attrs
);
10514 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
10516 -- Nothing to do when the root scenario appears at the declaration level
10517 -- and the generic is in the same unit, but outside this context.
10520 -- procedure Gen is ...; -- generic declaration
10522 -- procedure Proc is
10523 -- function A ... is
10525 -- if Some_Condition then
10527 -- procedure I is new Gen; -- instantiation site
10532 -- X : ... := A; -- root scenario
10535 -- procedure Gen is
10539 -- In the example above, the context of X is the declarative region of
10540 -- Proc. The "elaboration" of X may eventually reach Gen which appears
10541 -- outside of X's context. Gen is relevant only when Proc is invoked,
10542 -- but this happens only by means of "normal" elaboration, therefore
10543 -- Gen must not be considered if this is not the case.
10545 -- Performance note: parent traversal
10547 if Is_Up_Level_Target
(Gen_Attrs
.Spec_Decl
) then
10550 -- Nothing to do when the instantiation is ABE-safe
10557 -- package body Gen is
10562 -- procedure Main is
10563 -- package Inst is new Gen (ABE); -- safe instantiation
10566 elsif Is_Safe_Instantiation
(Inst
, Gen_Attrs
) then
10569 -- An instantiation leads to a guaranteed ABE when the instantiation and
10570 -- the generic appear within the same context ignoring library levels,
10571 -- and the body of the generic has not been seen yet or appears after
10572 -- the instantiation.
10574 -- procedure Guaranteed_ABE is
10578 -- package Nested is
10579 -- procedure Inst is new Gen; -- guaranteed ABE
10582 -- procedure Gen is
10587 -- Performance note: parent traversal
10589 elsif Is_Guaranteed_ABE
10591 Target_Decl
=> Gen_Attrs
.Spec_Decl
,
10592 Target_Body
=> Gen_Attrs
.Body_Decl
)
10594 if Inst_Attrs
.Elab_Warnings_OK
then
10596 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
10597 Error_Msg_N
("\Program_Error will be raised at run time", Inst
);
10600 -- Mark the instantiation as a guarantee ABE. This automatically
10601 -- suppresses the instantiation of the generic body.
10603 Set_Is_Known_Guaranteed_ABE
(Inst
);
10605 -- Install a run-time ABE failure because the instantiation will
10606 -- always result in an ABE. The failure is installed when both the
10607 -- instance and the generic have enabled elaboration checks, and both
10608 -- are not ignored Ghost constructs.
10610 if Inst_Attrs
.Elab_Checks_OK
10611 and then Gen_Attrs
.Elab_Checks_OK
10612 and then not Inst_Attrs
.Ghost_Mode_Ignore
10613 and then not Gen_Attrs
.Ghost_Mode_Ignore
10615 Install_ABE_Failure
10617 Ins_Nod
=> Exp_Inst
);
10620 end Process_Guaranteed_ABE_Instantiation
;
10622 ----------------------------
10623 -- Process_Guaranteed_ABE --
10624 ----------------------------
10626 -- NOTE: The body of this routine is intentionally out of order because it
10627 -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation).
10628 -- Placing the body in alphabetical order will result in a guaranteed ABE.
10630 procedure Process_Guaranteed_ABE
(N
: Node_Id
) is
10631 Call_Attrs
: Call_Attributes
;
10632 Target_Id
: Entity_Id
;
10635 -- Add the current scenario to the stack of active scenarios
10637 Push_Active_Scenario
(N
);
10639 -- Only calls, instantiations, and task activations may result in a
10642 if Is_Suitable_Call
(N
) then
10643 Extract_Call_Attributes
10645 Target_Id
=> Target_Id
,
10646 Attrs
=> Call_Attrs
);
10648 if Is_Activation_Proc
(Target_Id
) then
10649 Process_Guaranteed_ABE_Activation
10651 Call_Attrs
=> Call_Attrs
,
10652 State
=> Initial_State
);
10655 Process_Guaranteed_ABE_Call
10657 Call_Attrs
=> Call_Attrs
,
10658 Target_Id
=> Target_Id
);
10661 elsif Is_Suitable_Instantiation
(N
) then
10662 Process_Guaranteed_ABE_Instantiation
(N
);
10665 -- Remove the current scenario from the stack of active scenarios once
10666 -- all ABE diagnostics and checks have been performed.
10668 Pop_Active_Scenario
(N
);
10669 end Process_Guaranteed_ABE
;
10671 --------------------------
10672 -- Push_Active_Scenario --
10673 --------------------------
10675 procedure Push_Active_Scenario
(N
: Node_Id
) is
10677 Scenario_Stack
.Append
(N
);
10678 end Push_Active_Scenario
;
10680 ---------------------------------
10681 -- Record_Elaboration_Scenario --
10682 ---------------------------------
10684 procedure Record_Elaboration_Scenario
(N
: Node_Id
) is
10685 Level
: Enclosing_Level_Kind
;
10687 Any_Level_OK
: Boolean;
10688 -- This flag is set when a particular scenario is allowed to appear at
10691 Declaration_Level_OK
: Boolean;
10692 -- This flag is set when a particular scenario is allowed to appear at
10693 -- the declaration level.
10695 Library_Level_OK
: Boolean;
10696 -- This flag is set when a particular scenario is allowed to appear at
10697 -- the library level.
10700 -- Assume that the scenario cannot appear on any level
10702 Any_Level_OK
:= False;
10703 Declaration_Level_OK
:= False;
10704 Library_Level_OK
:= False;
10706 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
10707 -- enabled) is in effect because the legacy ABE mechanism does not need
10708 -- to carry out this action.
10710 if Legacy_Elaboration_Checks
then
10713 -- Nothing to do for ASIS because ABE checks and diagnostics are not
10714 -- performed in this mode.
10716 elsif ASIS_Mode
then
10719 -- Nothing to do when the scenario is being preanalyzed
10721 elsif Preanalysis_Active
then
10725 -- Ensure that a library-level call does not appear in a preelaborated
10726 -- unit. The check must come before ignoring scenarios within external
10727 -- units or inside generics because calls in those context must also be
10730 if Is_Suitable_Call
(N
) then
10731 Check_Preelaborated_Call
(N
);
10734 -- Nothing to do when the scenario does not appear within the main unit
10736 if not In_Main_Context
(N
) then
10739 -- Scenarios within a generic unit are never considered because generics
10740 -- cannot be elaborated.
10742 elsif Inside_A_Generic
then
10745 -- Scenarios which do not fall in one of the elaboration categories
10746 -- listed below are not considered. The categories are:
10748 -- 'Access for entries, operators, and subprograms
10749 -- Assignments to variables
10750 -- Calls (includes task activation)
10753 -- Pragma Refined_State
10754 -- Reads of variables
10756 elsif Is_Suitable_Access
(N
) then
10757 Library_Level_OK
:= True;
10759 -- Signal any enclosing local exception handlers that the 'Access may
10760 -- raise Program_Error due to a failed ABE check when switch -gnatd.o
10761 -- (conservative elaboration order for indirect calls) is in effect.
10762 -- Marking the exception handlers ensures proper expansion by both
10763 -- the front and back end restriction when No_Exception_Propagation
10766 if Debug_Flag_Dot_O
then
10767 Possible_Local_Raise
(N
, Standard_Program_Error
);
10770 elsif Is_Suitable_Call
(N
) or else Is_Suitable_Instantiation
(N
) then
10771 Declaration_Level_OK
:= True;
10772 Library_Level_OK
:= True;
10774 -- Signal any enclosing local exception handlers that the call or
10775 -- instantiation may raise Program_Error due to a failed ABE check.
10776 -- Marking the exception handlers ensures proper expansion by both
10777 -- the front and back end restriction when No_Exception_Propagation
10780 Possible_Local_Raise
(N
, Standard_Program_Error
);
10782 elsif Is_Suitable_SPARK_Derived_Type
(N
) then
10783 Any_Level_OK
:= True;
10785 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
10786 Library_Level_OK
:= True;
10788 elsif Is_Suitable_Variable_Assignment
(N
)
10789 or else Is_Suitable_Variable_Reference
(N
)
10791 Library_Level_OK
:= True;
10793 -- Otherwise the input does not denote a suitable scenario
10799 -- The static model imposes additional restrictions on the placement of
10800 -- scenarios. In contrast, the dynamic model assumes that every scenario
10801 -- will be elaborated or invoked at some point.
10803 if Static_Elaboration_Checks
then
10805 -- Certain scenarios are allowed to appear at any level. This check
10806 -- is performed here in order to save on a parent traversal.
10808 if Any_Level_OK
then
10811 -- Otherwise the scenario must appear at a specific level
10814 -- Performance note: parent traversal
10816 Level
:= Find_Enclosing_Level
(N
);
10818 -- Declaration-level scenario
10820 if Declaration_Level_OK
and then Level
= Declaration_Level
then
10823 -- Library-level or instantiation scenario
10825 elsif Library_Level_OK
10826 and then Level
in Library_Or_Instantiation_Level
10830 -- Otherwise the scenario does not appear at the proper level and
10831 -- cannot possibly act as a top-level scenario.
10839 -- Derived types subject to SPARK_Mode On require elaboration-related
10840 -- checks even though the type may not be declared within elaboration
10841 -- code. The types are recorded in a separate table which is examined
10842 -- during the Processing phase. Note that the checks must be delayed
10843 -- because the bodies of overriding primitives are not available yet.
10845 if Is_Suitable_SPARK_Derived_Type
(N
) then
10846 Record_SPARK_Elaboration_Scenario
(N
);
10848 -- Nothing left to do for derived types
10852 -- Instantiations of generics both subject to SPARK_Mode On require
10853 -- elaboration-related checks even though the instantiations may not
10854 -- appear within elaboration code. The instantiations are recored in
10855 -- a separate table which is examined during the Procesing phase. Note
10856 -- that the checks must be delayed because it is not known yet whether
10857 -- the generic unit has a body or not.
10859 -- IMPORTANT: A SPARK instantiation is also a normal instantiation which
10860 -- is subject to common conditional and guaranteed ABE checks.
10862 elsif Is_Suitable_SPARK_Instantiation
(N
) then
10863 Record_SPARK_Elaboration_Scenario
(N
);
10865 -- External constituents that refine abstract states which appear in
10866 -- pragma Initializes require elaboration-related checks even though
10867 -- a Refined_State pragma lacks any elaboration semantic.
10869 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
10870 Record_SPARK_Elaboration_Scenario
(N
);
10872 -- Nothing left to do for pragma Refined_State
10877 -- Perform early detection of guaranteed ABEs in order to suppress the
10878 -- instantiation of generic bodies as gigi cannot handle certain types
10879 -- of premature instantiations.
10881 Process_Guaranteed_ABE
(N
);
10883 -- At this point all checks have been performed. Record the scenario for
10884 -- later processing by the ABE phase.
10886 Top_Level_Scenarios
.Append
(N
);
10887 Set_Is_Recorded_Top_Level_Scenario
(N
);
10888 end Record_Elaboration_Scenario
;
10890 ---------------------------------------
10891 -- Record_SPARK_Elaboration_Scenario --
10892 ---------------------------------------
10894 procedure Record_SPARK_Elaboration_Scenario
(N
: Node_Id
) is
10896 SPARK_Scenarios
.Append
(N
);
10897 Set_Is_Recorded_SPARK_Scenario
(N
);
10898 end Record_SPARK_Elaboration_Scenario
;
10900 -----------------------------------
10901 -- Recorded_SPARK_Scenarios_Hash --
10902 -----------------------------------
10904 function Recorded_SPARK_Scenarios_Hash
10905 (Key
: Node_Id
) return Recorded_SPARK_Scenarios_Index
10909 Recorded_SPARK_Scenarios_Index
(Key
mod Recorded_SPARK_Scenarios_Max
);
10910 end Recorded_SPARK_Scenarios_Hash
;
10912 ---------------------------------------
10913 -- Recorded_Top_Level_Scenarios_Hash --
10914 ---------------------------------------
10916 function Recorded_Top_Level_Scenarios_Hash
10917 (Key
: Node_Id
) return Recorded_Top_Level_Scenarios_Index
10921 Recorded_Top_Level_Scenarios_Index
10922 (Key
mod Recorded_Top_Level_Scenarios_Max
);
10923 end Recorded_Top_Level_Scenarios_Hash
;
10925 --------------------------
10926 -- Reset_Visited_Bodies --
10927 --------------------------
10929 procedure Reset_Visited_Bodies
is
10931 if Visited_Bodies_In_Use
then
10932 Visited_Bodies_In_Use
:= False;
10933 Visited_Bodies
.Reset
;
10935 end Reset_Visited_Bodies
;
10937 -------------------
10938 -- Root_Scenario --
10939 -------------------
10941 function Root_Scenario
return Node_Id
is
10942 package Stack
renames Scenario_Stack
;
10945 -- Ensure that the scenario stack has at least one active scenario in
10946 -- it. The one at the bottom (index First) is the root scenario.
10948 pragma Assert
(Stack
.Last
>= Stack
.First
);
10949 return Stack
.Table
(Stack
.First
);
10952 ---------------------------
10953 -- Set_Early_Call_Region --
10954 ---------------------------
10956 procedure Set_Early_Call_Region
(Body_Id
: Entity_Id
; Start
: Node_Id
) is
10958 pragma Assert
(Ekind_In
(Body_Id
, E_Entry
,
10962 E_Subprogram_Body
));
10964 Early_Call_Regions_In_Use
:= True;
10965 Early_Call_Regions
.Set
(Body_Id
, Start
);
10966 end Set_Early_Call_Region
;
10968 ----------------------------
10969 -- Set_Elaboration_Status --
10970 ----------------------------
10972 procedure Set_Elaboration_Status
10973 (Unit_Id
: Entity_Id
;
10974 Val
: Elaboration_Attributes
)
10977 Elaboration_Statuses_In_Use
:= True;
10978 Elaboration_Statuses
.Set
(Unit_Id
, Val
);
10979 end Set_Elaboration_Status
;
10981 ------------------------------------
10982 -- Set_Is_Recorded_SPARK_Scenario --
10983 ------------------------------------
10985 procedure Set_Is_Recorded_SPARK_Scenario
10987 Val
: Boolean := True)
10990 Recorded_SPARK_Scenarios_In_Use
:= True;
10991 Recorded_SPARK_Scenarios
.Set
(N
, Val
);
10992 end Set_Is_Recorded_SPARK_Scenario
;
10994 ----------------------------------------
10995 -- Set_Is_Recorded_Top_Level_Scenario --
10996 ----------------------------------------
10998 procedure Set_Is_Recorded_Top_Level_Scenario
11000 Val
: Boolean := True)
11003 Recorded_Top_Level_Scenarios_In_Use
:= True;
11004 Recorded_Top_Level_Scenarios
.Set
(N
, Val
);
11005 end Set_Is_Recorded_Top_Level_Scenario
;
11007 -------------------------
11008 -- Set_Is_Visited_Body --
11009 -------------------------
11011 procedure Set_Is_Visited_Body
(Subp_Body
: Node_Id
) is
11013 Visited_Bodies_In_Use
:= True;
11014 Visited_Bodies
.Set
(Subp_Body
, True);
11015 end Set_Is_Visited_Body
;
11017 -------------------------------
11018 -- Static_Elaboration_Checks --
11019 -------------------------------
11021 function Static_Elaboration_Checks
return Boolean is
11023 return not Dynamic_Elaboration_Checks
;
11024 end Static_Elaboration_Checks
;
11026 -------------------
11027 -- Traverse_Body --
11028 -------------------
11030 procedure Traverse_Body
(N
: Node_Id
; State
: Processing_Attributes
) is
11031 procedure Find_And_Process_Nested_Scenarios
;
11032 pragma Inline
(Find_And_Process_Nested_Scenarios
);
11033 -- Examine the declarations and statements of subprogram body N for
11034 -- suitable scenarios.
11036 ---------------------------------------
11037 -- Find_And_Process_Nested_Scenarios --
11038 ---------------------------------------
11040 procedure Find_And_Process_Nested_Scenarios
is
11041 function Is_Potential_Scenario
11042 (Nod
: Node_Id
) return Traverse_Result
;
11043 -- Determine whether arbitrary node Nod denotes a suitable scenario.
11044 -- If it does, save it in the Nested_Scenarios list of the subprogram
11045 -- body, and process it.
11047 procedure Traverse_List
(List
: List_Id
);
11048 pragma Inline
(Traverse_List
);
11049 -- Invoke Traverse_Potential_Scenarios on each node in list List
11051 procedure Traverse_Potential_Scenarios
is
11052 new Traverse_Proc
(Is_Potential_Scenario
);
11054 ---------------------------
11055 -- Is_Potential_Scenario --
11056 ---------------------------
11058 function Is_Potential_Scenario
11059 (Nod
: Node_Id
) return Traverse_Result
11064 -- Skip constructs which do not have elaboration of their own and
11065 -- need to be elaborated by other means such as invocation, task
11066 -- activation, etc.
11068 if Is_Non_Library_Level_Encapsulator
(Nod
) then
11071 -- Terminate the traversal of a task body when encountering an
11072 -- accept or select statement, and
11074 -- * Entry calls during elaboration are not allowed. In this
11075 -- case the accept or select statement will cause the task
11076 -- to block at elaboration time because there are no entry
11077 -- calls to unblock it.
11081 -- * Switch -gnatd_a (stop elaboration checks on accept or
11082 -- select statement) is in effect.
11084 elsif (Debug_Flag_Underscore_A
11085 or else Restriction_Active
11086 (No_Entry_Calls_In_Elaboration_Code
))
11087 and then Nkind_In
(Original_Node
(Nod
), N_Accept_Statement
,
11088 N_Selective_Accept
)
11092 -- Terminate the traversal of a task body when encountering a
11093 -- suspension call, and
11095 -- * Entry calls during elaboration are not allowed. In this
11096 -- case the suspension call emulates an entry call and will
11097 -- cause the task to block at elaboration time.
11101 -- * Switch -gnatd_s (stop elaboration checks on synchronous
11102 -- suspension) is in effect.
11104 -- Note that the guard should not be checking the state of flag
11105 -- Within_Task_Body because only suspension calls which appear
11106 -- immediately within the statements of the task are supported.
11107 -- Flag Within_Task_Body carries over to deeper levels of the
11110 elsif (Debug_Flag_Underscore_S
11111 or else Restriction_Active
11112 (No_Entry_Calls_In_Elaboration_Code
))
11113 and then Is_Synchronous_Suspension_Call
(Nod
)
11114 and then In_Task_Body
(Nod
)
11118 -- Certain nodes carry semantic lists which act as repositories
11119 -- until expansion transforms the node and relocates the contents.
11120 -- Examine these lists in case expansion is disabled.
11122 elsif Nkind_In
(Nod
, N_And_Then
, N_Or_Else
) then
11123 Traverse_List
(Actions
(Nod
));
11125 elsif Nkind_In
(Nod
, N_Elsif_Part
, N_Iteration_Scheme
) then
11126 Traverse_List
(Condition_Actions
(Nod
));
11128 elsif Nkind
(Nod
) = N_If_Expression
then
11129 Traverse_List
(Then_Actions
(Nod
));
11130 Traverse_List
(Else_Actions
(Nod
));
11132 elsif Nkind_In
(Nod
, N_Component_Association
,
11133 N_Iterated_Component_Association
)
11135 Traverse_List
(Loop_Actions
(Nod
));
11139 elsif Is_Suitable_Scenario
(Nod
) then
11140 Process_Conditional_ABE
11146 end Is_Potential_Scenario
;
11148 -------------------
11149 -- Traverse_List --
11150 -------------------
11152 procedure Traverse_List
(List
: List_Id
) is
11156 Item
:= First
(List
);
11157 while Present
(Item
) loop
11158 Traverse_Potential_Scenarios
(Item
);
11163 -- Start of processing for Find_And_Process_Nested_Scenarios
11166 -- Examine the declarations for suitable scenarios
11168 Traverse_List
(Declarations
(N
));
11170 -- Examine the handled sequence of statements. This also includes any
11171 -- exceptions handlers.
11173 Traverse_Potential_Scenarios
(Handled_Statement_Sequence
(N
));
11174 end Find_And_Process_Nested_Scenarios
;
11176 -- Start of processing for Traverse_Body
11179 -- Nothing to do when there is no body
11184 elsif Nkind
(N
) /= N_Subprogram_Body
then
11188 -- Nothing to do if the body was already traversed during the processing
11189 -- of the same top-level scenario.
11191 if Is_Visited_Body
(N
) then
11194 -- Otherwise mark the body as traversed
11197 Set_Is_Visited_Body
(N
);
11200 -- Examine the declarations and statements of the subprogram body for
11201 -- suitable scenarios, save and process them accordingly.
11203 Find_And_Process_Nested_Scenarios
;
11210 function Unit_Entity
(Unit_Id
: Entity_Id
) return Entity_Id
is
11211 function Is_Subunit
(Id
: Entity_Id
) return Boolean;
11212 pragma Inline
(Is_Subunit
);
11213 -- Determine whether the entity of an initial declaration denotes a
11220 function Is_Subunit
(Id
: Entity_Id
) return Boolean is
11221 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Id
);
11225 Nkind_In
(Decl
, N_Generic_Package_Declaration
,
11226 N_Generic_Subprogram_Declaration
,
11227 N_Package_Declaration
,
11228 N_Protected_Type_Declaration
,
11229 N_Subprogram_Declaration
,
11230 N_Task_Type_Declaration
)
11231 and then Present
(Corresponding_Body
(Decl
))
11232 and then Nkind
(Parent
(Unit_Declaration_Node
11233 (Corresponding_Body
(Decl
)))) = N_Subunit
;
11240 -- Start of processing for Unit_Entity
11243 Id
:= Unique_Entity
(Unit_Id
);
11245 -- Skip all subunits found in the scope chain which ends at the input
11248 while Is_Subunit
(Id
) loop
11255 ---------------------------------
11256 -- Update_Elaboration_Scenario --
11257 ---------------------------------
11259 procedure Update_Elaboration_Scenario
(New_N
: Node_Id
; Old_N
: Node_Id
) is
11260 procedure Update_SPARK_Scenario
;
11261 pragma Inline
(Update_SPARK_Scenario
);
11262 -- Update the contents of table SPARK_Scenarios if Old_N is recorded
11265 procedure Update_Top_Level_Scenario
;
11266 pragma Inline
(Update_Top_Level_Scenario
);
11267 -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded
11270 ---------------------------
11271 -- Update_SPARK_Scenario --
11272 ---------------------------
11274 procedure Update_SPARK_Scenario
is
11275 package Scenarios
renames SPARK_Scenarios
;
11278 if Is_Recorded_SPARK_Scenario
(Old_N
) then
11280 -- Performance note: list traversal
11282 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
11283 if Scenarios
.Table
(Index
) = Old_N
then
11284 Scenarios
.Table
(Index
) := New_N
;
11286 -- The old SPARK scenario is no longer recorded, but the new
11289 Set_Is_Recorded_Top_Level_Scenario
(Old_N
, False);
11290 Set_Is_Recorded_Top_Level_Scenario
(New_N
);
11295 -- A recorded SPARK scenario must be in the table of recorded
11296 -- SPARK scenarios.
11298 pragma Assert
(False);
11300 end Update_SPARK_Scenario
;
11302 -------------------------------
11303 -- Update_Top_Level_Scenario --
11304 -------------------------------
11306 procedure Update_Top_Level_Scenario
is
11307 package Scenarios
renames Top_Level_Scenarios
;
11310 if Is_Recorded_Top_Level_Scenario
(Old_N
) then
11312 -- Performance note: list traversal
11314 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
11315 if Scenarios
.Table
(Index
) = Old_N
then
11316 Scenarios
.Table
(Index
) := New_N
;
11318 -- The old top-level scenario is no longer recorded, but the
11321 Set_Is_Recorded_Top_Level_Scenario
(Old_N
, False);
11322 Set_Is_Recorded_Top_Level_Scenario
(New_N
);
11327 -- A recorded top-level scenario must be in the table of recorded
11328 -- top-level scenarios.
11330 pragma Assert
(False);
11332 end Update_Top_Level_Scenario
;
11334 -- Start of processing for Update_Elaboration_Requirement
11337 -- Nothing to do when the old and new scenarios are one and the same
11339 if Old_N
= New_N
then
11342 -- A scenario is being transformed by Atree.Rewrite. Update all relevant
11343 -- internal data structures to reflect this change. This ensures that a
11344 -- potential run-time conditional ABE check or a guaranteed ABE failure
11345 -- is inserted at the proper place in the tree.
11347 elsif Is_Scenario
(Old_N
) then
11348 Update_SPARK_Scenario
;
11349 Update_Top_Level_Scenario
;
11351 end Update_Elaboration_Scenario
;
11353 -------------------------
11354 -- Visited_Bodies_Hash --
11355 -------------------------
11357 function Visited_Bodies_Hash
(Key
: Node_Id
) return Visited_Bodies_Index
is
11359 return Visited_Bodies_Index
(Key
mod Visited_Bodies_Max
);
11360 end Visited_Bodies_Hash
;
11362 ---------------------------------------------------------------------------
11364 -- 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 --
11366 -- M E C H A N I S M --
11368 ---------------------------------------------------------------------------
11370 -- This section contains the implementation of the pre-18.x legacy ABE
11371 -- mechanism. The mechanism can be activated using switch -gnatH (legacy
11372 -- elaboration checking mode enabled).
11374 -----------------------------
11375 -- Description of Approach --
11376 -----------------------------
11378 -- Every non-static call that is encountered by Sem_Res results in a call
11379 -- to Check_Elab_Call, with N being the call node, and Outer set to its
11380 -- default value of True. In addition X'Access is treated like a call
11381 -- for the access-to-procedure case, and in SPARK mode only we also
11382 -- check variable references.
11384 -- The goal of Check_Elab_Call is to determine whether or not the reference
11385 -- in question can generate an access before elaboration error (raising
11386 -- Program_Error) either by directly calling a subprogram whose body
11387 -- has not yet been elaborated, or indirectly, by calling a subprogram
11388 -- whose body has been elaborated, but which contains a call to such a
11391 -- In addition, in SPARK mode, we are checking for a variable reference in
11392 -- another package, which requires an explicit Elaborate_All pragma.
11394 -- The only references that we need to look at the outer level are
11395 -- references that occur in elaboration code. There are two cases. The
11396 -- reference can be at the outer level of elaboration code, or it can
11397 -- be within another unit, e.g. the elaboration code of a subprogram.
11399 -- In the case of an elaboration call at the outer level, we must trace
11400 -- all calls to outer level routines either within the current unit or to
11401 -- other units that are with'ed. For calls within the current unit, we can
11402 -- determine if the body has been elaborated or not, and if it has not,
11403 -- then a warning is generated.
11405 -- Note that there are two subcases. If the original call directly calls a
11406 -- subprogram whose body has not been elaborated, then we know that an ABE
11407 -- will take place, and we replace the call by a raise of Program_Error.
11408 -- If the call is indirect, then we don't know that the PE will be raised,
11409 -- since the call might be guarded by a conditional. In this case we set
11410 -- Do_Elab_Check on the call so that a dynamic check is generated, and
11411 -- output a warning.
11413 -- For calls to a subprogram in a with'ed unit or a 'Access or variable
11414 -- reference (SPARK mode case), we require that a pragma Elaborate_All
11415 -- or pragma Elaborate be present, or that the referenced unit have a
11416 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
11417 -- of these conditions is met, then a warning is generated that a pragma
11418 -- Elaborate_All may be needed (error in the SPARK case), or an implicit
11419 -- pragma is generated.
11421 -- For the case of an elaboration call at some inner level, we are
11422 -- interested in tracing only calls to subprograms at the same level, i.e.
11423 -- those that can be called during elaboration. Any calls to outer level
11424 -- routines cannot cause ABE's as a result of the original call (there
11425 -- might be an outer level call to the subprogram from outside that causes
11426 -- the ABE, but that gets analyzed separately).
11428 -- Note that we never trace calls to inner level subprograms, since these
11429 -- cannot result in ABE's unless there is an elaboration problem at a lower
11430 -- level, which will be separately detected.
11432 -- Note on pragma Elaborate. The checking here assumes that a pragma
11433 -- Elaborate on a with'ed unit guarantees that subprograms within the unit
11434 -- can be called without causing an ABE. This is not in fact the case since
11435 -- pragma Elaborate does not guarantee the transitive coverage guaranteed
11436 -- by Elaborate_All. However, we decide to trust the user in this case.
11438 --------------------------------------
11439 -- Instantiation Elaboration Errors --
11440 --------------------------------------
11442 -- A special case arises when an instantiation appears in a context that is
11443 -- known to be before the body is elaborated, e.g.
11445 -- generic package x is ...
11447 -- package xx is new x;
11449 -- package body x is ...
11451 -- In this situation it is certain that an elaboration error will occur,
11452 -- and an unconditional raise Program_Error statement is inserted before
11453 -- the instantiation, and a warning generated.
11455 -- The problem is that in this case we have no place to put the body of
11456 -- the instantiation. We can't put it in the normal place, because it is
11457 -- too early, and will cause errors to occur as a result of referencing
11458 -- entities before they are declared.
11460 -- Our approach in this case is simply to avoid creating the body of the
11461 -- instantiation in such a case. The instantiation spec is modified to
11462 -- include dummy bodies for all subprograms, so that the resulting code
11463 -- does not contain subprogram specs with no corresponding bodies.
11465 -- The following table records the recursive call chain for output in the
11466 -- Output routine. Each entry records the call node and the entity of the
11467 -- called routine. The number of entries in the table (i.e. the value of
11468 -- Elab_Call.Last) indicates the current depth of recursion and is used to
11469 -- identify the outer level.
11471 type Elab_Call_Element
is record
11476 package Elab_Call
is new Table
.Table
11477 (Table_Component_Type
=> Elab_Call_Element
,
11478 Table_Index_Type
=> Int
,
11479 Table_Low_Bound
=> 1,
11480 Table_Initial
=> 50,
11481 Table_Increment
=> 100,
11482 Table_Name
=> "Elab_Call");
11484 -- The following table records all calls that have been processed starting
11485 -- from an outer level call. The table prevents both infinite recursion and
11486 -- useless reanalysis of calls within the same context. The use of context
11487 -- is important because it allows for proper checks in more complex code:
11490 -- Call; -- requires a check
11491 -- Call; -- does not need a check thanks to the table
11493 -- Call; -- requires a check, different context
11496 -- Call; -- requires a check, different context
11498 type Visited_Element
is record
11499 Subp_Id
: Entity_Id
;
11500 -- The entity of the subprogram being called
11503 -- The context where the call to the subprogram occurs
11506 package Elab_Visited
is new Table
.Table
11507 (Table_Component_Type
=> Visited_Element
,
11508 Table_Index_Type
=> Int
,
11509 Table_Low_Bound
=> 1,
11510 Table_Initial
=> 200,
11511 Table_Increment
=> 100,
11512 Table_Name
=> "Elab_Visited");
11514 -- The following table records delayed calls which must be examined after
11515 -- all generic bodies have been instantiated.
11517 type Delay_Element
is record
11519 -- The parameter N from the call to Check_Internal_Call. Note that this
11520 -- node may get rewritten over the delay period by expansion in the call
11521 -- case (but not in the instantiation case).
11524 -- The parameter E from the call to Check_Internal_Call
11526 Orig_Ent
: Entity_Id
;
11527 -- The parameter Orig_Ent from the call to Check_Internal_Call
11529 Curscop
: Entity_Id
;
11530 -- The current scope of the call. This is restored when we complete the
11531 -- delayed call, so that we do this in the right scope.
11533 Outer_Scope
: Entity_Id
;
11534 -- Save scope of outer level call
11536 From_Elab_Code
: Boolean;
11537 -- Save indication of whether this call is from elaboration code
11539 In_Task_Activation
: Boolean;
11540 -- Save indication of whether this call is from a task body. Tasks are
11541 -- activated at the "begin", which is after all local procedure bodies,
11542 -- so calls to those procedures can't fail, even if they occur after the
11545 From_SPARK_Code
: Boolean;
11546 -- Save indication of whether this call is under SPARK_Mode => On
11549 package Delay_Check
is new Table
.Table
11550 (Table_Component_Type
=> Delay_Element
,
11551 Table_Index_Type
=> Int
,
11552 Table_Low_Bound
=> 1,
11553 Table_Initial
=> 1000,
11554 Table_Increment
=> 100,
11555 Table_Name
=> "Delay_Check");
11557 C_Scope
: Entity_Id
;
11558 -- Top-level scope of current scope. Compute this only once at the outer
11559 -- level, i.e. for a call to Check_Elab_Call from outside this unit.
11561 Outer_Level_Sloc
: Source_Ptr
;
11562 -- Save Sloc value for outer level call node for comparisons of source
11563 -- locations. A body is too late if it appears after the *outer* level
11564 -- call, not the particular call that is being analyzed.
11566 From_Elab_Code
: Boolean;
11567 -- This flag shows whether the outer level call currently being examined
11568 -- is or is not in elaboration code. We are only interested in calls to
11569 -- routines in other units if this flag is True.
11571 In_Task_Activation
: Boolean := False;
11572 -- This flag indicates whether we are performing elaboration checks on task
11573 -- bodies, at the point of activation. If true, we do not raise
11574 -- Program_Error for calls to local procedures, because all local bodies
11575 -- are known to be elaborated. However, we still need to trace such calls,
11576 -- because a local procedure could call a procedure in another package,
11577 -- so we might need an implicit Elaborate_All.
11579 Delaying_Elab_Checks
: Boolean := True;
11580 -- This is set True till the compilation is complete, including the
11581 -- insertion of all instance bodies. Then when Check_Elab_Calls is called,
11582 -- the delay table is used to make the delayed calls and this flag is reset
11583 -- to False, so that the calls are processed.
11585 -----------------------
11586 -- Local Subprograms --
11587 -----------------------
11589 -- Note: Outer_Scope in all following specs represents the scope of
11590 -- interest of the outer level call. If it is set to Standard_Standard,
11591 -- then it means the outer level call was at elaboration level, and that
11592 -- thus all calls are of interest. If it was set to some other scope,
11593 -- then the original call was an inner call, and we are not interested
11594 -- in calls that go outside this scope.
11596 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
);
11597 -- Analysis of construct N shows that we should set Elaborate_All_Desirable
11598 -- for the WITH clause for unit U (which will always be present). A special
11599 -- case is when N is a function or procedure instantiation, in which case
11600 -- it is sufficient to set Elaborate_Desirable, since in this case there is
11601 -- no possibility of transitive elaboration issues.
11603 procedure Check_A_Call
11606 Outer_Scope
: Entity_Id
;
11607 Inter_Unit_Only
: Boolean;
11608 Generate_Warnings
: Boolean := True;
11609 In_Init_Proc
: Boolean := False);
11610 -- This is the internal recursive routine that is called to check for
11611 -- possible elaboration error. The argument N is a subprogram call or
11612 -- generic instantiation, or 'Access attribute reference to be checked, and
11613 -- E is the entity of the called subprogram, or instantiated generic unit,
11614 -- or subprogram referenced by 'Access.
11616 -- In SPARK mode, N can also be a variable reference, since in SPARK this
11617 -- also triggers a requirement for Elaborate_All, and in this case E is the
11618 -- entity being referenced.
11620 -- Outer_Scope is the outer level scope for the original reference.
11621 -- Inter_Unit_Only is set if the call is only to be checked in the
11622 -- case where it is to another unit (and skipped if within a unit).
11623 -- Generate_Warnings is set to False to suppress warning messages about
11624 -- missing pragma Elaborate_All's. These messages are not wanted for
11625 -- inner calls in the dynamic model. Note that an instance of the Access
11626 -- attribute applied to a subprogram also generates a call to this
11627 -- procedure (since the referenced subprogram may be called later
11628 -- indirectly). Flag In_Init_Proc should be set whenever the current
11629 -- context is a type init proc.
11631 -- Note: this might better be called Check_A_Reference to recognize the
11632 -- variable case for SPARK, but we prefer to retain the historical name
11633 -- since in practice this is mostly about checking calls for the possible
11634 -- occurrence of an access-before-elaboration exception.
11636 procedure Check_Bad_Instantiation
(N
: Node_Id
);
11637 -- N is a node for an instantiation (if called with any other node kind,
11638 -- Check_Bad_Instantiation ignores the call). This subprogram checks for
11639 -- the special case of a generic instantiation of a generic spec in the
11640 -- same declarative part as the instantiation where a body is present and
11641 -- has not yet been seen. This is an obvious error, but needs to be checked
11642 -- specially at the time of the instantiation, since it is a case where we
11643 -- cannot insert the body anywhere. If this case is detected, warnings are
11644 -- generated, and a raise of Program_Error is inserted. In addition any
11645 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation
11646 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this
11647 -- flag as an indication that no attempt should be made to insert an
11650 procedure Check_Internal_Call
11653 Outer_Scope
: Entity_Id
;
11654 Orig_Ent
: Entity_Id
);
11655 -- N is a function call or procedure statement call node and E is the
11656 -- entity of the called function, which is within the current compilation
11657 -- unit (where subunits count as part of the parent). This call checks if
11658 -- this call, or any call within any accessed body could cause an ABE, and
11659 -- if so, outputs a warning. Orig_Ent differs from E only in the case of
11660 -- renamings, and points to the original name of the entity. This is used
11661 -- for error messages. Outer_Scope is the outer level scope for the
11664 procedure Check_Internal_Call_Continue
11667 Outer_Scope
: Entity_Id
;
11668 Orig_Ent
: Entity_Id
);
11669 -- The processing for Check_Internal_Call is divided up into two phases,
11670 -- and this represents the second phase. The second phase is delayed if
11671 -- Delaying_Elab_Checks is set to True. In this delayed case, the first
11672 -- phase makes an entry in the Delay_Check table, which is processed when
11673 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
11674 -- Check_Internal_Call. Outer_Scope is the outer level scope for the
11677 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
;
11678 -- N is either a function or procedure call or an access attribute that
11679 -- references a subprogram. This call retrieves the relevant entity. If
11680 -- this is a call to a protected subprogram, the entity is a selected
11681 -- component. The callable entity may be absent, in which case Empty is
11682 -- returned. This happens with non-analyzed calls in nested generics.
11684 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable
11685 -- entity, in which case, the value returned is simply this entity.
11687 function Has_Generic_Body
(N
: Node_Id
) return Boolean;
11688 -- N is a generic package instantiation node, and this routine determines
11689 -- if this package spec does in fact have a generic body. If so, then
11690 -- True is returned, otherwise False. Note that this is not at all the
11691 -- same as checking if the unit requires a body, since it deals with
11692 -- the case of optional bodies accurately (i.e. if a body is optional,
11693 -- then it looks to see if a body is actually present). Note: this
11694 -- function can only do a fully correct job if in generating code mode
11695 -- where all bodies have to be present. If we are operating in semantics
11696 -- check only mode, then in some cases of optional bodies, a result of
11697 -- False may incorrectly be given. In practice this simply means that
11698 -- some cases of warnings for incorrect order of elaboration will only
11699 -- be given when generating code, which is not a big problem (and is
11700 -- inevitable, given the optional body semantics of Ada).
11702 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
);
11703 -- Given code for an elaboration check (or unconditional raise if the check
11704 -- is not needed), inserts the code in the appropriate place. N is the call
11705 -- or instantiation node for which the check code is required. C is the
11706 -- test whose failure triggers the raise.
11708 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean;
11709 -- Returns True if node N is a call to a generic formal subprogram
11711 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean;
11712 -- Determine whether entity Id denotes a [Deep_]Finalize procedure
11714 procedure Output_Calls
11716 Check_Elab_Flag
: Boolean);
11717 -- Outputs chain of calls stored in the Elab_Call table. The caller has
11718 -- already generated the main warning message, so the warnings generated
11719 -- are all continuation messages. The argument is the call node at which
11720 -- the messages are to be placed. When Check_Elab_Flag is set, calls are
11721 -- enumerated only when flag Elab_Warning is set for the dynamic case or
11722 -- when flag Elab_Info_Messages is set for the static case.
11724 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean;
11725 -- Given two scopes, determine whether they are the same scope from an
11726 -- elaboration point of view, i.e. packages and blocks are ignored.
11728 procedure Set_C_Scope
;
11729 -- On entry C_Scope is set to some scope. On return, C_Scope is reset
11730 -- to be the enclosing compilation unit of this scope.
11732 procedure Set_Elaboration_Constraint
11736 -- The current unit U may depend semantically on some unit P that is not
11737 -- in the current context. If there is an elaboration call that reaches P,
11738 -- we need to indicate that P requires an Elaborate_All, but this is not
11739 -- effective in U's ali file, if there is no with_clause for P. In this
11740 -- case we add the Elaborate_All on the unit Q that directly or indirectly
11741 -- makes P available. This can happen in two cases:
11743 -- a) Q declares a subtype of a type declared in P, and the call is an
11744 -- initialization call for an object of that subtype.
11746 -- b) Q declares an object of some tagged type whose root type is
11747 -- declared in P, and the initialization call uses object notation on
11748 -- that object to reach a primitive operation or a classwide operation
11751 -- If P appears in the context of U, the current processing is correct.
11752 -- Otherwise we must identify these two cases to retrieve Q and place the
11753 -- Elaborate_All_Desirable on it.
11755 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
;
11756 -- Given a compilation unit entity, if it is a spec entity, it is returned
11757 -- unchanged. If it is a body entity, then the spec for the corresponding
11758 -- spec is returned
11760 function Within
(E1
, E2
: Entity_Id
) return Boolean;
11761 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
11762 -- of its contained scopes, False otherwise.
11764 function Within_Elaborate_All
11765 (Unit
: Unit_Number_Type
;
11766 E
: Entity_Id
) return Boolean;
11767 -- Return True if we are within the scope of an Elaborate_All for E, or if
11768 -- we are within the scope of an Elaborate_All for some other unit U, and U
11769 -- with's E. This prevents spurious warnings when the called entity is
11770 -- renamed within U, or in case of generic instances.
11772 --------------------------------------
11773 -- Activate_Elaborate_All_Desirable --
11774 --------------------------------------
11776 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
) is
11777 UN
: constant Unit_Number_Type
:= Get_Code_Unit
(N
);
11778 CU
: constant Node_Id
:= Cunit
(UN
);
11779 UE
: constant Entity_Id
:= Cunit_Entity
(UN
);
11780 Unm
: constant Unit_Name_Type
:= Unit_Name
(UN
);
11781 CI
: constant List_Id
:= Context_Items
(CU
);
11785 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
);
11786 -- This procedure is called when the elaborate indication must be
11787 -- applied to a unit not in the context of the referencing unit. The
11788 -- unit gets added to the context as an implicit with.
11790 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean;
11791 -- UEs is the spec entity of a unit. If the unit to be marked is
11792 -- in the context item list of this unit spec, then the call returns
11793 -- True and Itm is left set to point to the relevant N_With_Clause node.
11795 procedure Set_Elab_Flag
(Itm
: Node_Id
);
11796 -- Sets Elaborate_[All_]Desirable as appropriate on Itm
11798 -----------------------------
11799 -- Add_To_Context_And_Mark --
11800 -----------------------------
11802 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
) is
11803 CW
: constant Node_Id
:=
11804 Make_With_Clause
(Sloc
(Itm
),
11805 Name
=> Name
(Itm
));
11808 Set_Library_Unit
(CW
, Library_Unit
(Itm
));
11809 Set_Implicit_With
(CW
);
11811 -- Set elaborate all desirable on copy and then append the copy to
11812 -- the list of body with's and we are done.
11814 Set_Elab_Flag
(CW
);
11815 Append_To
(CI
, CW
);
11816 end Add_To_Context_And_Mark
;
11822 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean is
11823 UNs
: constant Unit_Number_Type
:= Get_Source_Unit
(UEs
);
11824 CUs
: constant Node_Id
:= Cunit
(UNs
);
11825 CIs
: constant List_Id
:= Context_Items
(CUs
);
11828 Itm
:= First
(CIs
);
11829 while Present
(Itm
) loop
11830 if Nkind
(Itm
) = N_With_Clause
then
11832 Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
11845 -------------------
11846 -- Set_Elab_Flag --
11847 -------------------
11849 procedure Set_Elab_Flag
(Itm
: Node_Id
) is
11851 if Nkind
(N
) in N_Subprogram_Instantiation
then
11852 Set_Elaborate_Desirable
(Itm
);
11854 Set_Elaborate_All_Desirable
(Itm
);
11858 -- Start of processing for Activate_Elaborate_All_Desirable
11861 -- Do not set binder indication if expansion is disabled, as when
11862 -- compiling a generic unit.
11864 if not Expander_Active
then
11868 -- If an instance of a generic package contains a controlled object (so
11869 -- we're calling Initialize at elaboration time), and the instance is in
11870 -- a package body P that says "with P;", then we need to return without
11871 -- adding "pragma Elaborate_All (P);" to P.
11873 if U
= Main_Unit_Entity
then
11878 while Present
(Itm
) loop
11879 if Nkind
(Itm
) = N_With_Clause
then
11880 Ent
:= Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
11882 -- If we find it, then mark elaborate all desirable and return
11885 Set_Elab_Flag
(Itm
);
11893 -- If we fall through then the with clause is not present in the
11894 -- current unit. One legitimate possibility is that the with clause
11895 -- is present in the spec when we are a body.
11897 if Is_Body_Name
(Unm
)
11898 and then In_Withs_Of
(Spec_Entity
(UE
))
11900 Add_To_Context_And_Mark
(Itm
);
11904 -- Similarly, we may be in the spec or body of a child unit, where
11905 -- the unit in question is with'ed by some ancestor of the child unit.
11907 if Is_Child_Name
(Unm
) then
11914 Pkg
:= Scope
(Pkg
);
11915 exit when Pkg
= Standard_Standard
;
11917 if In_Withs_Of
(Pkg
) then
11918 Add_To_Context_And_Mark
(Itm
);
11925 -- Here if we do not find with clause on spec or body. We just ignore
11926 -- this case; it means that the elaboration involves some other unit
11927 -- than the unit being compiled, and will be caught elsewhere.
11928 end Activate_Elaborate_All_Desirable
;
11934 procedure Check_A_Call
11937 Outer_Scope
: Entity_Id
;
11938 Inter_Unit_Only
: Boolean;
11939 Generate_Warnings
: Boolean := True;
11940 In_Init_Proc
: Boolean := False)
11942 Access_Case
: constant Boolean := Nkind
(N
) = N_Attribute_Reference
;
11943 -- Indicates if we have Access attribute case
11945 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean;
11946 -- True if we're calling an instance of a generic subprogram, or a
11947 -- subprogram in an instance of a generic package, and the call is
11948 -- outside that instance.
11950 procedure Elab_Warning
11953 Ent
: Node_Or_Entity_Id
);
11954 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
11955 -- dynamic or static elaboration model), N and Ent. Msg_D is a real
11956 -- warning (output if Msg_D is non-null and Elab_Warnings is set),
11957 -- Msg_S is an info message (output if Elab_Info_Messages is set).
11959 function Find_W_Scope
return Entity_Id
;
11960 -- Find top-level scope for called entity (not following renamings
11961 -- or derivations). This is where the Elaborate_All will go if it is
11962 -- needed. We start with the called entity, except in the case of an
11963 -- initialization procedure outside the current package, where the init
11964 -- proc is in the root package, and we start from the entity of the name
11967 -----------------------------------
11968 -- Call_To_Instance_From_Outside --
11969 -----------------------------------
11971 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean is
11972 Scop
: Entity_Id
:= Id
;
11976 if Scop
= Standard_Standard
then
11980 if Is_Generic_Instance
(Scop
) then
11981 return not In_Open_Scopes
(Scop
);
11984 Scop
:= Scope
(Scop
);
11986 end Call_To_Instance_From_Outside
;
11992 procedure Elab_Warning
11995 Ent
: Node_Or_Entity_Id
)
11998 -- Dynamic elaboration checks, real warning
12000 if Dynamic_Elaboration_Checks
then
12001 if not Access_Case
then
12002 if Msg_D
/= "" and then Elab_Warnings
then
12003 Error_Msg_NE
(Msg_D
, N
, Ent
);
12006 -- In the access case emit first warning message as well,
12007 -- otherwise list of calls will appear as errors.
12009 elsif Elab_Warnings
then
12010 Error_Msg_NE
(Msg_S
, N
, Ent
);
12013 -- Static elaboration checks, info message
12016 if Elab_Info_Messages
then
12017 Error_Msg_NE
(Msg_S
, N
, Ent
);
12026 function Find_W_Scope
return Entity_Id
is
12027 Refed_Ent
: constant Entity_Id
:= Get_Referenced_Ent
(N
);
12028 W_Scope
: Entity_Id
;
12031 if Is_Init_Proc
(Refed_Ent
)
12032 and then not In_Same_Extended_Unit
(N
, Refed_Ent
)
12034 W_Scope
:= Scope
(Refed_Ent
);
12039 -- Now loop through scopes to get to the enclosing compilation unit
12041 while not Is_Compilation_Unit
(W_Scope
) loop
12042 W_Scope
:= Scope
(W_Scope
);
12050 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
12051 -- Indicates if we have instantiation case
12053 Loc
: constant Source_Ptr
:= Sloc
(N
);
12055 Variable_Case
: constant Boolean :=
12056 Nkind
(N
) in N_Has_Entity
12057 and then Present
(Entity
(N
))
12058 and then Ekind
(Entity
(N
)) = E_Variable
;
12059 -- Indicates if we have variable reference case
12061 W_Scope
: constant Entity_Id
:= Find_W_Scope
;
12062 -- Top-level scope of directly called entity for subprogram. This
12063 -- differs from E_Scope in the case where renamings or derivations
12064 -- are involved, since it does not follow these links. W_Scope is
12065 -- generally in a visible unit, and it is this scope that may require
12066 -- an Elaborate_All. However, there are some cases (initialization
12067 -- calls and calls involving object notation) where W_Scope might not
12068 -- be in the context of the current unit, and there is an intermediate
12069 -- package that is, in which case the Elaborate_All has to be placed
12070 -- on this intermediate package. These special cases are handled in
12071 -- Set_Elaboration_Constraint.
12074 Callee_Unit_Internal
: Boolean;
12075 Caller_Unit_Internal
: Boolean;
12077 Inst_Callee
: Source_Ptr
;
12078 Inst_Caller
: Source_Ptr
;
12079 Unit_Callee
: Unit_Number_Type
;
12080 Unit_Caller
: Unit_Number_Type
;
12082 Body_Acts_As_Spec
: Boolean;
12083 -- Set to true if call is to body acting as spec (no separate spec)
12085 Cunit_SC
: Boolean := False;
12086 -- Set to suppress dynamic elaboration checks where one of the
12087 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
12088 -- if a pragma Elaborate[_All] applies to that scope, in which case
12089 -- warnings on the scope are also suppressed. For the internal case,
12090 -- we ignore this flag.
12092 E_Scope
: Entity_Id
;
12093 -- Top-level scope of entity for called subprogram. This value includes
12094 -- following renamings and derivations, so this scope can be in a
12095 -- non-visible unit. This is the scope that is to be investigated to
12096 -- see whether an elaboration check is required.
12099 -- Flag set when the subprogram being invoked is the procedure generated
12100 -- for pragma Default_Initial_Condition.
12102 SPARK_Elab_Errors
: Boolean;
12103 -- Flag set when an entity is called or a variable is read during SPARK
12104 -- dynamic elaboration.
12106 -- Start of processing for Check_A_Call
12109 -- If the call is known to be within a local Suppress Elaboration
12110 -- pragma, nothing to check. This can happen in task bodies. But
12111 -- we ignore this for a call to a generic formal.
12113 if Nkind
(N
) in N_Subprogram_Call
12114 and then No_Elaboration_Check
(N
)
12115 and then not Is_Call_Of_Generic_Formal
(N
)
12119 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to
12120 -- check, we don't mind in this case if the call occurs before the body
12121 -- since this is all generated code.
12123 elsif Nkind
(Original_Node
(N
)) = N_Attribute_Reference
12124 and then Attribute_Name
(Original_Node
(N
)) = Name_Valid_Scalars
12128 -- Intrinsics such as instances of Unchecked_Deallocation do not have
12129 -- any body, so elaboration checking is not needed, and would be wrong.
12131 elsif Is_Intrinsic_Subprogram
(E
) then
12134 -- Do not consider references to internal variables for SPARK semantics
12136 elsif Variable_Case
and then not Comes_From_Source
(E
) then
12140 -- Proceed with check
12144 -- For a variable reference, just set Body_Acts_As_Spec to False
12146 if Variable_Case
then
12147 Body_Acts_As_Spec
:= False;
12149 -- Additional checks for all other cases
12152 -- Go to parent for derived subprogram, or to original subprogram in
12153 -- the case of a renaming (Alias covers both these cases).
12156 if (Suppress_Elaboration_Warnings
(Ent
)
12157 or else Elaboration_Checks_Suppressed
(Ent
))
12158 and then (Inst_Case
or else No
(Alias
(Ent
)))
12163 -- Nothing to do for imported entities
12165 if Is_Imported
(Ent
) then
12169 exit when Inst_Case
or else No
(Alias
(Ent
));
12170 Ent
:= Alias
(Ent
);
12173 Decl
:= Unit_Declaration_Node
(Ent
);
12175 if Nkind
(Decl
) = N_Subprogram_Body
then
12176 Body_Acts_As_Spec
:= True;
12178 elsif Nkind_In
(Decl
, N_Subprogram_Declaration
,
12179 N_Subprogram_Body_Stub
)
12182 Body_Acts_As_Spec
:= False;
12184 -- If we have none of an instantiation, subprogram body or subprogram
12185 -- declaration, or in the SPARK case, a variable reference, then
12186 -- it is not a case that we want to check. (One case is a call to a
12187 -- generic formal subprogram, where we do not want the check in the
12197 if Elaboration_Checks_Suppressed
(E_Scope
)
12198 or else Suppress_Elaboration_Warnings
(E_Scope
)
12203 -- Exit when we get to compilation unit, not counting subunits
12205 exit when Is_Compilation_Unit
(E_Scope
)
12206 and then (Is_Child_Unit
(E_Scope
)
12207 or else Scope
(E_Scope
) = Standard_Standard
);
12209 pragma Assert
(E_Scope
/= Standard_Standard
);
12211 -- Move up a scope looking for compilation unit
12213 E_Scope
:= Scope
(E_Scope
);
12216 -- No checks needed for pure or preelaborated compilation units
12218 if Is_Pure
(E_Scope
) or else Is_Preelaborated
(E_Scope
) then
12222 -- If the generic entity is within a deeper instance than we are, then
12223 -- either the instantiation to which we refer itself caused an ABE, in
12224 -- which case that will be handled separately, or else we know that the
12225 -- body we need appears as needed at the point of the instantiation.
12226 -- However, this assumption is only valid if we are in static mode.
12228 if not Dynamic_Elaboration_Checks
12230 Instantiation_Depth
(Sloc
(Ent
)) > Instantiation_Depth
(Sloc
(N
))
12235 -- Do not give a warning for a package with no body
12237 if Ekind
(Ent
) = E_Generic_Package
and then not Has_Generic_Body
(N
) then
12241 -- Case of entity is in same unit as call or instantiation. In the
12242 -- instantiation case, W_Scope may be different from E_Scope; we want
12243 -- the unit in which the instantiation occurs, since we're analyzing
12244 -- based on the expansion.
12246 if W_Scope
= C_Scope
then
12247 if not Inter_Unit_Only
then
12248 Check_Internal_Call
(N
, Ent
, Outer_Scope
, E
);
12254 -- Case of entity is not in current unit (i.e. with'ed unit case)
12256 -- We are only interested in such calls if the outer call was from
12257 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
12259 if not From_Elab_Code
and then not Dynamic_Elaboration_Checks
then
12263 -- Nothing to do if some scope said that no checks were required
12269 -- Nothing to do for a generic instance, because a call to an instance
12270 -- cannot fail the elaboration check, because the body of the instance
12271 -- is always elaborated immediately after the spec.
12273 if Call_To_Instance_From_Outside
(Ent
) then
12277 -- Nothing to do if subprogram with no separate spec. However, a call
12278 -- to Deep_Initialize may result in a call to a user-defined Initialize
12279 -- procedure, which imposes a body dependency. This happens only if the
12280 -- type is controlled and the Initialize procedure is not inherited.
12282 if Body_Acts_As_Spec
then
12283 if Is_TSS
(Ent
, TSS_Deep_Initialize
) then
12285 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Ent
));
12289 if not Is_Controlled
(Typ
) then
12292 Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
12294 if Comes_From_Source
(Init
) then
12307 -- Check cases of internal units
12309 Callee_Unit_Internal
:= In_Internal_Unit
(E_Scope
);
12311 -- Do not give a warning if the with'ed unit is internal and this is
12312 -- the generic instantiation case (this saves a lot of hassle dealing
12313 -- with the Text_IO special child units)
12315 if Callee_Unit_Internal
and Inst_Case
then
12319 if C_Scope
= Standard_Standard
then
12320 Caller_Unit_Internal
:= False;
12322 Caller_Unit_Internal
:= In_Internal_Unit
(C_Scope
);
12325 -- Do not give a warning if the with'ed unit is internal and the caller
12326 -- is not internal (since the binder always elaborates internal units
12329 if Callee_Unit_Internal
and not Caller_Unit_Internal
then
12333 -- For now, if debug flag -gnatdE is not set, do no checking for one
12334 -- internal unit withing another. This fixes the problem with the sgi
12335 -- build and storage errors. To be resolved later ???
12337 if (Callee_Unit_Internal
and Caller_Unit_Internal
)
12338 and not Debug_Flag_EE
12343 if Is_TSS
(E
, TSS_Deep_Initialize
) then
12347 -- If the call is in an instance, and the called entity is not
12348 -- defined in the same instance, then the elaboration issue focuses
12349 -- around the unit containing the template, it is this unit that
12350 -- requires an Elaborate_All.
12352 -- However, if we are doing dynamic elaboration, we need to chase the
12353 -- call in the usual manner.
12355 -- We also need to chase the call in the usual manner if it is a call
12356 -- to a generic formal parameter, since that case was not handled as
12357 -- part of the processing of the template.
12359 Inst_Caller
:= Instantiation
(Get_Source_File_Index
(Sloc
(N
)));
12360 Inst_Callee
:= Instantiation
(Get_Source_File_Index
(Sloc
(Ent
)));
12362 if Inst_Caller
= No_Location
then
12363 Unit_Caller
:= No_Unit
;
12365 Unit_Caller
:= Get_Source_Unit
(N
);
12368 if Inst_Callee
= No_Location
then
12369 Unit_Callee
:= No_Unit
;
12371 Unit_Callee
:= Get_Source_Unit
(Ent
);
12374 if Unit_Caller
/= No_Unit
12375 and then Unit_Callee
/= Unit_Caller
12376 and then not Dynamic_Elaboration_Checks
12377 and then not Is_Call_Of_Generic_Formal
(N
)
12379 E_Scope
:= Spec_Entity
(Cunit_Entity
(Unit_Caller
));
12381 -- If we don't get a spec entity, just ignore call. Not quite
12382 -- clear why this check is necessary. ???
12384 if No
(E_Scope
) then
12388 -- Otherwise step to enclosing compilation unit
12390 while not Is_Compilation_Unit
(E_Scope
) loop
12391 E_Scope
:= Scope
(E_Scope
);
12394 -- For the case where N is not an instance, and is not a call within
12395 -- instance to other than a generic formal, we recompute E_Scope
12396 -- for the error message, since we do NOT want to go to the unit
12397 -- that has the ultimate declaration in the case of renaming and
12398 -- derivation and we also want to go to the generic unit in the
12399 -- case of an instance, and no further.
12402 -- Loop to carefully follow renamings and derivations one step
12403 -- outside the current unit, but not further.
12405 if not (Inst_Case
or Variable_Case
)
12406 and then Present
(Alias
(Ent
))
12408 E_Scope
:= Alias
(Ent
);
12414 while not Is_Compilation_Unit
(E_Scope
) loop
12415 E_Scope
:= Scope
(E_Scope
);
12418 -- If E_Scope is the same as C_Scope, it means that there
12419 -- definitely was a local renaming or derivation, and we
12420 -- are not yet out of the current unit.
12422 exit when E_Scope
/= C_Scope
;
12423 Ent
:= Alias
(Ent
);
12426 -- If no alias, there could be a previous error, but not if we've
12427 -- already reached the outermost level (Standard).
12435 if Within_Elaborate_All
(Current_Sem_Unit
, E_Scope
) then
12439 -- Determine whether the Default_Initial_Condition procedure of some
12440 -- type is being invoked.
12442 Is_DIC
:= Ekind
(Ent
) = E_Procedure
and then Is_DIC_Procedure
(Ent
);
12444 -- Checks related to Default_Initial_Condition fall under the SPARK
12445 -- umbrella because this is a SPARK-specific annotation.
12447 SPARK_Elab_Errors
:=
12448 SPARK_Mode
= On
and (Is_DIC
or Dynamic_Elaboration_Checks
);
12450 -- Now check if an Elaborate_All (or dynamic check) is needed
12452 if (Elab_Info_Messages
or Elab_Warnings
or SPARK_Elab_Errors
)
12453 and then Generate_Warnings
12454 and then not Suppress_Elaboration_Warnings
(Ent
)
12455 and then not Elaboration_Checks_Suppressed
(Ent
)
12456 and then not Suppress_Elaboration_Warnings
(E_Scope
)
12457 and then not Elaboration_Checks_Suppressed
(E_Scope
)
12459 -- Instantiation case
12462 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
12464 ("instantiation of & during elaboration in SPARK", N
, Ent
);
12467 ("instantiation of & may raise Program_Error?l?",
12468 "info: instantiation of & during elaboration?$?", Ent
);
12471 -- Indirect call case, info message only in static elaboration
12472 -- case, because the attribute reference itself cannot raise an
12473 -- exception. Note that SPARK does not permit indirect calls.
12475 elsif Access_Case
then
12476 Elab_Warning
("", "info: access to & during elaboration?$?", Ent
);
12478 -- Variable reference in SPARK mode
12480 elsif Variable_Case
then
12481 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
12483 ("reference to & during elaboration in SPARK", N
, Ent
);
12486 -- Subprogram call case
12489 if Nkind
(Name
(N
)) in N_Has_Entity
12490 and then Is_Init_Proc
(Entity
(Name
(N
)))
12491 and then Comes_From_Source
(Ent
)
12494 ("implicit call to & may raise Program_Error?l?",
12495 "info: implicit call to & during elaboration?$?",
12498 elsif SPARK_Elab_Errors
then
12500 -- Emit a specialized error message when the elaboration of an
12501 -- object of a private type evaluates the expression of pragma
12502 -- Default_Initial_Condition. This prevents the internal name
12503 -- of the procedure from appearing in the error message.
12507 ("call to Default_Initial_Condition during elaboration in "
12511 ("call to & during elaboration in SPARK", N
, Ent
);
12516 ("call to & may raise Program_Error?l?",
12517 "info: call to & during elaboration?$?",
12522 Error_Msg_Qual_Level
:= Nat
'Last;
12524 -- Case of Elaborate_All not present and required, for SPARK this
12525 -- is an error, so give an error message.
12527 if SPARK_Elab_Errors
then
12528 Error_Msg_NE
-- CODEFIX
12529 ("\Elaborate_All pragma required for&", N
, W_Scope
);
12531 -- Otherwise we generate an implicit pragma. For a subprogram
12532 -- instantiation, Elaborate is good enough, since no transitive
12533 -- call is possible at elaboration time in this case.
12535 elsif Nkind
(N
) in N_Subprogram_Instantiation
then
12537 ("\missing pragma Elaborate for&?l?",
12538 "\implicit pragma Elaborate for& generated?$?",
12541 -- For all other cases, we need an implicit Elaborate_All
12545 ("\missing pragma Elaborate_All for&?l?",
12546 "\implicit pragma Elaborate_All for & generated?$?",
12550 Error_Msg_Qual_Level
:= 0;
12552 -- Take into account the flags related to elaboration warning
12553 -- messages when enumerating the various calls involved. This
12554 -- ensures the proper pairing of the main warning and the
12555 -- clarification messages generated by Output_Calls.
12557 Output_Calls
(N
, Check_Elab_Flag
=> True);
12559 -- Set flag to prevent further warnings for same unit unless in
12560 -- All_Errors_Mode.
12562 if not All_Errors_Mode
and not Dynamic_Elaboration_Checks
then
12563 Set_Suppress_Elaboration_Warnings
(W_Scope
);
12567 -- Check for runtime elaboration check required
12569 if Dynamic_Elaboration_Checks
then
12570 if not Elaboration_Checks_Suppressed
(Ent
)
12571 and then not Elaboration_Checks_Suppressed
(W_Scope
)
12572 and then not Elaboration_Checks_Suppressed
(E_Scope
)
12573 and then not Cunit_SC
12575 -- Runtime elaboration check required. Generate check of the
12576 -- elaboration Boolean for the unit containing the entity.
12578 -- Note that for this case, we do check the real unit (the one
12579 -- from following renamings, since that is the issue).
12581 -- Could this possibly miss a useless but required PE???
12583 Insert_Elab_Check
(N
,
12584 Make_Attribute_Reference
(Loc
,
12585 Attribute_Name
=> Name_Elaborated
,
12587 New_Occurrence_Of
(Spec_Entity
(E_Scope
), Loc
)));
12589 -- Prevent duplicate elaboration checks on the same call, which
12590 -- can happen if the body enclosing the call appears itself in a
12591 -- call whose elaboration check is delayed.
12593 if Nkind
(N
) in N_Subprogram_Call
then
12594 Set_No_Elaboration_Check
(N
);
12598 -- Case of static elaboration model
12601 -- Do not do anything if elaboration checks suppressed. Note that
12602 -- we check Ent here, not E, since we want the real entity for the
12603 -- body to see if checks are suppressed for it, not the dummy
12604 -- entry for renamings or derivations.
12606 if Elaboration_Checks_Suppressed
(Ent
)
12607 or else Elaboration_Checks_Suppressed
(E_Scope
)
12608 or else Elaboration_Checks_Suppressed
(W_Scope
)
12612 -- Do not generate an Elaborate_All for finalization routines
12613 -- that perform partial clean up as part of initialization.
12615 elsif In_Init_Proc
and then Is_Finalization_Procedure
(Ent
) then
12618 -- Here we need to generate an implicit elaborate all
12621 -- Generate Elaborate_All warning unless suppressed
12623 if (Elab_Info_Messages
and Generate_Warnings
and not Inst_Case
)
12624 and then not Suppress_Elaboration_Warnings
(Ent
)
12625 and then not Suppress_Elaboration_Warnings
(E_Scope
)
12626 and then not Suppress_Elaboration_Warnings
(W_Scope
)
12628 Error_Msg_Node_2
:= W_Scope
;
12630 ("info: call to& in elaboration code requires pragma "
12631 & "Elaborate_All on&?$?", N
, E
);
12634 -- Set indication for binder to generate Elaborate_All
12636 Set_Elaboration_Constraint
(N
, E
, W_Scope
);
12641 -----------------------------
12642 -- Check_Bad_Instantiation --
12643 -----------------------------
12645 procedure Check_Bad_Instantiation
(N
: Node_Id
) is
12649 -- Nothing to do if we do not have an instantiation (happens in some
12650 -- error cases, and also in the formal package declaration case)
12652 if Nkind
(N
) not in N_Generic_Instantiation
then
12655 -- Nothing to do if serious errors detected (avoid cascaded errors)
12657 elsif Serious_Errors_Detected
/= 0 then
12660 -- Nothing to do if not in full analysis mode
12662 elsif not Full_Analysis
then
12665 -- Nothing to do if inside a generic template
12667 elsif Inside_A_Generic
then
12670 -- Nothing to do if a library level instantiation
12672 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
12675 -- Nothing to do if we are compiling a proper body for semantic
12676 -- purposes only. The generic body may be in another proper body.
12679 Nkind
(Parent
(Unit_Declaration_Node
(Main_Unit_Entity
))) = N_Subunit
12684 Ent
:= Get_Generic_Entity
(N
);
12686 -- The case we are interested in is when the generic spec is in the
12687 -- current declarative part
12689 if not Same_Elaboration_Scope
(Current_Scope
, Scope
(Ent
))
12690 or else not In_Same_Extended_Unit
(N
, Ent
)
12695 -- If the generic entity is within a deeper instance than we are, then
12696 -- either the instantiation to which we refer itself caused an ABE, in
12697 -- which case that will be handled separately. Otherwise, we know that
12698 -- the body we need appears as needed at the point of the instantiation.
12699 -- If they are both at the same level but not within the same instance
12700 -- then the body of the generic will be in the earlier instance.
12703 D1
: constant Nat
:= Instantiation_Depth
(Sloc
(Ent
));
12704 D2
: constant Nat
:= Instantiation_Depth
(Sloc
(N
));
12711 and then Is_Generic_Instance
(Scope
(Ent
))
12712 and then not In_Open_Scopes
(Scope
(Ent
))
12718 -- Now we can proceed, if the entity being called has a completion,
12719 -- then we are definitely OK, since we have already seen the body.
12721 if Has_Completion
(Ent
) then
12725 -- If there is no body, then nothing to do
12727 if not Has_Generic_Body
(N
) then
12731 -- Here we definitely have a bad instantiation
12733 Error_Msg_Warn
:= SPARK_Mode
/= On
;
12734 Error_Msg_NE
("cannot instantiate& before body seen<<", N
, Ent
);
12735 Error_Msg_N
("\Program_Error [<<", N
);
12737 Insert_Elab_Check
(N
);
12738 Set_Is_Known_Guaranteed_ABE
(N
);
12739 end Check_Bad_Instantiation
;
12741 ---------------------
12742 -- Check_Elab_Call --
12743 ---------------------
12745 procedure Check_Elab_Call
12747 Outer_Scope
: Entity_Id
:= Empty
;
12748 In_Init_Proc
: Boolean := False)
12754 pragma Assert
(Legacy_Elaboration_Checks
);
12756 -- If the reference is not in the main unit, there is nothing to check.
12757 -- Elaboration call from units in the context of the main unit will lead
12758 -- to semantic dependencies when those units are compiled.
12760 if not In_Extended_Main_Code_Unit
(N
) then
12764 -- For an entry call, check relevant restriction
12766 if Nkind
(N
) = N_Entry_Call_Statement
12767 and then not In_Subprogram_Or_Concurrent_Unit
12769 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, N
);
12771 -- Nothing to do if this is not an expected type of reference (happens
12772 -- in some error conditions, and in some cases where rewriting occurs).
12774 elsif Nkind
(N
) not in N_Subprogram_Call
12775 and then Nkind
(N
) /= N_Attribute_Reference
12776 and then (SPARK_Mode
/= On
12777 or else Nkind
(N
) not in N_Has_Entity
12778 or else No
(Entity
(N
))
12779 or else Ekind
(Entity
(N
)) /= E_Variable
)
12783 -- Nothing to do if this is a call already rewritten for elab checking.
12784 -- Such calls appear as the targets of If_Expressions.
12786 -- This check MUST be wrong, it catches far too much
12788 elsif Nkind
(Parent
(N
)) = N_If_Expression
then
12791 -- Nothing to do if inside a generic template
12793 elsif Inside_A_Generic
12794 and then No
(Enclosing_Generic_Body
(N
))
12798 -- Nothing to do if call is being preanalyzed, as when within a
12799 -- pre/postcondition, a predicate, or an invariant.
12801 elsif In_Spec_Expression
then
12805 -- Nothing to do if this is a call to a postcondition, which is always
12806 -- within a subprogram body, even though the current scope may be the
12807 -- enclosing scope of the subprogram.
12809 if Nkind
(N
) = N_Procedure_Call_Statement
12810 and then Is_Entity_Name
(Name
(N
))
12811 and then Chars
(Entity
(Name
(N
))) = Name_uPostconditions
12816 -- Here we have a reference at elaboration time that must be checked
12818 if Debug_Flag_Underscore_LL
then
12819 Write_Str
(" Check_Elab_Ref: ");
12821 if Nkind
(N
) = N_Attribute_Reference
then
12822 if not Is_Entity_Name
(Prefix
(N
)) then
12823 Write_Str
("<<not entity name>>");
12825 Write_Name
(Chars
(Entity
(Prefix
(N
))));
12828 Write_Str
("'Access");
12830 elsif No
(Name
(N
)) or else not Is_Entity_Name
(Name
(N
)) then
12831 Write_Str
("<<not entity name>> ");
12834 Write_Name
(Chars
(Entity
(Name
(N
))));
12837 Write_Str
(" reference at ");
12838 Write_Location
(Sloc
(N
));
12842 -- Climb up the tree to make sure we are not inside default expression
12843 -- of a parameter specification or a record component, since in both
12844 -- these cases, we will be doing the actual reference later, not now,
12845 -- and it is at the time of the actual reference (statically speaking)
12846 -- that we must do our static check, not at the time of its initial
12849 -- However, we have to check references within component definitions
12850 -- (e.g. a function call that determines an array component bound),
12851 -- so we terminate the loop in that case.
12854 while Present
(P
) loop
12855 if Nkind_In
(P
, N_Parameter_Specification
,
12856 N_Component_Declaration
)
12860 -- The reference occurs within the constraint of a component,
12861 -- so it must be checked.
12863 elsif Nkind
(P
) = N_Component_Definition
then
12871 -- Stuff that happens only at the outer level
12873 if No
(Outer_Scope
) then
12874 Elab_Visited
.Set_Last
(0);
12876 -- Nothing to do if current scope is Standard (this is a bit odd, but
12877 -- it happens in the case of generic instantiations).
12879 C_Scope
:= Current_Scope
;
12881 if C_Scope
= Standard_Standard
then
12885 -- First case, we are in elaboration code
12887 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
12889 if From_Elab_Code
then
12891 -- Complain if ref that comes from source in preelaborated unit
12892 -- and we are not inside a subprogram (i.e. we are in elab code).
12894 if Comes_From_Source
(N
)
12895 and then In_Preelaborated_Unit
12896 and then not In_Inlined_Body
12897 and then Nkind
(N
) /= N_Attribute_Reference
12899 -- This is a warning in GNAT mode allowing such calls to be
12900 -- used in the predefined library with appropriate care.
12902 Error_Msg_Warn
:= GNAT_Mode
;
12904 ("<<non-static call not allowed in preelaborated unit", N
);
12908 -- Second case, we are inside a subprogram or concurrent unit, which
12909 -- means we are not in elaboration code.
12912 -- In this case, the issue is whether we are inside the
12913 -- declarative part of the unit in which we live, or inside its
12914 -- statements. In the latter case, there is no issue of ABE calls
12915 -- at this level (a call from outside to the unit in which we live
12916 -- might cause an ABE, but that will be detected when we analyze
12917 -- that outer level call, as it recurses into the called unit).
12919 -- Climb up the tree, doing this test, and also testing for being
12920 -- inside a default expression, which, as discussed above, is not
12921 -- checked at this stage.
12930 -- If we find a parentless subtree, it seems safe to assume
12931 -- that we are not in a declarative part and that no
12932 -- checking is required.
12938 if Is_List_Member
(P
) then
12939 L
:= List_Containing
(P
);
12946 exit when Nkind
(P
) = N_Subunit
;
12948 -- Filter out case of default expressions, where we do not
12949 -- do the check at this stage.
12951 if Nkind_In
(P
, N_Parameter_Specification
,
12952 N_Component_Declaration
)
12957 -- A protected body has no elaboration code and contains
12958 -- only other bodies.
12960 if Nkind
(P
) = N_Protected_Body
then
12963 elsif Nkind_In
(P
, N_Subprogram_Body
,
12968 if L
= Declarations
(P
) then
12971 -- We are not in elaboration code, but we are doing
12972 -- dynamic elaboration checks, in this case, we still
12973 -- need to do the reference, since the subprogram we are
12974 -- in could be called from another unit, also in dynamic
12975 -- elaboration check mode, at elaboration time.
12977 elsif Dynamic_Elaboration_Checks
then
12979 -- We provide a debug flag to disable this check. That
12980 -- way we have an easy work around for regressions
12981 -- that are caused by this new check. This debug flag
12982 -- can be removed later.
12984 if Debug_Flag_DD
then
12988 -- Do the check in this case
12992 elsif Nkind
(P
) = N_Task_Body
then
12994 -- The check is deferred until Check_Task_Activation
12995 -- but we need to capture local suppress pragmas
12996 -- that may inhibit checks on this call.
12998 Ent
:= Get_Referenced_Ent
(N
);
13003 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
13004 or else Elaboration_Checks_Suppressed
(Ent
)
13005 or else Elaboration_Checks_Suppressed
(Scope
(Ent
))
13007 if Nkind
(N
) in N_Subprogram_Call
then
13008 Set_No_Elaboration_Check
(N
);
13014 -- Static model, call is not in elaboration code, we
13015 -- never need to worry, because in the static model the
13016 -- top-level caller always takes care of things.
13027 Ent
:= Get_Referenced_Ent
(N
);
13033 -- Determine whether a prior call to the same subprogram was already
13034 -- examined within the same context. If this is the case, then there is
13035 -- no need to proceed with the various warnings and checks because the
13036 -- work was already done for the previous call.
13039 Self
: constant Visited_Element
:=
13040 (Subp_Id
=> Ent
, Context
=> Parent
(N
));
13043 for Index
in 1 .. Elab_Visited
.Last
loop
13044 if Self
= Elab_Visited
.Table
(Index
) then
13050 -- See if we need to analyze this reference. We analyze it if either of
13051 -- the following conditions is met:
13053 -- It is an inner level call (since in this case it was triggered
13054 -- by an outer level call from elaboration code), but only if the
13055 -- call is within the scope of the original outer level call.
13057 -- It is an outer level reference from elaboration code, or a call to
13058 -- an entity is in the same elaboration scope.
13060 -- And in these cases, we will check both inter-unit calls and
13061 -- intra-unit (within a single unit) calls.
13063 C_Scope
:= Current_Scope
;
13065 -- If not outer level reference, then we follow it if it is within the
13066 -- original scope of the outer reference.
13068 if Present
(Outer_Scope
)
13069 and then Within
(Scope
(Ent
), Outer_Scope
)
13075 Outer_Scope
=> Outer_Scope
,
13076 Inter_Unit_Only
=> False,
13077 In_Init_Proc
=> In_Init_Proc
);
13079 -- Nothing to do if elaboration checks suppressed for this scope.
13080 -- However, an interesting exception, the fact that elaboration checks
13081 -- are suppressed within an instance (because we can trace the body when
13082 -- we process the template) does not extend to calls to generic formal
13085 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
13086 and then not Is_Call_Of_Generic_Formal
(N
)
13090 elsif From_Elab_Code
then
13092 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
13094 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
13096 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
13098 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
13099 -- is set, then we will do the check, but only in the inter-unit case
13100 -- (this is to accommodate unguarded elaboration calls from other units
13101 -- in which this same mode is set). We don't want warnings in this case,
13102 -- it would generate warnings having nothing to do with elaboration.
13104 elsif Dynamic_Elaboration_Checks
then
13110 Inter_Unit_Only
=> True,
13111 Generate_Warnings
=> False);
13113 -- Otherwise nothing to do
13119 -- A call to an Init_Proc in elaboration code may bring additional
13120 -- dependencies, if some of the record components thereof have
13121 -- initializations that are function calls that come from source. We
13122 -- treat the current node as a call to each of these functions, to check
13123 -- their elaboration impact.
13125 if Is_Init_Proc
(Ent
) and then From_Elab_Code
then
13126 Process_Init_Proc
: declare
13127 Unit_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
13129 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
;
13130 -- Find subprogram calls within body of Init_Proc for Traverse
13131 -- instantiation below.
13133 procedure Traverse_Body
is new Traverse_Proc
(Check_Init_Call
);
13134 -- Traversal procedure to find all calls with body of Init_Proc
13136 ---------------------
13137 -- Check_Init_Call --
13138 ---------------------
13140 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
is
13144 if Nkind
(Nod
) in N_Subprogram_Call
13145 and then Is_Entity_Name
(Name
(Nod
))
13147 Func
:= Entity
(Name
(Nod
));
13149 if Comes_From_Source
(Func
) then
13151 (N
, Func
, Standard_Standard
, Inter_Unit_Only
=> True);
13159 end Check_Init_Call
;
13161 -- Start of processing for Process_Init_Proc
13164 if Nkind
(Unit_Decl
) = N_Subprogram_Body
then
13165 Traverse_Body
(Handled_Statement_Sequence
(Unit_Decl
));
13167 end Process_Init_Proc
;
13169 end Check_Elab_Call
;
13171 -----------------------
13172 -- Check_Elab_Assign --
13173 -----------------------
13175 procedure Check_Elab_Assign
(N
: Node_Id
) is
13179 Pkg_Spec
: Entity_Id
;
13180 Pkg_Body
: Entity_Id
;
13183 pragma Assert
(Legacy_Elaboration_Checks
);
13185 -- For record or array component, check prefix. If it is an access type,
13186 -- then there is nothing to do (we do not know what is being assigned),
13187 -- but otherwise this is an assignment to the prefix.
13189 if Nkind_In
(N
, N_Indexed_Component
,
13190 N_Selected_Component
,
13193 if not Is_Access_Type
(Etype
(Prefix
(N
))) then
13194 Check_Elab_Assign
(Prefix
(N
));
13200 -- For type conversion, check expression
13202 if Nkind
(N
) = N_Type_Conversion
then
13203 Check_Elab_Assign
(Expression
(N
));
13207 -- Nothing to do if this is not an entity reference otherwise get entity
13209 if Is_Entity_Name
(N
) then
13215 -- What we are looking for is a reference in the body of a package that
13216 -- modifies a variable declared in the visible part of the package spec.
13219 and then Comes_From_Source
(N
)
13220 and then not Suppress_Elaboration_Warnings
(Ent
)
13221 and then Ekind
(Ent
) = E_Variable
13222 and then not In_Private_Part
(Ent
)
13223 and then Is_Library_Level_Entity
(Ent
)
13225 Scop
:= Current_Scope
;
13227 if No
(Scop
) or else Scop
= Standard_Standard
then
13229 elsif Ekind
(Scop
) = E_Package
13230 and then Is_Compilation_Unit
(Scop
)
13234 Scop
:= Scope
(Scop
);
13238 -- Here Scop points to the containing library package
13241 Pkg_Body
:= Body_Entity
(Pkg_Spec
);
13243 -- All OK if the package has an Elaborate_Body pragma
13245 if Has_Pragma_Elaborate_Body
(Scop
) then
13249 -- OK if entity being modified is not in containing package spec
13251 if not In_Same_Source_Unit
(Scop
, Ent
) then
13255 -- All OK if entity appears in generic package or generic instance.
13256 -- We just get too messed up trying to give proper warnings in the
13257 -- presence of generics. Better no message than a junk one.
13259 Scop
:= Scope
(Ent
);
13260 while Present
(Scop
) and then Scop
/= Pkg_Spec
loop
13261 if Ekind
(Scop
) = E_Generic_Package
then
13263 elsif Ekind
(Scop
) = E_Package
13264 and then Is_Generic_Instance
(Scop
)
13269 Scop
:= Scope
(Scop
);
13272 -- All OK if in task, don't issue warnings there
13274 if In_Task_Activation
then
13278 -- OK if no package body
13280 if No
(Pkg_Body
) then
13284 -- OK if reference is not in package body
13286 if not In_Same_Source_Unit
(Pkg_Body
, N
) then
13290 -- OK if package body has no handled statement sequence
13293 HSS
: constant Node_Id
:=
13294 Handled_Statement_Sequence
(Declaration_Node
(Pkg_Body
));
13296 if No
(HSS
) or else not Comes_From_Source
(HSS
) then
13301 -- We definitely have a case of a modification of an entity in
13302 -- the package spec from the elaboration code of the package body.
13303 -- We may not give the warning (because there are some additional
13304 -- checks to avoid too many false positives), but it would be a good
13305 -- idea for the binder to try to keep the body elaboration close to
13306 -- the spec elaboration.
13308 Set_Elaborate_Body_Desirable
(Pkg_Spec
);
13310 -- All OK in gnat mode (we know what we are doing)
13316 -- All OK if all warnings suppressed
13318 if Warning_Mode
= Suppress
then
13322 -- All OK if elaboration checks suppressed for entity
13324 if Checks_May_Be_Suppressed
(Ent
)
13325 and then Is_Check_Suppressed
(Ent
, Elaboration_Check
)
13330 -- OK if the entity is initialized. Note that the No_Initialization
13331 -- flag usually means that the initialization has been rewritten into
13332 -- assignments, but that still counts for us.
13335 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
13337 if Nkind
(Decl
) = N_Object_Declaration
13338 and then (Present
(Expression
(Decl
))
13339 or else No_Initialization
(Decl
))
13345 -- Here is where we give the warning
13347 -- All OK if warnings suppressed on the entity
13349 if not Has_Warnings_Off
(Ent
) then
13350 Error_Msg_Sloc
:= Sloc
(Ent
);
13353 ("??& can be accessed by clients before this initialization",
13356 ("\??add Elaborate_Body to spec to ensure & is initialized",
13360 if not All_Errors_Mode
then
13361 Set_Suppress_Elaboration_Warnings
(Ent
);
13364 end Check_Elab_Assign
;
13366 ----------------------
13367 -- Check_Elab_Calls --
13368 ----------------------
13370 -- WARNING: This routine manages SPARK regions
13372 procedure Check_Elab_Calls
is
13373 Saved_SM
: SPARK_Mode_Type
;
13374 Saved_SMP
: Node_Id
;
13377 pragma Assert
(Legacy_Elaboration_Checks
);
13379 -- If expansion is disabled, do not generate any checks, unless we
13380 -- are in GNATprove mode, so that errors are issued in GNATprove for
13381 -- violations of static elaboration rules in SPARK code. Also skip
13382 -- checks if any subunits are missing because in either case we lack the
13383 -- full information that we need, and no object file will be created in
13386 if (not Expander_Active
and not GNATprove_Mode
)
13387 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
13388 or else Subunits_Missing
13393 -- Skip delayed calls if we had any errors
13395 if Serious_Errors_Detected
= 0 then
13396 Delaying_Elab_Checks
:= False;
13397 Expander_Mode_Save_And_Set
(True);
13399 for J
in Delay_Check
.First
.. Delay_Check
.Last
loop
13400 Push_Scope
(Delay_Check
.Table
(J
).Curscop
);
13401 From_Elab_Code
:= Delay_Check
.Table
(J
).From_Elab_Code
;
13402 In_Task_Activation
:= Delay_Check
.Table
(J
).In_Task_Activation
;
13404 Saved_SM
:= SPARK_Mode
;
13405 Saved_SMP
:= SPARK_Mode_Pragma
;
13407 -- Set appropriate value of SPARK_Mode
13409 if Delay_Check
.Table
(J
).From_SPARK_Code
then
13413 Check_Internal_Call_Continue
13414 (N
=> Delay_Check
.Table
(J
).N
,
13415 E
=> Delay_Check
.Table
(J
).E
,
13416 Outer_Scope
=> Delay_Check
.Table
(J
).Outer_Scope
,
13417 Orig_Ent
=> Delay_Check
.Table
(J
).Orig_Ent
);
13419 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
13423 -- Set Delaying_Elab_Checks back on for next main compilation
13425 Expander_Mode_Restore
;
13426 Delaying_Elab_Checks
:= True;
13428 end Check_Elab_Calls
;
13430 ------------------------------
13431 -- Check_Elab_Instantiation --
13432 ------------------------------
13434 procedure Check_Elab_Instantiation
13436 Outer_Scope
: Entity_Id
:= Empty
)
13441 pragma Assert
(Legacy_Elaboration_Checks
);
13443 -- Check for and deal with bad instantiation case. There is some
13444 -- duplicated code here, but we will worry about this later ???
13446 Check_Bad_Instantiation
(N
);
13448 if Is_Known_Guaranteed_ABE
(N
) then
13452 -- Nothing to do if we do not have an instantiation (happens in some
13453 -- error cases, and also in the formal package declaration case)
13455 if Nkind
(N
) not in N_Generic_Instantiation
then
13459 -- Nothing to do if inside a generic template
13461 if Inside_A_Generic
then
13465 -- Nothing to do if the instantiation is not in the main unit
13467 if not In_Extended_Main_Code_Unit
(N
) then
13471 Ent
:= Get_Generic_Entity
(N
);
13472 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
13474 -- See if we need to analyze this instantiation. We analyze it if
13475 -- either of the following conditions is met:
13477 -- It is an inner level instantiation (since in this case it was
13478 -- triggered by an outer level call from elaboration code), but
13479 -- only if the instantiation is within the scope of the original
13480 -- outer level call.
13482 -- It is an outer level instantiation from elaboration code, or the
13483 -- instantiated entity is in the same elaboration scope.
13485 -- And in these cases, we will check both the inter-unit case and
13486 -- the intra-unit (within a single unit) case.
13488 C_Scope
:= Current_Scope
;
13490 if Present
(Outer_Scope
) and then Within
(Scope
(Ent
), Outer_Scope
) then
13492 Check_A_Call
(N
, Ent
, Outer_Scope
, Inter_Unit_Only
=> False);
13494 elsif From_Elab_Code
then
13496 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
13498 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
13500 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
13502 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is
13503 -- set, then we will do the check, but only in the inter-unit case (this
13504 -- is to accommodate unguarded elaboration calls from other units in
13505 -- which this same mode is set). We inhibit warnings in this case, since
13506 -- this instantiation is not occurring in elaboration code.
13508 elsif Dynamic_Elaboration_Checks
then
13514 Inter_Unit_Only
=> True,
13515 Generate_Warnings
=> False);
13520 end Check_Elab_Instantiation
;
13522 -------------------------
13523 -- Check_Internal_Call --
13524 -------------------------
13526 procedure Check_Internal_Call
13529 Outer_Scope
: Entity_Id
;
13530 Orig_Ent
: Entity_Id
)
13532 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean;
13533 -- Determine whether call Call occurs within pragma Initial_Condition or
13534 -- pragma Check with check_kind set to Initial_Condition.
13536 ------------------------------
13537 -- Within_Initial_Condition --
13538 ------------------------------
13540 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean is
13546 -- Traverse the parent chain looking for an enclosing pragma
13549 while Present
(Par
) loop
13550 if Nkind
(Par
) = N_Pragma
then
13551 Nam
:= Pragma_Name
(Par
);
13553 -- Pragma Initial_Condition appears in its alternative from as
13554 -- Check (Initial_Condition, ...).
13556 if Nam
= Name_Check
then
13557 Args
:= Pragma_Argument_Associations
(Par
);
13559 -- Pragma Check should have at least two arguments
13561 pragma Assert
(Present
(Args
));
13564 Chars
(Expression
(First
(Args
))) = Name_Initial_Condition
;
13568 elsif Nam
= Name_Initial_Condition
then
13571 -- Since pragmas are never nested within other pragmas, stop
13578 -- Prevent the search from going too far
13580 elsif Is_Body_Or_Package_Declaration
(Par
) then
13584 Par
:= Parent
(Par
);
13586 -- If assertions are not enabled, the check pragma is rewritten
13587 -- as an if_statement in sem_prag, to generate various warnings
13588 -- on boolean expressions. Retrieve the original pragma.
13590 if Nkind
(Original_Node
(Par
)) = N_Pragma
then
13591 Par
:= Original_Node
(Par
);
13596 end Within_Initial_Condition
;
13600 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
13602 -- Start of processing for Check_Internal_Call
13605 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the
13606 -- node comes from source.
13608 if Nkind
(N
) = N_Attribute_Reference
13609 and then ((not Warn_On_Elab_Access
and then not Debug_Flag_Dot_O
)
13610 or else not Comes_From_Source
(N
))
13614 -- If not function or procedure call, instantiation, or 'Access, then
13615 -- ignore call (this happens in some error cases and rewriting cases).
13617 elsif not Nkind_In
(N
, N_Attribute_Reference
,
13619 N_Procedure_Call_Statement
)
13620 and then not Inst_Case
13624 -- Nothing to do if this is a call or instantiation that has already
13625 -- been found to be a sure ABE.
13627 elsif Nkind
(N
) /= N_Attribute_Reference
13628 and then Is_Known_Guaranteed_ABE
(N
)
13632 -- Nothing to do if errors already detected (avoid cascaded errors)
13634 elsif Serious_Errors_Detected
/= 0 then
13637 -- Nothing to do if not in full analysis mode
13639 elsif not Full_Analysis
then
13642 -- Nothing to do if analyzing in special spec-expression mode, since the
13643 -- call is not actually being made at this time.
13645 elsif In_Spec_Expression
then
13648 -- Nothing to do for call to intrinsic subprogram
13650 elsif Is_Intrinsic_Subprogram
(E
) then
13653 -- Nothing to do if call is within a generic unit
13655 elsif Inside_A_Generic
then
13658 -- Nothing to do when the call appears within pragma Initial_Condition.
13659 -- The pragma is part of the elaboration statements of a package body
13660 -- and may only call external subprograms or subprograms whose body is
13661 -- already available.
13663 elsif Within_Initial_Condition
(N
) then
13667 -- Delay this call if we are still delaying calls
13669 if Delaying_Elab_Checks
then
13673 Orig_Ent
=> Orig_Ent
,
13674 Curscop
=> Current_Scope
,
13675 Outer_Scope
=> Outer_Scope
,
13676 From_Elab_Code
=> From_Elab_Code
,
13677 In_Task_Activation
=> In_Task_Activation
,
13678 From_SPARK_Code
=> SPARK_Mode
= On
));
13681 -- Otherwise, call phase 2 continuation right now
13684 Check_Internal_Call_Continue
(N
, E
, Outer_Scope
, Orig_Ent
);
13686 end Check_Internal_Call
;
13688 ----------------------------------
13689 -- Check_Internal_Call_Continue --
13690 ----------------------------------
13692 procedure Check_Internal_Call_Continue
13695 Outer_Scope
: Entity_Id
;
13696 Orig_Ent
: Entity_Id
)
13698 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
;
13699 -- Function applied to each node as we traverse the body. Checks for
13700 -- call or entity reference that needs checking, and if so checks it.
13701 -- Always returns OK, so entire tree is traversed, except that as
13702 -- described below subprogram bodies are skipped for now.
13704 procedure Traverse
is new Atree
.Traverse_Proc
(Find_Elab_Reference
);
13705 -- Traverse procedure using above Find_Elab_Reference function
13707 -------------------------
13708 -- Find_Elab_Reference --
13709 -------------------------
13711 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
is
13715 -- If user has specified that there are no entry calls in elaboration
13716 -- code, do not trace past an accept statement, because the rendez-
13717 -- vous will happen after elaboration.
13719 if Nkind_In
(Original_Node
(N
), N_Accept_Statement
,
13720 N_Selective_Accept
)
13721 and then Restriction_Active
(No_Entry_Calls_In_Elaboration_Code
)
13725 -- If we have a function call, check it
13727 elsif Nkind
(N
) = N_Function_Call
then
13728 Check_Elab_Call
(N
, Outer_Scope
);
13731 -- If we have a procedure call, check the call, and also check
13732 -- arguments that are assignments (OUT or IN OUT mode formals).
13734 elsif Nkind
(N
) = N_Procedure_Call_Statement
then
13735 Check_Elab_Call
(N
, Outer_Scope
, In_Init_Proc
=> Is_Init_Proc
(E
));
13737 Actual
:= First_Actual
(N
);
13738 while Present
(Actual
) loop
13739 if Known_To_Be_Assigned
(Actual
) then
13740 Check_Elab_Assign
(Actual
);
13743 Next_Actual
(Actual
);
13748 -- If we have an access attribute for a subprogram, check it.
13749 -- Suppress this behavior under debug flag.
13751 elsif not Debug_Flag_Dot_UU
13752 and then Nkind
(N
) = N_Attribute_Reference
13753 and then Nam_In
(Attribute_Name
(N
), Name_Access
,
13754 Name_Unrestricted_Access
)
13755 and then Is_Entity_Name
(Prefix
(N
))
13756 and then Is_Subprogram
(Entity
(Prefix
(N
)))
13758 Check_Elab_Call
(N
, Outer_Scope
);
13761 -- In SPARK mode, if we have an entity reference to a variable, then
13762 -- check it. For now we consider any reference.
13764 elsif SPARK_Mode
= On
13765 and then Nkind
(N
) in N_Has_Entity
13766 and then Present
(Entity
(N
))
13767 and then Ekind
(Entity
(N
)) = E_Variable
13769 Check_Elab_Call
(N
, Outer_Scope
);
13772 -- If we have a generic instantiation, check it
13774 elsif Nkind
(N
) in N_Generic_Instantiation
then
13775 Check_Elab_Instantiation
(N
, Outer_Scope
);
13778 -- Skip subprogram bodies that come from source (wait for call to
13779 -- analyze these). The reason for the come from source test is to
13780 -- avoid catching task bodies.
13782 -- For task bodies, we should really avoid these too, waiting for the
13783 -- task activation, but that's too much trouble to catch for now, so
13784 -- we go in unconditionally. This is not so terrible, it means the
13785 -- error backtrace is not quite complete, and we are too eager to
13786 -- scan bodies of tasks that are unused, but this is hardly very
13789 elsif Nkind
(N
) = N_Subprogram_Body
13790 and then Comes_From_Source
(N
)
13794 elsif Nkind
(N
) = N_Assignment_Statement
13795 and then Comes_From_Source
(N
)
13797 Check_Elab_Assign
(Name
(N
));
13803 end Find_Elab_Reference
;
13805 Inst_Case
: constant Boolean := Is_Generic_Unit
(E
);
13806 Loc
: constant Source_Ptr
:= Sloc
(N
);
13811 -- Start of processing for Check_Internal_Call_Continue
13814 -- Save outer level call if at outer level
13816 if Elab_Call
.Last
= 0 then
13817 Outer_Level_Sloc
:= Loc
;
13820 -- If the call is to a function that renames a literal, no check needed
13822 if Ekind
(E
) = E_Enumeration_Literal
then
13826 -- Register the subprogram as examined within this particular context.
13827 -- This ensures that calls to the same subprogram but in different
13828 -- contexts receive warnings and checks of their own since the calls
13829 -- may be reached through different flow paths.
13831 Elab_Visited
.Append
((Subp_Id
=> E
, Context
=> Parent
(N
)));
13833 Sbody
:= Unit_Declaration_Node
(E
);
13835 if not Nkind_In
(Sbody
, N_Subprogram_Body
, N_Package_Body
) then
13836 Ebody
:= Corresponding_Body
(Sbody
);
13841 Sbody
:= Unit_Declaration_Node
(Ebody
);
13845 -- If the body appears after the outer level call or instantiation then
13846 -- we have an error case handled below.
13848 if Earlier_In_Extended_Unit
(Outer_Level_Sloc
, Sloc
(Sbody
))
13849 and then not In_Task_Activation
13853 -- If we have the instantiation case we are done, since we now know that
13854 -- the body of the generic appeared earlier.
13856 elsif Inst_Case
then
13859 -- Otherwise we have a call, so we trace through the called body to see
13860 -- if it has any problems.
13863 pragma Assert
(Nkind
(Sbody
) = N_Subprogram_Body
);
13865 Elab_Call
.Append
((Cloc
=> Loc
, Ent
=> E
));
13867 if Debug_Flag_Underscore_LL
then
13868 Write_Str
("Elab_Call.Last = ");
13869 Write_Int
(Int
(Elab_Call
.Last
));
13870 Write_Str
(" Ent = ");
13871 Write_Name
(Chars
(E
));
13872 Write_Str
(" at ");
13873 Write_Location
(Sloc
(N
));
13877 -- Now traverse declarations and statements of subprogram body. Note
13878 -- that we cannot simply Traverse (Sbody), since traverse does not
13879 -- normally visit subprogram bodies.
13884 Decl
:= First
(Declarations
(Sbody
));
13885 while Present
(Decl
) loop
13891 Traverse
(Handled_Statement_Sequence
(Sbody
));
13893 Elab_Call
.Decrement_Last
;
13897 -- Here is the case of calling a subprogram where the body has not yet
13898 -- been encountered. A warning message is needed, except if this is the
13899 -- case of appearing within an aspect specification that results in
13900 -- a check call, we do not really have such a situation, so no warning
13901 -- is needed (e.g. the case of a precondition, where the call appears
13902 -- textually before the body, but in actual fact is moved to the
13903 -- appropriate subprogram body and so does not need a check).
13912 -- Keep looking at parents if we are still in the subexpression
13914 if Nkind
(P
) in N_Subexpr
then
13917 -- Here P is the parent of the expression, check for special case
13920 O
:= Original_Node
(P
);
13922 -- Definitely not the special case if orig node is not a pragma
13924 exit when Nkind
(O
) /= N_Pragma
;
13926 -- Check we have an If statement or a null statement (happens
13927 -- when the If has been expanded to be True).
13929 exit when not Nkind_In
(P
, N_If_Statement
, N_Null_Statement
);
13931 -- Our special case will be indicated either by the pragma
13932 -- coming from an aspect ...
13934 if Present
(Corresponding_Aspect
(O
)) then
13937 -- Or, in the case of an initial condition, specifically by a
13938 -- Check pragma specifying an Initial_Condition check.
13940 elsif Pragma_Name
(O
) = Name_Check
13943 (Expression
(First
(Pragma_Argument_Associations
(O
)))) =
13944 Name_Initial_Condition
13948 -- For anything else, we have an error
13957 -- Not that special case, warning and dynamic check is required
13959 -- If we have nothing in the call stack, then this is at the outer
13960 -- level, and the ABE is bound to occur, unless it's a 'Access, or
13961 -- it's a renaming.
13963 if Elab_Call
.Last
= 0 then
13964 Error_Msg_Warn
:= SPARK_Mode
/= On
;
13967 Insert_Check
: Boolean := True;
13968 -- This flag is set to True if an elaboration check should be
13972 if In_Task_Activation
then
13973 Insert_Check
:= False;
13975 elsif Inst_Case
then
13977 ("cannot instantiate& before body seen<<", N
, Orig_Ent
);
13979 elsif Nkind
(N
) = N_Attribute_Reference
then
13981 ("Access attribute of & before body seen<<", N
, Orig_Ent
);
13982 Error_Msg_N
("\possible Program_Error on later references<", N
);
13983 Insert_Check
:= False;
13985 elsif Nkind
(Unit_Declaration_Node
(Orig_Ent
)) /=
13986 N_Subprogram_Renaming_Declaration
13989 ("cannot call& before body seen<<", N
, Orig_Ent
);
13991 elsif not Is_Generic_Actual_Subprogram
(Orig_Ent
) then
13992 Insert_Check
:= False;
13995 if Insert_Check
then
13996 Error_Msg_N
("\Program_Error [<<", N
);
13997 Insert_Elab_Check
(N
);
14001 -- Call is not at outer level
14004 -- Do not generate elaboration checks in GNATprove mode because the
14005 -- elaboration counter and the check are both forms of expansion.
14007 if GNATprove_Mode
then
14010 -- Generate an elaboration check
14012 elsif not Elaboration_Checks_Suppressed
(E
) then
14013 Set_Elaboration_Entity_Required
(E
);
14015 -- Create a declaration of the elaboration entity, and insert it
14016 -- prior to the subprogram or the generic unit, within the same
14017 -- scope. Since the subprogram may be overloaded, create a unique
14020 if No
(Elaboration_Entity
(E
)) then
14022 Loce
: constant Source_Ptr
:= Sloc
(E
);
14023 Ent
: constant Entity_Id
:=
14024 Make_Defining_Identifier
(Loc
,
14025 New_External_Name
(Chars
(E
), 'E', -1));
14028 Set_Elaboration_Entity
(E
, Ent
);
14029 Push_Scope
(Scope
(E
));
14031 Insert_Action
(Declaration_Node
(E
),
14032 Make_Object_Declaration
(Loce
,
14033 Defining_Identifier
=> Ent
,
14034 Object_Definition
=>
14035 New_Occurrence_Of
(Standard_Short_Integer
, Loce
),
14037 Make_Integer_Literal
(Loc
, Uint_0
)));
14039 -- Set elaboration flag at the point of the body
14041 Set_Elaboration_Flag
(Sbody
, E
);
14043 -- Kill current value indication. This is necessary because
14044 -- the tests of this flag are inserted out of sequence and
14045 -- must not pick up bogus indications of the wrong constant
14046 -- value. Also, this is never a true constant, since one way
14047 -- or another, it gets reset.
14049 Set_Current_Value
(Ent
, Empty
);
14050 Set_Last_Assignment
(Ent
, Empty
);
14051 Set_Is_True_Constant
(Ent
, False);
14058 -- raise Program_Error with "access before elaboration";
14061 Insert_Elab_Check
(N
,
14062 Make_Attribute_Reference
(Loc
,
14063 Attribute_Name
=> Name_Elaborated
,
14064 Prefix
=> New_Occurrence_Of
(E
, Loc
)));
14067 -- Generate the warning
14069 if not Suppress_Elaboration_Warnings
(E
)
14070 and then not Elaboration_Checks_Suppressed
(E
)
14072 -- Suppress this warning if we have a function call that occurred
14073 -- within an assertion expression, since we can get false warnings
14074 -- in this case, due to the out of order handling in this case.
14077 (Nkind
(Original_Node
(N
)) /= N_Function_Call
14078 or else not In_Assertion_Expression_Pragma
(Original_Node
(N
)))
14080 Error_Msg_Warn
:= SPARK_Mode
/= On
;
14084 ("instantiation of& may occur before body is seen<l<",
14087 -- A rather specific check. For Finalize/Adjust/Initialize, if
14088 -- the type has Warnings_Off set, suppress the warning.
14090 if Nam_In
(Chars
(E
), Name_Adjust
,
14093 and then Present
(First_Formal
(E
))
14096 T
: constant Entity_Id
:= Etype
(First_Formal
(E
));
14098 if Is_Controlled
(T
) then
14099 if Warnings_Off
(T
)
14100 or else (Ekind
(T
) = E_Private_Type
14101 and then Warnings_Off
(Full_View
(T
)))
14109 -- Go ahead and give warning if not this special case
14112 ("call to& may occur before body is seen<l<", N
, Orig_Ent
);
14115 Error_Msg_N
("\Program_Error ]<l<", N
);
14117 -- There is no need to query the elaboration warning message flags
14118 -- because the main message is an error, not a warning, therefore
14119 -- all the clarification messages produces by Output_Calls must be
14120 -- emitted unconditionally.
14124 Output_Calls
(N
, Check_Elab_Flag
=> False);
14127 end Check_Internal_Call_Continue
;
14129 ---------------------------
14130 -- Check_Task_Activation --
14131 ---------------------------
14133 procedure Check_Task_Activation
(N
: Node_Id
) is
14134 Loc
: constant Source_Ptr
:= Sloc
(N
);
14135 Inter_Procs
: constant Elist_Id
:= New_Elmt_List
;
14136 Intra_Procs
: constant Elist_Id
:= New_Elmt_List
;
14139 Task_Scope
: Entity_Id
;
14140 Cunit_SC
: Boolean := False;
14143 Enclosing
: Entity_Id
;
14145 procedure Add_Task_Proc
(Typ
: Entity_Id
);
14146 -- Add to Task_Procs the task body procedure(s) of task types in Typ.
14147 -- For record types, this procedure recurses over component types.
14149 procedure Collect_Tasks
(Decls
: List_Id
);
14150 -- Collect the types of the tasks that are to be activated in the given
14151 -- list of declarations, in order to perform elaboration checks on the
14152 -- corresponding task procedures that are called implicitly here.
14154 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
;
14155 -- find enclosing compilation unit of Entity, ignoring subunits, or
14156 -- else enclosing subprogram. If E is not a package, there is no need
14157 -- for inter-unit elaboration checks.
14159 -------------------
14160 -- Add_Task_Proc --
14161 -------------------
14163 procedure Add_Task_Proc
(Typ
: Entity_Id
) is
14165 Proc
: Entity_Id
:= Empty
;
14168 if Is_Task_Type
(Typ
) then
14169 Proc
:= Get_Task_Body_Procedure
(Typ
);
14171 elsif Is_Array_Type
(Typ
)
14172 and then Has_Task
(Base_Type
(Typ
))
14174 Add_Task_Proc
(Component_Type
(Typ
));
14176 elsif Is_Record_Type
(Typ
)
14177 and then Has_Task
(Base_Type
(Typ
))
14179 Comp
:= First_Component
(Typ
);
14180 while Present
(Comp
) loop
14181 Add_Task_Proc
(Etype
(Comp
));
14182 Comp
:= Next_Component
(Comp
);
14186 -- If the task type is another unit, we will perform the usual
14187 -- elaboration check on its enclosing unit. If the type is in the
14188 -- same unit, we can trace the task body as for an internal call,
14189 -- but we only need to examine other external calls, because at
14190 -- the point the task is activated, internal subprogram bodies
14191 -- will have been elaborated already. We keep separate lists for
14192 -- each kind of task.
14194 -- Skip this test if errors have occurred, since in this case
14195 -- we can get false indications.
14197 if Serious_Errors_Detected
/= 0 then
14201 if Present
(Proc
) then
14202 if Outer_Unit
(Scope
(Proc
)) = Enclosing
then
14204 if No
(Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
14206 (not Is_Generic_Instance
(Scope
(Proc
))
14207 or else Scope
(Proc
) = Scope
(Defining_Identifier
(Decl
)))
14209 Error_Msg_Warn
:= SPARK_Mode
/= On
;
14211 ("task will be activated before elaboration of its body<<",
14213 Error_Msg_N
("\Program_Error [<<", Decl
);
14216 (Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
14218 Append_Elmt
(Proc
, Intra_Procs
);
14222 -- No need for multiple entries of the same type
14224 Elmt
:= First_Elmt
(Inter_Procs
);
14225 while Present
(Elmt
) loop
14226 if Node
(Elmt
) = Proc
then
14233 Append_Elmt
(Proc
, Inter_Procs
);
14238 -------------------
14239 -- Collect_Tasks --
14240 -------------------
14242 procedure Collect_Tasks
(Decls
: List_Id
) is
14244 if Present
(Decls
) then
14245 Decl
:= First
(Decls
);
14246 while Present
(Decl
) loop
14247 if Nkind
(Decl
) = N_Object_Declaration
14248 and then Has_Task
(Etype
(Defining_Identifier
(Decl
)))
14250 Add_Task_Proc
(Etype
(Defining_Identifier
(Decl
)));
14262 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
is
14267 while Present
(Outer
) loop
14268 if Elaboration_Checks_Suppressed
(Outer
) then
14272 exit when Is_Child_Unit
(Outer
)
14273 or else Scope
(Outer
) = Standard_Standard
14274 or else Ekind
(Outer
) /= E_Package
;
14275 Outer
:= Scope
(Outer
);
14281 -- Start of processing for Check_Task_Activation
14284 pragma Assert
(Legacy_Elaboration_Checks
);
14286 Enclosing
:= Outer_Unit
(Current_Scope
);
14288 -- Find all tasks declared in the current unit
14290 if Nkind
(N
) = N_Package_Body
then
14291 P
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
14293 Collect_Tasks
(Declarations
(N
));
14294 Collect_Tasks
(Visible_Declarations
(Specification
(P
)));
14295 Collect_Tasks
(Private_Declarations
(Specification
(P
)));
14297 elsif Nkind
(N
) = N_Package_Declaration
then
14298 Collect_Tasks
(Visible_Declarations
(Specification
(N
)));
14299 Collect_Tasks
(Private_Declarations
(Specification
(N
)));
14302 Collect_Tasks
(Declarations
(N
));
14305 -- We only perform detailed checks in all tasks that are library level
14306 -- entities. If the master is a subprogram or task, activation will
14307 -- depend on the activation of the master itself.
14309 -- Should dynamic checks be added in the more general case???
14311 if Ekind
(Enclosing
) /= E_Package
then
14315 -- For task types defined in other units, we want the unit containing
14316 -- the task body to be elaborated before the current one.
14318 Elmt
:= First_Elmt
(Inter_Procs
);
14319 while Present
(Elmt
) loop
14320 Ent
:= Node
(Elmt
);
14321 Task_Scope
:= Outer_Unit
(Scope
(Ent
));
14323 if not Is_Compilation_Unit
(Task_Scope
) then
14326 elsif Suppress_Elaboration_Warnings
(Task_Scope
)
14327 or else Elaboration_Checks_Suppressed
(Task_Scope
)
14331 elsif Dynamic_Elaboration_Checks
then
14332 if not Elaboration_Checks_Suppressed
(Ent
)
14333 and then not Cunit_SC
14334 and then not Restriction_Active
14335 (No_Entry_Calls_In_Elaboration_Code
)
14337 -- Runtime elaboration check required. Generate check of the
14338 -- elaboration counter for the unit containing the entity.
14340 Insert_Elab_Check
(N
,
14341 Make_Attribute_Reference
(Loc
,
14343 New_Occurrence_Of
(Spec_Entity
(Task_Scope
), Loc
),
14344 Attribute_Name
=> Name_Elaborated
));
14348 -- Force the binder to elaborate other unit first
14350 if Elab_Info_Messages
14351 and then not Suppress_Elaboration_Warnings
(Ent
)
14352 and then not Elaboration_Checks_Suppressed
(Ent
)
14353 and then not Suppress_Elaboration_Warnings
(Task_Scope
)
14354 and then not Elaboration_Checks_Suppressed
(Task_Scope
)
14356 Error_Msg_Node_2
:= Task_Scope
;
14358 ("info: activation of an instance of task type & requires "
14359 & "pragma Elaborate_All on &?$?", N
, Ent
);
14362 Activate_Elaborate_All_Desirable
(N
, Task_Scope
);
14363 Set_Suppress_Elaboration_Warnings
(Task_Scope
);
14369 -- For tasks declared in the current unit, trace other calls within the
14370 -- task procedure bodies, which are available.
14372 if not Debug_Flag_Dot_Y
then
14373 In_Task_Activation
:= True;
14375 Elmt
:= First_Elmt
(Intra_Procs
);
14376 while Present
(Elmt
) loop
14377 Ent
:= Node
(Elmt
);
14378 Check_Internal_Call_Continue
(N
, Ent
, Enclosing
, Ent
);
14382 In_Task_Activation
:= False;
14384 end Check_Task_Activation
;
14386 ------------------------
14387 -- Get_Referenced_Ent --
14388 ------------------------
14390 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
is
14394 if Nkind
(N
) in N_Has_Entity
14395 and then Present
(Entity
(N
))
14396 and then Ekind
(Entity
(N
)) = E_Variable
14401 if Nkind
(N
) = N_Attribute_Reference
then
14409 elsif Nkind
(Nam
) = N_Selected_Component
then
14410 return Entity
(Selector_Name
(Nam
));
14411 elsif not Is_Entity_Name
(Nam
) then
14414 return Entity
(Nam
);
14416 end Get_Referenced_Ent
;
14418 ----------------------
14419 -- Has_Generic_Body --
14420 ----------------------
14422 function Has_Generic_Body
(N
: Node_Id
) return Boolean is
14423 Ent
: constant Entity_Id
:= Get_Generic_Entity
(N
);
14424 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
14427 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
;
14428 -- Determine if the list of nodes headed by N and linked by Next
14429 -- contains a package body for the package spec entity E, and if so
14430 -- return the package body. If not, then returns Empty.
14432 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
;
14433 -- This procedure is called load the unit whose name is given by Nam.
14434 -- This unit is being loaded to see whether it contains an optional
14435 -- generic body. The returned value is the loaded unit, which is always
14436 -- a package body (only package bodies can contain other entities in the
14437 -- sense in which Has_Generic_Body is interested). We only attempt to
14438 -- load bodies if we are generating code. If we are in semantics check
14439 -- only mode, then it would be wrong to load bodies that are not
14440 -- required from a semantic point of view, so in this case we return
14441 -- Empty. The result is that the caller may incorrectly decide that a
14442 -- generic spec does not have a body when in fact it does, but the only
14443 -- harm in this is that some warnings on elaboration problems may be
14444 -- lost in semantic checks only mode, which is not big loss. We also
14445 -- return Empty if we go for a body and it is not there.
14447 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
;
14448 -- PE is the entity for a package spec. This function locates the
14449 -- corresponding package body, returning Empty if none is found. The
14450 -- package body returned is fully parsed but may not yet be analyzed,
14451 -- so only syntactic fields should be referenced.
14457 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
is
14462 while Present
(Nod
) loop
14464 -- If we found the package body we are looking for, return it
14466 if Nkind
(Nod
) = N_Package_Body
14467 and then Chars
(Defining_Unit_Name
(Nod
)) = Chars
(E
)
14471 -- If we found the stub for the body, go after the subunit,
14472 -- loading it if necessary.
14474 elsif Nkind
(Nod
) = N_Package_Body_Stub
14475 and then Chars
(Defining_Identifier
(Nod
)) = Chars
(E
)
14477 if Present
(Library_Unit
(Nod
)) then
14478 return Unit
(Library_Unit
(Nod
));
14481 return Load_Package_Body
(Get_Unit_Name
(Nod
));
14484 -- If neither package body nor stub, keep looking on chain
14494 -----------------------
14495 -- Load_Package_Body --
14496 -----------------------
14498 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
is
14499 U
: Unit_Number_Type
;
14502 if Operating_Mode
/= Generate_Code
then
14512 if U
= No_Unit
then
14515 return Unit
(Cunit
(U
));
14518 end Load_Package_Body
;
14520 -------------------------------
14521 -- Locate_Corresponding_Body --
14522 -------------------------------
14524 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
is
14525 Spec
: constant Node_Id
:= Declaration_Node
(PE
);
14526 Decl
: constant Node_Id
:= Parent
(Spec
);
14527 Scop
: constant Entity_Id
:= Scope
(PE
);
14531 if Is_Library_Level_Entity
(PE
) then
14533 -- If package is a library unit that requires a body, we have no
14534 -- choice but to go after that body because it might contain an
14535 -- optional body for the original generic package.
14537 if Unit_Requires_Body
(PE
) then
14539 -- Load the body. Note that we are a little careful here to use
14540 -- Spec to get the unit number, rather than PE or Decl, since
14541 -- in the case where the package is itself a library level
14542 -- instantiation, Spec will properly reference the generic
14543 -- template, which is what we really want.
14547 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec
))));
14549 -- But if the package is a library unit that does NOT require
14550 -- a body, then no body is permitted, so we are sure that there
14551 -- is no body for the original generic package.
14557 -- Otherwise look and see if we are embedded in a further package
14559 elsif Is_Package_Or_Generic_Package
(Scop
) then
14561 -- If so, get the body of the enclosing package, and look in
14562 -- its package body for the package body we are looking for.
14564 PBody
:= Locate_Corresponding_Body
(Scop
);
14569 return Find_Body_In
(PE
, First
(Declarations
(PBody
)));
14572 -- If we are not embedded in a further package, then the body
14573 -- must be in the same declarative part as we are.
14576 return Find_Body_In
(PE
, Next
(Decl
));
14578 end Locate_Corresponding_Body
;
14580 -- Start of processing for Has_Generic_Body
14583 if Present
(Corresponding_Body
(Decl
)) then
14586 elsif Unit_Requires_Body
(Ent
) then
14589 -- Compilation units cannot have optional bodies
14591 elsif Is_Compilation_Unit
(Ent
) then
14594 -- Otherwise look at what scope we are in
14597 Scop
:= Scope
(Ent
);
14599 -- Case of entity is in other than a package spec, in this case
14600 -- the body, if present, must be in the same declarative part.
14602 if not Is_Package_Or_Generic_Package
(Scop
) then
14607 -- Declaration node may get us a spec, so if so, go to
14608 -- the parent declaration.
14610 P
:= Declaration_Node
(Ent
);
14611 while not Is_List_Member
(P
) loop
14615 return Present
(Find_Body_In
(Ent
, Next
(P
)));
14618 -- If the entity is in a package spec, then we have to locate
14619 -- the corresponding package body, and look there.
14623 PBody
: constant Node_Id
:= Locate_Corresponding_Body
(Scop
);
14631 (Find_Body_In
(Ent
, (First
(Declarations
(PBody
)))));
14636 end Has_Generic_Body
;
14638 -----------------------
14639 -- Insert_Elab_Check --
14640 -----------------------
14642 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
) is
14644 Loc
: constant Source_Ptr
:= Sloc
(N
);
14647 -- The check (N_Raise_Program_Error) node to be inserted
14650 -- If expansion is disabled, do not generate any checks. Also
14651 -- skip checks if any subunits are missing because in either
14652 -- case we lack the full information that we need, and no object
14653 -- file will be created in any case.
14655 if not Expander_Active
or else Subunits_Missing
then
14659 -- If we have a generic instantiation, where Instance_Spec is set,
14660 -- then this field points to a generic instance spec that has
14661 -- been inserted before the instantiation node itself, so that
14662 -- is where we want to insert a check.
14664 if Nkind
(N
) in N_Generic_Instantiation
14665 and then Present
(Instance_Spec
(N
))
14667 Nod
:= Instance_Spec
(N
);
14672 -- Build check node, possibly with condition
14675 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Access_Before_Elaboration
);
14677 if Present
(C
) then
14678 Set_Condition
(Chk
, Make_Op_Not
(Loc
, Right_Opnd
=> C
));
14681 -- If we are inserting at the top level, insert in Aux_Decls
14683 if Nkind
(Parent
(Nod
)) = N_Compilation_Unit
then
14685 ADN
: constant Node_Id
:= Aux_Decls_Node
(Parent
(Nod
));
14688 if No
(Declarations
(ADN
)) then
14689 Set_Declarations
(ADN
, New_List
(Chk
));
14691 Append_To
(Declarations
(ADN
), Chk
);
14697 -- Otherwise just insert as an action on the node in question
14700 Insert_Action
(Nod
, Chk
);
14702 end Insert_Elab_Check
;
14704 -------------------------------
14705 -- Is_Call_Of_Generic_Formal --
14706 -------------------------------
14708 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean is
14710 return Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
)
14712 -- Always return False if debug flag -gnatd.G is set
14714 and then not Debug_Flag_Dot_GG
14716 -- For now, we detect this by looking for the strange identifier
14717 -- node, whose Chars reflect the name of the generic formal, but
14718 -- the Chars of the Entity references the generic actual.
14720 and then Nkind
(Name
(N
)) = N_Identifier
14721 and then Chars
(Name
(N
)) /= Chars
(Entity
(Name
(N
)));
14722 end Is_Call_Of_Generic_Formal
;
14724 -------------------------------
14725 -- Is_Finalization_Procedure --
14726 -------------------------------
14728 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean is
14730 -- Check whether Id is a procedure with at least one parameter
14732 if Ekind
(Id
) = E_Procedure
and then Present
(First_Formal
(Id
)) then
14734 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Id
));
14735 Deep_Fin
: Entity_Id
:= Empty
;
14736 Fin
: Entity_Id
:= Empty
;
14739 -- If the type of the first formal does not require finalization
14740 -- actions, then this is definitely not [Deep_]Finalize.
14742 if not Needs_Finalization
(Typ
) then
14746 -- At this point we have the following scenario:
14748 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
14750 -- Recover the two possible versions of [Deep_]Finalize using the
14751 -- type of the first parameter and compare with the input.
14753 Deep_Fin
:= TSS
(Typ
, TSS_Deep_Finalize
);
14755 if Is_Controlled
(Typ
) then
14756 Fin
:= Find_Prim_Op
(Typ
, Name_Finalize
);
14759 return (Present
(Deep_Fin
) and then Id
= Deep_Fin
)
14760 or else (Present
(Fin
) and then Id
= Fin
);
14765 end Is_Finalization_Procedure
;
14771 procedure Output_Calls
14773 Check_Elab_Flag
: Boolean)
14775 function Emit
(Flag
: Boolean) return Boolean;
14776 -- Determine whether to emit an error message based on the combination
14777 -- of flags Check_Elab_Flag and Flag.
14779 function Is_Printable_Error_Name
return Boolean;
14780 -- An internal function, used to determine if a name, stored in the
14781 -- Name_Buffer, is either a non-internal name, or is an internal name
14782 -- that is printable by the error message circuits (i.e. it has a single
14783 -- upper case letter at the end).
14789 function Emit
(Flag
: Boolean) return Boolean is
14791 if Check_Elab_Flag
then
14798 -----------------------------
14799 -- Is_Printable_Error_Name --
14800 -----------------------------
14802 function Is_Printable_Error_Name
return Boolean is
14804 if not Is_Internal_Name
then
14807 elsif Name_Len
= 1 then
14811 Name_Len
:= Name_Len
- 1;
14812 return not Is_Internal_Name
;
14814 end Is_Printable_Error_Name
;
14820 -- Start of processing for Output_Calls
14823 for J
in reverse 1 .. Elab_Call
.Last
loop
14824 Error_Msg_Sloc
:= Elab_Call
.Table
(J
).Cloc
;
14826 Ent
:= Elab_Call
.Table
(J
).Ent
;
14827 Get_Name_String
(Chars
(Ent
));
14829 -- Dynamic elaboration model, warnings controlled by -gnatwl
14831 if Dynamic_Elaboration_Checks
then
14832 if Emit
(Elab_Warnings
) then
14833 if Is_Generic_Unit
(Ent
) then
14834 Error_Msg_NE
("\\?l?& instantiated #", N
, Ent
);
14835 elsif Is_Init_Proc
(Ent
) then
14836 Error_Msg_N
("\\?l?initialization procedure called #", N
);
14837 elsif Is_Printable_Error_Name
then
14838 Error_Msg_NE
("\\?l?& called #", N
, Ent
);
14840 Error_Msg_N
("\\?l?called #", N
);
14844 -- Static elaboration model, info messages controlled by -gnatel
14847 if Emit
(Elab_Info_Messages
) then
14848 if Is_Generic_Unit
(Ent
) then
14849 Error_Msg_NE
("\\?$?& instantiated #", N
, Ent
);
14850 elsif Is_Init_Proc
(Ent
) then
14851 Error_Msg_N
("\\?$?initialization procedure called #", N
);
14852 elsif Is_Printable_Error_Name
then
14853 Error_Msg_NE
("\\?$?& called #", N
, Ent
);
14855 Error_Msg_N
("\\?$?called #", N
);
14862 ----------------------------
14863 -- Same_Elaboration_Scope --
14864 ----------------------------
14866 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean is
14871 -- Find elaboration scope for Scop1
14872 -- This is either a subprogram or a compilation unit.
14875 while S1
/= Standard_Standard
14876 and then not Is_Compilation_Unit
(S1
)
14877 and then Ekind_In
(S1
, E_Package
, E_Protected_Type
, E_Block
)
14882 -- Find elaboration scope for Scop2
14885 while S2
/= Standard_Standard
14886 and then not Is_Compilation_Unit
(S2
)
14887 and then Ekind_In
(S2
, E_Package
, E_Protected_Type
, E_Block
)
14893 end Same_Elaboration_Scope
;
14899 procedure Set_C_Scope
is
14901 while not Is_Compilation_Unit
(C_Scope
) loop
14902 C_Scope
:= Scope
(C_Scope
);
14906 --------------------------------
14907 -- Set_Elaboration_Constraint --
14908 --------------------------------
14910 procedure Set_Elaboration_Constraint
14915 Elab_Unit
: Entity_Id
;
14917 -- Check whether this is a call to an Initialize subprogram for a
14918 -- controlled type. Note that Call can also be a 'Access attribute
14919 -- reference, which now generates an elaboration check.
14921 Init_Call
: constant Boolean :=
14922 Nkind
(Call
) = N_Procedure_Call_Statement
14923 and then Chars
(Subp
) = Name_Initialize
14924 and then Comes_From_Source
(Subp
)
14925 and then Present
(Parameter_Associations
(Call
))
14926 and then Is_Controlled
(Etype
(First_Actual
(Call
)));
14929 -- If the unit is mentioned in a with_clause of the current unit, it is
14930 -- visible, and we can set the elaboration flag.
14932 if Is_Immediately_Visible
(Scop
)
14933 or else (Is_Child_Unit
(Scop
) and then Is_Visible_Lib_Unit
(Scop
))
14935 Activate_Elaborate_All_Desirable
(Call
, Scop
);
14936 Set_Suppress_Elaboration_Warnings
(Scop
);
14940 -- If this is not an initialization call or a call using object notation
14941 -- we know that the unit of the called entity is in the context, and we
14942 -- can set the flag as well. The unit need not be visible if the call
14943 -- occurs within an instantiation.
14945 if Is_Init_Proc
(Subp
)
14947 or else Nkind
(Original_Node
(Call
)) = N_Selected_Component
14949 null; -- detailed processing follows.
14952 Activate_Elaborate_All_Desirable
(Call
, Scop
);
14953 Set_Suppress_Elaboration_Warnings
(Scop
);
14957 -- If the unit is not in the context, there must be an intermediate unit
14958 -- that is, on which we need to place to elaboration flag. This happens
14959 -- with init proc calls.
14961 if Is_Init_Proc
(Subp
) or else Init_Call
then
14963 -- The initialization call is on an object whose type is not declared
14964 -- in the same scope as the subprogram. The type of the object must
14965 -- be a subtype of the type of operation. This object is the first
14966 -- actual in the call.
14969 Typ
: constant Entity_Id
:=
14970 Etype
(First
(Parameter_Associations
(Call
)));
14972 Elab_Unit
:= Scope
(Typ
);
14973 while (Present
(Elab_Unit
))
14974 and then not Is_Compilation_Unit
(Elab_Unit
)
14976 Elab_Unit
:= Scope
(Elab_Unit
);
14980 -- If original node uses selected component notation, the prefix is
14981 -- visible and determines the scope that must be elaborated. After
14982 -- rewriting, the prefix is the first actual in the call.
14984 elsif Nkind
(Original_Node
(Call
)) = N_Selected_Component
then
14985 Elab_Unit
:= Scope
(Etype
(First
(Parameter_Associations
(Call
))));
14987 -- Not one of special cases above
14990 -- Using previously computed scope. If the elaboration check is
14991 -- done after analysis, the scope is not visible any longer, but
14992 -- must still be in the context.
14997 Activate_Elaborate_All_Desirable
(Call
, Elab_Unit
);
14998 Set_Suppress_Elaboration_Warnings
(Elab_Unit
);
14999 end Set_Elaboration_Constraint
;
15005 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
is
15009 -- Check for case of body entity
15010 -- Why is the check for E_Void needed???
15012 if Ekind_In
(E
, E_Void
, E_Subprogram_Body
, E_Package_Body
) then
15016 Decl
:= Parent
(Decl
);
15017 exit when Nkind
(Decl
) in N_Proper_Body
;
15020 return Corresponding_Spec
(Decl
);
15031 function Within
(E1
, E2
: Entity_Id
) return Boolean is
15038 elsif Scop
= Standard_Standard
then
15041 Scop
:= Scope
(Scop
);
15046 --------------------------
15047 -- Within_Elaborate_All --
15048 --------------------------
15050 function Within_Elaborate_All
15051 (Unit
: Unit_Number_Type
;
15052 E
: Entity_Id
) return Boolean
15054 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
15055 pragma Pack
(Unit_Number_Set
);
15057 Seen
: Unit_Number_Set
:= (others => False);
15058 -- Seen (X) is True after we have seen unit X in the walk. This is used
15059 -- to prevent processing the same unit more than once.
15061 Result
: Boolean := False;
15063 procedure Helper
(Unit
: Unit_Number_Type
);
15064 -- This helper procedure does all the work for Within_Elaborate_All. It
15065 -- walks the dependency graph, and sets Result to True if it finds an
15066 -- appropriate Elaborate_All.
15072 procedure Helper
(Unit
: Unit_Number_Type
) is
15073 CU
: constant Node_Id
:= Cunit
(Unit
);
15077 Elab_Id
: Entity_Id
;
15081 if Seen
(Unit
) then
15084 Seen
(Unit
) := True;
15087 -- First, check for Elaborate_Alls on this unit
15089 Item
:= First
(Context_Items
(CU
));
15090 while Present
(Item
) loop
15091 if Nkind
(Item
) = N_Pragma
15092 and then Pragma_Name
(Item
) = Name_Elaborate_All
15094 -- Return if some previous error on the pragma itself. The
15095 -- pragma may be unanalyzed, because of a previous error, or
15096 -- if it is the context of a subunit, inherited by its parent.
15098 if Error_Posted
(Item
) or else not Analyzed
(Item
) then
15104 (Expression
(First
(Pragma_Argument_Associations
(Item
))));
15106 if E
= Elab_Id
then
15111 Par
:= Parent
(Unit_Declaration_Node
(Elab_Id
));
15113 Item2
:= First
(Context_Items
(Par
));
15114 while Present
(Item2
) loop
15115 if Nkind
(Item2
) = N_With_Clause
15116 and then Entity
(Name
(Item2
)) = E
15117 and then not Limited_Present
(Item2
)
15130 -- Second, recurse on with's. We could do this as part of the above
15131 -- loop, but it's probably more efficient to have two loops, because
15132 -- the relevant Elaborate_All is likely to be on the initial unit. In
15133 -- other words, we're walking the with's breadth-first. This part is
15134 -- only necessary in the dynamic elaboration model.
15136 if Dynamic_Elaboration_Checks
then
15137 Item
:= First
(Context_Items
(CU
));
15138 while Present
(Item
) loop
15139 if Nkind
(Item
) = N_With_Clause
15140 and then not Limited_Present
(Item
)
15142 -- Note: the following call to Get_Cunit_Unit_Number does a
15143 -- linear search, which could be slow, but it's OK because
15144 -- we're about to give a warning anyway. Also, there might
15145 -- be hundreds of units, but not millions. If it turns out
15146 -- to be a problem, we could store the Get_Cunit_Unit_Number
15147 -- in each N_Compilation_Unit node, but that would involve
15148 -- rearranging N_Compilation_Unit_Aux to make room.
15150 Helper
(Get_Cunit_Unit_Number
(Library_Unit
(Item
)));
15162 -- Start of processing for Within_Elaborate_All
15167 end Within_Elaborate_All
;