1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2017, 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.
379 -- The following switches may be used to control the behavior of the ABE
382 -- -gnatd_a stop elaboration checks on accept or select statement
384 -- The ABE mechanism stops the traversal of a task body when it
385 -- encounters an accept or a select statement. This behavior is
386 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code,
387 -- but without penalizing actual entry calls during elaboration.
389 -- -gnatd_e ignore entry calls and requeue statements for elaboration
391 -- The ABE mechanism does not generate N_Call_Marker nodes for
392 -- protected or task entry calls as well as requeue statements.
393 -- As a result, the calls and requeues are not recorded or
396 -- -gnatdE elaboration checks on predefined units
398 -- The ABE mechanism considers scenarios which appear in internal
399 -- units (Ada, GNAT, Interfaces, System).
401 -- -gnatd.G ignore calls through generic formal parameters for elaboration
403 -- The ABE mechanism does not generate N_Call_Marker nodes for
404 -- calls which occur in expanded instances, and invoke generic
405 -- actual subprograms through generic formal subprograms. As a
406 -- result, the calls are not recorded or processed.
408 -- -gnatd_i ignore activations and calls to instances for elaboration
410 -- The ABE mechanism ignores calls and task activations when they
411 -- target a subprogram or task type defined an external instance.
412 -- As a result, the calls and task activations are not processed.
414 -- -gnatdL ignore external calls from instances for elaboration
416 -- The ABE mechanism does not generate N_Call_Marker nodes for
417 -- calls which occur in expanded instances, do not invoke generic
418 -- actual subprograms through formal subprograms, and the target
419 -- is external to the instance. As a result, the calls are not
420 -- recorded or processed.
422 -- -gnatd.o conservative elaboration order for indirect calls
424 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
425 -- operator, or subprogram as an immediate invocation of the
426 -- target. As a result, it performs ABE checks and diagnostics on
427 -- the immediate call.
429 -- -gnatd_p ignore assertion pragmas for elaboration
431 -- The ABE mechanism does not generate N_Call_Marker nodes for
432 -- calls to subprograms which verify the run-time semantics of
433 -- the following assertion pragmas:
435 -- Default_Initial_Condition
443 -- Type_Invariant_Class
445 -- As a result, the assertion expressions of the pragmas are not
448 -- -gnatd.U ignore indirect calls for static elaboration
450 -- The ABE mechanism does not consider '[Unrestricted_]Access of
451 -- entries, operators, and subprograms. As a result, the scenarios
452 -- are not recorder or processed.
454 -- -gnatd.v enforce SPARK elaboration rules in SPARK code
456 -- The ABE mechanism applies some of the SPARK elaboration rules
457 -- defined in the SPARK reference manual, chapter 7.7. Note that
458 -- certain rules are always enforced, regardless of whether the
461 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies
463 -- The ABE mechanism does not generate implicit Elaborate_All when
464 -- the need for the pragma came from a task body.
466 -- -gnatE dynamic elaboration checking mode enabled
468 -- The ABE mechanism assumes that any scenario is elaborated or
469 -- invoked by elaboration code. The ABE mechanism performs very
470 -- little diagnostics and generates condintional ABE checks to
471 -- detect ABE issues at run-time.
473 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas
475 -- The ABE mechanism produces information messages on generated
476 -- implicit Elabote[_All] pragmas along with traceback showing
477 -- why the pragma was generated. In addition, the ABE mechanism
478 -- produces information messages for each scenario elaborated or
479 -- invoked by elaboration code.
481 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas
483 -- The complementary switch for -gnatel.
485 -- -gnatH legacy elaboration checking mode enabled
487 -- When this switch is in effect, the pre-18.x ABE model becomes
488 -- the defacto ABE model. This ammounts to cutting off all entry
489 -- points into the new ABE mechanism, and giving full control to
490 -- the old ABE mechanism.
492 -- -gnatJ permissive elaboration checking mode enabled
494 -- This switch activates the following switches:
505 -- IMPORTANT: The behavior of the ABE mechanism becomes more
506 -- permissive at the cost of accurate diagnostics and runtime
509 -- -gnatw.f turn on warnings for suspicious Subp'Access
511 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
512 -- operator, or subprogram as a pseudo invocation of the target.
513 -- As a result, it performs ABE diagnostics on the pseudo call.
515 -- -gnatw.F turn off warnings for suspicious Subp'Access
517 -- The complementary switch for -gnatw.f.
519 -- -gnatwl turn on warnings for elaboration problems
521 -- The ABE mechanism produces warnings on detected ABEs along with
522 -- a traceback showing the graph of the ABE.
524 -- -gnatwL turn off warnings for elaboration problems
526 -- The complementary switch for -gnatwl.
528 ---------------------------
529 -- Adding a new scenario --
530 ---------------------------
532 -- The following steps describe how to add a new elaboration scenario and
533 -- preserve the existing architecture. Note that not all of the steps may
534 -- need to be carried out.
536 -- 1) Update predicate Is_Scenario
538 -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate
539 -- Is_Suitable_Scenario.
541 -- 3) Update routine Record_Elaboration_Scenario
543 -- 4) Add routine Process_Conditional_ABE_xxx. Include a call to it in
544 -- routine Process_Conditional_ABE.
546 -- 5) Add routine Process_Guaranteed_ABE_xxx. Include a call to it in
547 -- routine Process_Guaranteed_ABE.
549 -- 6) Add routine Check_SPARK_xxx. Include a call to it in routine
550 -- Check_SPARK_Scenario.
552 -- 7) Add routine Info_xxx. Include a call to it in routine
553 -- Process_Conditional_ABE_xxx.
555 -- 8) Add routine Output_xxx. Include a call to it in routine
556 -- Output_Active_Scenarios.
558 -- 9) Add routine Extract_xxx_Attributes
560 -- 10) Update routine Is_Potential_Scenario
562 -------------------------
563 -- Adding a new target --
564 -------------------------
566 -- The following steps describe how to add a new elaboration target and
567 -- preserve the existing architecture. Note that not all of the steps may
568 -- need to be carried out.
570 -- 1) Add predicate Is_xxx.
572 -- 2) Update the following predicates
574 -- Is_Ada_Semantic_Target
575 -- Is_Assertion_Pragma_Target
577 -- Is_SPARK_Semantic_Target
579 -- If necessary, create a new category.
581 -- 3) Update the appropriate Info_xxx routine.
583 -- 4) Update the appropriate Output_xxx routine.
585 -- 5) Update routine Extract_Target_Attributes. If necessary, create a
586 -- new Extract_xxx routine.
588 --------------------------
589 -- Debugging ABE issues --
590 --------------------------
592 -- * If the issue involves a call, ensure that the call is eligible for ABE
593 -- processing and receives a corresponding call marker. The routines of
597 -- Record_Elaboration_Scenario
599 -- * If the issue involves an arbitrary scenario, ensure that the scenario
600 -- is either recorded, or is successfully recognized while traversing a
601 -- body. The routines of interest are
603 -- Record_Elaboration_Scenario
604 -- Process_Conditional_ABE
605 -- Process_Guaranteed_ABE
608 -- * If the issue involves a circularity in the elaboration order, examine
609 -- the ALI files and look for the following encodings next to units:
611 -- E indicates a source Elaborate
613 -- EA indicates a source Elaborate_All
615 -- AD indicates an implicit Elaborate_All
617 -- ED indicates an implicit Elaborate
619 -- If possible, compare these encodings with those generated by the old
620 -- ABE mechanism. The routines of interest are
622 -- Ensure_Prior_Elaboration
628 -- To minimize the amount of code within routines, the ABE mechanism relies
629 -- on "attribute" records to capture relevant information for a scenario or
632 -- The following type captures relevant attributes which pertain to a call
634 type Call_Attributes
is record
635 Elab_Checks_OK
: Boolean;
636 -- This flag is set when the call has elaboration checks enabled
638 Elab_Warnings_OK
: Boolean;
639 -- This flag is set when the call has elaboration warnings elabled
641 From_Source
: Boolean;
642 -- This flag is set when the call comes from source
644 Ghost_Mode_Ignore
: Boolean;
645 -- This flag is set when the call appears in a region subject to pragma
646 -- Ghost with policy Ignore.
648 In_Declarations
: Boolean;
649 -- This flag is set when the call appears at the declaration level
651 Is_Dispatching
: Boolean;
652 -- This flag is set when the call is dispatching
654 SPARK_Mode_On
: Boolean;
655 -- This flag is set when the call appears in a region subject to pragma
656 -- SPARK_Mode with value On.
659 -- The following type captures relevant attributes which pertain to the
660 -- prior elaboration of a unit. This type is coupled together with a unit
661 -- to form a key -> value relationship.
663 type Elaboration_Attributes
is record
664 Source_Pragma
: Node_Id
;
665 -- This attribute denotes a source Elaborate or Elaborate_All pragma
666 -- which guarantees the prior elaboration of some unit with respect
667 -- to the main unit. The pragma may come from the following contexts:
670 -- * The spec of the main unit (if applicable)
671 -- * Any parent spec of the main unit (if applicable)
672 -- * Any parent subunit of the main unit (if applicable)
674 -- The attribute remains Empty if no such pragma is available. Source
675 -- pragmas play a role in satisfying SPARK elaboration requirements.
677 With_Clause
: Node_Id
;
678 -- This attribute denotes an internally generated or source with clause
679 -- for some unit withed by the main unit. With clauses carry flags which
680 -- represent implicit Elaborate or Elaborate_All pragmas. These clauses
681 -- play a role in supplying the elaboration dependencies to binde.
684 No_Elaboration_Attributes
: constant Elaboration_Attributes
:=
685 (Source_Pragma
=> Empty
,
686 With_Clause
=> Empty
);
688 -- The following type captures relevant attributes which pertain to an
691 type Instantiation_Attributes
is record
692 Elab_Checks_OK
: Boolean;
693 -- This flag is set when the instantiation has elaboration checks
696 Elab_Warnings_OK
: Boolean;
697 -- This flag is set when the instantiation has elaboration warnings
700 Ghost_Mode_Ignore
: Boolean;
701 -- This flag is set when the instantiation appears in a region subject
702 -- to pragma Ghost with policy ignore, or starts one such region.
704 In_Declarations
: Boolean;
705 -- This flag is set when the instantiation appears at the declaration
708 SPARK_Mode_On
: Boolean;
709 -- This flag is set when the instantiation appears in a region subject
710 -- to pragma SPARK_Mode with value On, or starts one such region.
713 -- The following type captures relevant attributes which pertain to the
714 -- state of the Processing phase.
716 type Processing_Attributes
is record
717 Suppress_Implicit_Pragmas
: Boolean;
718 -- This flag is set when the Processing phase must not generate any
719 -- implicit Elaborate[_All] pragmas.
721 Within_Initial_Condition
: Boolean;
722 -- This flag is set when the Processing phase is currently examining a
723 -- scenario which was reached from an initial condition procedure.
725 Within_Instance
: Boolean;
726 -- This flag is set when the Processing phase is currently examining a
727 -- scenario which was reached from a scenario defined in an instance.
729 Within_Partial_Finalization
: Boolean;
730 -- This flag is set when the Processing phase is currently examining a
731 -- scenario which was reached from a partial finalization procedure.
733 Within_Task_Body
: Boolean;
734 -- This flag is set when the Processing phase is currently examining a
735 -- scenario which was reached from a task body.
738 Initial_State
: constant Processing_Attributes
:=
739 (Suppress_Implicit_Pragmas
=> False,
740 Within_Initial_Condition
=> False,
741 Within_Instance
=> False,
742 Within_Partial_Finalization
=> False,
743 Within_Task_Body
=> False);
745 -- The following type captures relevant attributes which pertain to a
748 type Target_Attributes
is record
749 Elab_Checks_OK
: Boolean;
750 -- This flag is set when the target has elaboration checks enabled
752 From_Source
: Boolean;
753 -- This flag is set when the target comes from source
755 Ghost_Mode_Ignore
: Boolean;
756 -- This flag is set when the target appears in a region subject to
757 -- pragma Ghost with policy ignore, or starts one such region.
759 SPARK_Mode_On
: Boolean;
760 -- This flag is set when the target appears in a region subject to
761 -- pragma SPARK_Mode with value On, or starts one such region.
764 -- This attribute denotes the declaration of Spec_Id
767 -- This attribute denotes the top unit where Spec_Id resides
769 -- The semantics of the following attributes depend on the target
775 -- The target is a generic package or a subprogram
777 -- * Body_Barf - Empty
779 -- * Body_Decl - This attribute denotes the generic or subprogram
782 -- * Spec_Id - This attribute denotes the entity of the generic
783 -- package or subprogram.
785 -- The target is a protected entry
787 -- * Body_Barf - This attribute denotes the body of the barrier
788 -- function if expansion took place, otherwise it is Empty.
790 -- * Body_Decl - This attribute denotes the body of the procedure
791 -- which emulates the entry if expansion took place, otherwise it
792 -- denotes the body of the protected entry.
794 -- * Spec_Id - This attribute denotes the entity of the procedure
795 -- which emulates the entry if expansion took place, otherwise it
796 -- denotes the protected entry.
798 -- The target is a protected subprogram
800 -- * Body_Barf - Empty
802 -- * Body_Decl - This attribute denotes the body of the protected or
803 -- unprotected version of the protected subprogram if expansion took
804 -- place, otherwise it denotes the body of the protected subprogram.
806 -- * Spec_Id - This attribute denotes the entity of the protected or
807 -- unprotected version of the protected subprogram if expansion took
808 -- place, otherwise it is the entity of the protected subprogram.
810 -- The target is a task entry
812 -- * Body_Barf - Empty
814 -- * Body_Decl - This attribute denotes the body of the procedure
815 -- which emulates the task body if expansion took place, otherwise
816 -- it denotes the body of the task type.
818 -- * Spec_Id - This attribute denotes the entity of the procedure
819 -- which emulates the task body if expansion took place, otherwise
820 -- it denotes the entity of the task type.
823 -- The following type captures relevant attributes which pertain to a task
826 type Task_Attributes
is record
828 -- This attribute denotes the declaration of the procedure body which
829 -- emulates the behaviour of the task body.
831 Elab_Checks_OK
: Boolean;
832 -- This flag is set when the task type has elaboration checks enabled
834 Ghost_Mode_Ignore
: Boolean;
835 -- This flag is set when the task type appears in a region subject to
836 -- pragma Ghost with policy ignore, or starts one such region.
838 SPARK_Mode_On
: Boolean;
839 -- This flag is set when the task type appears in a region subject to
840 -- pragma SPARK_Mode with value On, or starts one such region.
843 -- This attribute denotes the entity of the initial declaration of the
844 -- procedure body which emulates the behaviour of the task body.
847 -- This attribute denotes the declaration of the task type
850 -- This attribute denotes the entity of the compilation unit where the
851 -- task type resides.
854 -- The following type captures relevant attributes which pertain to a
857 type Variable_Attributes
is record
859 -- This attribute denotes the entity of the compilation unit where the
863 ---------------------
864 -- Data structures --
865 ---------------------
867 -- The ABE mechanism employs lists and hash tables to store information
868 -- pertaining to scenarios and targets, as well as the Processing phase.
869 -- The need for data structures comes partly from the size limitation of
870 -- nodes. Note that the use of hash tables is conservative and operations
871 -- are carried out only when a particular hash table has at least one key
872 -- value pair (see xxx_In_Use flags).
874 -- The following table stores the early call regions of subprogram bodies
876 Early_Call_Regions_Max
: constant := 101;
878 type Early_Call_Regions_Index
is range 0 .. Early_Call_Regions_Max
- 1;
880 function Early_Call_Regions_Hash
881 (Key
: Entity_Id
) return Early_Call_Regions_Index
;
882 -- Obtain the hash value of entity Key
884 Early_Call_Regions_In_Use
: Boolean := False;
885 -- This flag determines whether table Early_Call_Regions contains at least
886 -- least one key/value pair.
888 Early_Call_Regions_No_Element
: constant Node_Id
:= Empty
;
890 package Early_Call_Regions
is new Simple_HTable
891 (Header_Num
=> Early_Call_Regions_Index
,
893 No_Element
=> Early_Call_Regions_No_Element
,
895 Hash
=> Early_Call_Regions_Hash
,
898 -- The following table stores the elaboration status of all units withed by
901 Elaboration_Statuses_Max
: constant := 1009;
903 type Elaboration_Statuses_Index
is range 0 .. Elaboration_Statuses_Max
- 1;
905 function Elaboration_Statuses_Hash
906 (Key
: Entity_Id
) return Elaboration_Statuses_Index
;
907 -- Obtain the hash value of entity Key
909 Elaboration_Statuses_In_Use
: Boolean := False;
910 -- This flag flag determines whether table Elaboration_Statuses contains at
911 -- least one key/value pair.
913 Elaboration_Statuses_No_Element
: constant Elaboration_Attributes
:=
914 No_Elaboration_Attributes
;
916 package Elaboration_Statuses
is new Simple_HTable
917 (Header_Num
=> Elaboration_Statuses_Index
,
918 Element
=> Elaboration_Attributes
,
919 No_Element
=> Elaboration_Statuses_No_Element
,
921 Hash
=> Elaboration_Statuses_Hash
,
924 -- The following table stores a status flag for each SPARK scenario saved
925 -- in table SPARK_Scenarios.
927 Recorded_SPARK_Scenarios_Max
: constant := 127;
929 type Recorded_SPARK_Scenarios_Index
is
930 range 0 .. Recorded_SPARK_Scenarios_Max
- 1;
932 function Recorded_SPARK_Scenarios_Hash
933 (Key
: Node_Id
) return Recorded_SPARK_Scenarios_Index
;
934 -- Obtain the hash value of Key
936 Recorded_SPARK_Scenarios_In_Use
: Boolean := False;
937 -- This flag flag determines whether table Recorded_SPARK_Scenarios
938 -- contains at least one key/value pair.
940 Recorded_SPARK_Scenarios_No_Element
: constant Boolean := False;
942 package Recorded_SPARK_Scenarios
is new Simple_HTable
943 (Header_Num
=> Recorded_SPARK_Scenarios_Index
,
945 No_Element
=> Recorded_SPARK_Scenarios_No_Element
,
947 Hash
=> Recorded_SPARK_Scenarios_Hash
,
950 -- The following table stores a status flag for each top-level scenario
951 -- recorded in table Top_Level_Scenarios.
953 Recorded_Top_Level_Scenarios_Max
: constant := 503;
955 type Recorded_Top_Level_Scenarios_Index
is
956 range 0 .. Recorded_Top_Level_Scenarios_Max
- 1;
958 function Recorded_Top_Level_Scenarios_Hash
959 (Key
: Node_Id
) return Recorded_Top_Level_Scenarios_Index
;
960 -- Obtain the hash value of entity Key
962 Recorded_Top_Level_Scenarios_In_Use
: Boolean := False;
963 -- This flag flag determines whether table Recorded_Top_Level_Scenarios
964 -- contains at least one key/value pair.
966 Recorded_Top_Level_Scenarios_No_Element
: constant Boolean := False;
968 package Recorded_Top_Level_Scenarios
is new Simple_HTable
969 (Header_Num
=> Recorded_Top_Level_Scenarios_Index
,
971 No_Element
=> Recorded_Top_Level_Scenarios_No_Element
,
973 Hash
=> Recorded_Top_Level_Scenarios_Hash
,
976 -- The following table stores all active scenarios in a recursive traversal
977 -- starting from a top-level scenario. This table must be maintained in a
980 package Scenario_Stack
is new Table
.Table
981 (Table_Component_Type
=> Node_Id
,
982 Table_Index_Type
=> Int
,
983 Table_Low_Bound
=> 1,
985 Table_Increment
=> 100,
986 Table_Name
=> "Scenario_Stack");
988 -- The following table stores SPARK scenarios which are not necessarily
989 -- executable during elaboration, but still require elaboration-related
992 package SPARK_Scenarios
is new Table
.Table
993 (Table_Component_Type
=> Node_Id
,
994 Table_Index_Type
=> Int
,
995 Table_Low_Bound
=> 1,
997 Table_Increment
=> 100,
998 Table_Name
=> "SPARK_Scenarios");
1000 -- The following table stores all top-level scenario saved during the
1001 -- Recording phase. The contents of this table act as traversal roots
1002 -- later in the Processing phase. This table must be maintained in a
1005 package Top_Level_Scenarios
is new Table
.Table
1006 (Table_Component_Type
=> Node_Id
,
1007 Table_Index_Type
=> Int
,
1008 Table_Low_Bound
=> 1,
1009 Table_Initial
=> 1000,
1010 Table_Increment
=> 100,
1011 Table_Name
=> "Top_Level_Scenarios");
1013 -- The following table stores the bodies of all eligible scenarios visited
1014 -- during a traversal starting from a top-level scenario. The contents of
1015 -- this table must be reset upon each new traversal.
1017 Visited_Bodies_Max
: constant := 511;
1019 type Visited_Bodies_Index
is range 0 .. Visited_Bodies_Max
- 1;
1021 function Visited_Bodies_Hash
(Key
: Node_Id
) return Visited_Bodies_Index
;
1022 -- Obtain the hash value of node Key
1024 Visited_Bodies_In_Use
: Boolean := False;
1025 -- This flag determines whether table Visited_Bodies contains at least one
1028 Visited_Bodies_No_Element
: constant Boolean := False;
1030 package Visited_Bodies
is new Simple_HTable
1031 (Header_Num
=> Visited_Bodies_Index
,
1033 No_Element
=> Visited_Bodies_No_Element
,
1035 Hash
=> Visited_Bodies_Hash
,
1038 -----------------------
1039 -- Local subprograms --
1040 -----------------------
1042 -- Multiple local subprograms are utilized to lower the semantic complexity
1043 -- of the Recording and Processing phase.
1045 procedure Check_Preelaborated_Call
(Call
: Node_Id
);
1046 pragma Inline
(Check_Preelaborated_Call
);
1047 -- Verify that entry, operator, or subprogram call Call does not appear at
1048 -- the library level of a preelaborated unit.
1050 procedure Check_SPARK_Derived_Type
(Typ_Decl
: Node_Id
);
1051 pragma Inline
(Check_SPARK_Derived_Type
);
1052 -- Verify that the freeze node of a derived type denoted by declaration
1053 -- Typ_Decl is within the early call region of each overriding primitive
1054 -- body that belongs to the derived type (SPARK RM 7.7(8)).
1056 procedure Check_SPARK_Instantiation
(Exp_Inst
: Node_Id
);
1057 pragma Inline
(Check_SPARK_Instantiation
);
1058 -- Verify that expanded instance Exp_Inst does not precede the generic body
1059 -- it instantiates (SPARK RM 7.7(6)).
1061 procedure Check_SPARK_Model_In_Effect
(N
: Node_Id
);
1062 pragma Inline
(Check_SPARK_Model_In_Effect
);
1063 -- Determine whether a suitable elaboration model is currently in effect
1064 -- for verifying the SPARK rules of scenario N. Emit a warning if this is
1067 procedure Check_SPARK_Scenario
(N
: Node_Id
);
1068 pragma Inline
(Check_SPARK_Scenario
);
1069 -- Top-level dispatcher for verifying SPARK scenarios which are not always
1070 -- executable during elaboration but still need elaboration-related checks.
1072 procedure Check_SPARK_Refined_State_Pragma
(N
: Node_Id
);
1073 pragma Inline
(Check_SPARK_Refined_State_Pragma
);
1074 -- Verify that each constituent of Refined_State pragma N which belongs to
1075 -- an abstract state mentioned in pragma Initializes has prior elaboration
1076 -- with respect to the main unit (SPARK RM 7.7.1(7)).
1078 function Compilation_Unit
(Unit_Id
: Entity_Id
) return Node_Id
;
1079 pragma Inline
(Compilation_Unit
);
1080 -- Return the N_Compilation_Unit node of unit Unit_Id
1082 function Early_Call_Region
(Body_Id
: Entity_Id
) return Node_Id
;
1083 pragma Inline
(Early_Call_Region
);
1084 -- Return the early call region associated with entry or subprogram body
1085 -- Body_Id. IMPORTANT: This routine does not find the early call region.
1086 -- To compute it, use routine Find_Early_Call_Region.
1088 procedure Elab_Msg_NE
1093 In_SPARK
: Boolean);
1094 pragma Inline
(Elab_Msg_NE
);
1095 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node
1096 -- N and entity. If flag Info_Msg is set, the routine emits an information
1097 -- message, otherwise it emits an error. If flag In_SPARK is set, then
1098 -- string " in SPARK" is added to the end of the message.
1100 function Elaboration_Status
1101 (Unit_Id
: Entity_Id
) return Elaboration_Attributes
;
1102 pragma Inline
(Elaboration_Status
);
1103 -- Return the set of elaboration attributes associated with unit Unit_Id
1105 procedure Ensure_Prior_Elaboration
1107 Unit_Id
: Entity_Id
;
1109 State
: Processing_Attributes
);
1110 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
1111 -- by installing pragma Elaborate or Elaborate_All denoted by Prag_Nam. N
1112 -- denotes the related scenario. State denotes the current state of the
1113 -- Processing phase.
1115 procedure Ensure_Prior_Elaboration_Dynamic
1117 Unit_Id
: Entity_Id
;
1118 Prag_Nam
: Name_Id
);
1119 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
1120 -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes
1121 -- the related scenario.
1123 procedure Ensure_Prior_Elaboration_Static
1125 Unit_Id
: Entity_Id
;
1126 Prag_Nam
: Name_Id
);
1127 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
1128 -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N
1129 -- denotes the related scenario.
1131 function Extract_Assignment_Name
(Asmt
: Node_Id
) return Node_Id
;
1132 pragma Inline
(Extract_Assignment_Name
);
1133 -- Obtain the Name attribute of assignment statement Asmt
1135 procedure Extract_Call_Attributes
1137 Target_Id
: out Entity_Id
;
1138 Attrs
: out Call_Attributes
);
1139 pragma Inline
(Extract_Call_Attributes
);
1140 -- Obtain attributes Attrs associated with call Call. Target_Id is the
1141 -- entity of the call target.
1143 function Extract_Call_Name
(Call
: Node_Id
) return Node_Id
;
1144 pragma Inline
(Extract_Call_Name
);
1145 -- Obtain the Name attribute of entry or subprogram call Call
1147 procedure Extract_Instance_Attributes
1148 (Exp_Inst
: Node_Id
;
1149 Inst_Body
: out Node_Id
;
1150 Inst_Decl
: out Node_Id
);
1151 pragma Inline
(Extract_Instance_Attributes
);
1152 -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst
1154 procedure Extract_Instantiation_Attributes
1155 (Exp_Inst
: Node_Id
;
1157 Inst_Id
: out Entity_Id
;
1158 Gen_Id
: out Entity_Id
;
1159 Attrs
: out Instantiation_Attributes
);
1160 pragma Inline
(Extract_Instantiation_Attributes
);
1161 -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst.
1162 -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id
1163 -- is the entity of the generic unit being instantiated.
1165 procedure Extract_Target_Attributes
1166 (Target_Id
: Entity_Id
;
1167 Attrs
: out Target_Attributes
);
1168 -- Obtain attributes Attrs associated with an entry, package, or subprogram
1169 -- denoted by Target_Id.
1171 procedure Extract_Task_Attributes
1173 Attrs
: out Task_Attributes
);
1174 pragma Inline
(Extract_Task_Attributes
);
1175 -- Obtain attributes Attrs associated with task type Typ
1177 procedure Extract_Variable_Reference_Attributes
1179 Var_Id
: out Entity_Id
;
1180 Attrs
: out Variable_Attributes
);
1181 pragma Inline
(Extract_Variable_Reference_Attributes
);
1182 -- Obtain attributes Attrs associated with reference Ref that mentions
1185 function Find_Code_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
;
1186 pragma Inline
(Find_Code_Unit
);
1187 -- Return the code unit which contains arbitrary node or entity N. This
1188 -- is the unit of the file which physically contains the related construct
1189 -- denoted by N except when N is within an instantiation. In that case the
1190 -- unit is that of the top-level instantiation.
1192 function Find_Early_Call_Region
1193 (Body_Decl
: Node_Id
;
1194 Assume_Elab_Body
: Boolean := False;
1195 Skip_Memoization
: Boolean := False) return Node_Id
;
1196 -- Find the start of the early call region which belongs to subprogram body
1197 -- Body_Decl as defined in SPARK RM 7.7. The behavior of the routine is to
1198 -- find the early call region, memoize it, and return it, but this behavior
1199 -- can be altered. Flag Assume_Elab_Body should be set when a package spec
1200 -- may lack pragma Elaborate_Body, but the routine must still examine that
1201 -- spec. Flag Skip_Memoization should be set when the routine must avoid
1202 -- memoizing the region.
1204 procedure Find_Elaborated_Units
;
1205 -- Populate table Elaboration_Statuses with all units which have prior
1206 -- elaboration with respect to the main unit.
1208 function Find_Enclosing_Instance
(N
: Node_Id
) return Node_Id
;
1209 pragma Inline
(Find_Enclosing_Instance
);
1210 -- Find the declaration or body of the nearest expanded instance which
1211 -- encloses arbitrary node N. Return Empty if no such instance exists.
1213 function Find_Top_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
;
1214 pragma Inline
(Find_Top_Unit
);
1215 -- Return the top unit which contains arbitrary node or entity N. The unit
1216 -- is obtained by logically unwinding instantiations and subunits when N
1217 -- resides within one.
1219 function Find_Unit_Entity
(N
: Node_Id
) return Entity_Id
;
1220 pragma Inline
(Find_Unit_Entity
);
1221 -- Return the entity of unit N
1223 function First_Formal_Type
(Subp_Id
: Entity_Id
) return Entity_Id
;
1224 pragma Inline
(First_Formal_Type
);
1225 -- Return the type of subprogram Subp_Id's first formal parameter. If the
1226 -- subprogram lacks formal parameters, return Empty.
1228 function Has_Body
(Pack_Decl
: Node_Id
) return Boolean;
1229 -- Determine whether package declaration Pack_Decl has a corresponding body
1230 -- or would eventually have one.
1232 function Has_Prior_Elaboration
1233 (Unit_Id
: Entity_Id
;
1234 Context_OK
: Boolean := False;
1235 Elab_Body_OK
: Boolean := False;
1236 Same_Unit_OK
: Boolean := False) return Boolean;
1237 pragma Inline
(Has_Prior_Elaboration
);
1238 -- Determine whether unit Unit_Id is elaborated prior to the main unit.
1239 -- If flag Context_OK is set, the routine considers the following case
1240 -- as valid prior elaboration:
1242 -- * Unit_Id is in the elaboration context of the main unit
1244 -- If flag Elab_Body_OK is set, the routine considers the following case
1245 -- as valid prior elaboration:
1247 -- * Unit_Id has pragma Elaborate_Body and is not the main unit
1249 -- If flag Same_Unit_OK is set, the routine considers the following cases
1250 -- as valid prior elaboration:
1252 -- * Unit_Id is the main unit
1254 -- * Unit_Id denotes the spec of the main unit body
1256 function In_External_Instance
1258 Target_Decl
: Node_Id
) return Boolean;
1259 pragma Inline
(In_External_Instance
);
1260 -- Determine whether a target desctibed by its declaration Target_Decl
1261 -- resides in a package instance which is external to scenario N.
1263 function In_Main_Context
(N
: Node_Id
) return Boolean;
1264 pragma Inline
(In_Main_Context
);
1265 -- Determine whether arbitrary node N appears within the main compilation
1268 function In_Same_Context
1271 Nested_OK
: Boolean := False) return Boolean;
1272 -- Determine whether two arbitrary nodes N1 and N2 appear within the same
1273 -- context ignoring enclosing library levels. Nested_OK should be set when
1274 -- the context of N1 can enclose that of N2.
1278 Target_Id
: Entity_Id
;
1280 In_SPARK
: Boolean);
1281 -- Output information concerning call Call which invokes target Target_Id.
1282 -- If flag Info_Msg is set, the routine emits an information message,
1283 -- otherwise it emits an error. If flag In_SPARK is set, then the string
1284 -- " in SPARK" is added to the end of the message.
1286 procedure Info_Instantiation
1290 In_SPARK
: Boolean);
1291 pragma Inline
(Info_Instantiation
);
1292 -- Output information concerning instantiation Inst which instantiates
1293 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an
1294 -- information message, otherwise it emits an error. If flag In_SPARK
1295 -- is set, then string " in SPARK" is added to the end of the message.
1297 procedure Info_Variable_Reference
1301 In_SPARK
: Boolean);
1302 pragma Inline
(Info_Variable_Reference
);
1303 -- Output information concerning reference Ref which mentions variable
1304 -- Var_Id. If flag Info_Msg is set, the routine emits an information
1305 -- message, otherwise it emits an error. If flag In_SPARK is set, then
1306 -- string " in SPARK" is added to the end of the message.
1308 function Insertion_Node
(N
: Node_Id
; Ins_Nod
: Node_Id
) return Node_Id
;
1309 pragma Inline
(Insertion_Node
);
1310 -- Obtain the proper insertion node of an ABE check or failure for scenario
1311 -- N and candidate insertion node Ins_Nod.
1313 procedure Install_ABE_Check
1317 -- Insert a run-time ABE check for elaboration scenario N which verifies
1318 -- whether arbitrary entity Id is elaborated. The check in inserted prior
1321 procedure Install_ABE_Check
1323 Target_Id
: Entity_Id
;
1324 Target_Decl
: Node_Id
;
1325 Target_Body
: Node_Id
;
1327 -- Insert a run-time ABE check for elaboration scenario N which verifies
1328 -- whether target Target_Id with initial declaration Target_Decl and body
1329 -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod.
1331 procedure Install_ABE_Failure
(N
: Node_Id
; Ins_Nod
: Node_Id
);
1332 -- Insert a Program_Error concerning a guaranteed ABE for elaboration
1333 -- scenario N. The failure is inserted prior to node Node_Id.
1335 function Is_Accept_Alternative_Proc
(Id
: Entity_Id
) return Boolean;
1336 pragma Inline
(Is_Accept_Alternative_Proc
);
1337 -- Determine whether arbitrary entity Id denotes an internally generated
1338 -- procedure which encapsulates the statements of an accept alternative.
1340 function Is_Activation_Proc
(Id
: Entity_Id
) return Boolean;
1341 pragma Inline
(Is_Activation_Proc
);
1342 -- Determine whether arbitrary entity Id denotes a runtime procedure in
1343 -- charge with activating tasks.
1345 function Is_Ada_Semantic_Target
(Id
: Entity_Id
) return Boolean;
1346 pragma Inline
(Is_Ada_Semantic_Target
);
1347 -- Determine whether arbitrary entity Id denodes a source or internally
1348 -- generated subprogram which emulates Ada semantics.
1350 function Is_Assertion_Pragma_Target
(Id
: Entity_Id
) return Boolean;
1351 pragma Inline
(Is_Assertion_Pragma_Target
);
1352 -- Determine whether arbitrary entity Id denotes a procedure which varifies
1353 -- the run-time semantics of an assertion pragma.
1355 function Is_Bodiless_Subprogram
(Subp_Id
: Entity_Id
) return Boolean;
1356 pragma Inline
(Is_Bodiless_Subprogram
);
1357 -- Determine whether subprogram Subp_Id will never have a body
1359 function Is_Controlled_Proc
1360 (Subp_Id
: Entity_Id
;
1361 Subp_Nam
: Name_Id
) return Boolean;
1362 pragma Inline
(Is_Controlled_Proc
);
1363 -- Determine whether subprogram Subp_Id denotes controlled type primitives
1364 -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam.
1366 function Is_Default_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean;
1367 pragma Inline
(Is_Default_Initial_Condition_Proc
);
1368 -- Determine whether arbitrary entity Id denotes internally generated
1369 -- routine Default_Initial_Condition.
1371 function Is_Finalizer_Proc
(Id
: Entity_Id
) return Boolean;
1372 pragma Inline
(Is_Finalizer_Proc
);
1373 -- Determine whether arbitrary entity Id denotes internally generated
1374 -- routine _Finalizer.
1376 function Is_Guaranteed_ABE
1378 Target_Decl
: Node_Id
;
1379 Target_Body
: Node_Id
) return Boolean;
1380 pragma Inline
(Is_Guaranteed_ABE
);
1381 -- Determine whether scenario N with a target described by its initial
1382 -- declaration Target_Decl and body Target_Decl results in a guaranteed
1385 function Is_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean;
1386 pragma Inline
(Is_Initial_Condition_Proc
);
1387 -- Determine whether arbitrary entity Id denotes internally generated
1388 -- routine Initial_Condition.
1390 function Is_Initialized
(Obj_Decl
: Node_Id
) return Boolean;
1391 pragma Inline
(Is_Initialized
);
1392 -- Determine whether object declaration Obj_Decl is initialized
1394 function Is_Invariant_Proc
(Id
: Entity_Id
) return Boolean;
1395 pragma Inline
(Is_Invariant_Proc
);
1396 -- Determine whether arbitrary entity Id denotes an invariant procedure
1398 function Is_Non_Library_Level_Encapsulator
(N
: Node_Id
) return Boolean;
1399 pragma Inline
(Is_Non_Library_Level_Encapsulator
);
1400 -- Determine whether arbitrary node N is a non-library encapsulator
1402 function Is_Partial_Invariant_Proc
(Id
: Entity_Id
) return Boolean;
1403 pragma Inline
(Is_Partial_Invariant_Proc
);
1404 -- Determine whether arbitrary entity Id denotes a partial invariant
1407 function Is_Postconditions_Proc
(Id
: Entity_Id
) return Boolean;
1408 pragma Inline
(Is_Postconditions_Proc
);
1409 -- Determine whether arbitrary entity Id denotes internally generated
1410 -- routine _Postconditions.
1412 function Is_Preelaborated_Unit
(Id
: Entity_Id
) return Boolean;
1413 pragma Inline
(Is_Preelaborated_Unit
);
1414 -- Determine whether arbitrary entity Id denotes a unit which is subject to
1415 -- one of the following pragmas:
1419 -- * Remote_Call_Interface
1423 function Is_Protected_Entry
(Id
: Entity_Id
) return Boolean;
1424 pragma Inline
(Is_Protected_Entry
);
1425 -- Determine whether arbitrary entity Id denotes a protected entry
1427 function Is_Protected_Subp
(Id
: Entity_Id
) return Boolean;
1428 pragma Inline
(Is_Protected_Subp
);
1429 -- Determine whether entity Id denotes a protected subprogram
1431 function Is_Protected_Body_Subp
(Id
: Entity_Id
) return Boolean;
1432 pragma Inline
(Is_Protected_Body_Subp
);
1433 -- Determine whether entity Id denotes the protected or unprotected version
1434 -- of a protected subprogram.
1436 function Is_Recorded_SPARK_Scenario
(N
: Node_Id
) return Boolean;
1437 pragma Inline
(Is_Recorded_SPARK_Scenario
);
1438 -- Determine whether arbitrary node N is a recorded SPARK scenario which
1439 -- appears in table SPARK_Scenarios.
1441 function Is_Recorded_Top_Level_Scenario
(N
: Node_Id
) return Boolean;
1442 pragma Inline
(Is_Recorded_Top_Level_Scenario
);
1443 -- Determine whether arbitrary node N is a recorded top-level scenario
1444 -- which appears in table Top_Level_Scenarios.
1446 function Is_Safe_Activation
1448 Task_Decl
: Node_Id
) return Boolean;
1449 pragma Inline
(Is_Safe_Activation
);
1450 -- Determine whether call Call which activates a task object described by
1451 -- declaration Task_Decl is always ABE-safe.
1453 function Is_Safe_Call
1455 Target_Attrs
: Target_Attributes
) return Boolean;
1456 pragma Inline
(Is_Safe_Call
);
1457 -- Determine whether call Call which invokes a target described by
1458 -- attributes Target_Attrs is always ABE-safe.
1460 function Is_Safe_Instantiation
1462 Gen_Attrs
: Target_Attributes
) return Boolean;
1463 pragma Inline
(Is_Safe_Instantiation
);
1464 -- Determine whether instance Inst which instantiates a generic unit
1465 -- described by attributes Gen_Attrs is always ABE-safe.
1467 function Is_Same_Unit
1468 (Unit_1
: Entity_Id
;
1469 Unit_2
: Entity_Id
) return Boolean;
1470 pragma Inline
(Is_Same_Unit
);
1471 -- Determine whether entities Unit_1 and Unit_2 denote the same unit
1473 function Is_Scenario
(N
: Node_Id
) return Boolean;
1474 pragma Inline
(Is_Scenario
);
1475 -- Determine whether attribute node N denotes a scenario. The scenario may
1476 -- not necessarily be eligible for ABE processing.
1478 function Is_SPARK_Semantic_Target
(Id
: Entity_Id
) return Boolean;
1479 pragma Inline
(Is_SPARK_Semantic_Target
);
1480 -- Determine whether arbitrary entity Id nodes a source or internally
1481 -- generated subprogram which emulates SPARK semantics.
1483 function Is_Suitable_Access
(N
: Node_Id
) return Boolean;
1484 pragma Inline
(Is_Suitable_Access
);
1485 -- Determine whether arbitrary node N denotes a suitable attribute for ABE
1488 function Is_Suitable_Call
(N
: Node_Id
) return Boolean;
1489 pragma Inline
(Is_Suitable_Call
);
1490 -- Determine whether arbitrary node N denotes a suitable call for ABE
1493 function Is_Suitable_Instantiation
(N
: Node_Id
) return Boolean;
1494 pragma Inline
(Is_Suitable_Instantiation
);
1495 -- Determine whether arbitrary node N is a suitable instantiation for ABE
1498 function Is_Suitable_Scenario
(N
: Node_Id
) return Boolean;
1499 pragma Inline
(Is_Suitable_Scenario
);
1500 -- Determine whether arbitrary node N is a suitable scenario for ABE
1503 function Is_Suitable_SPARK_Derived_Type
(N
: Node_Id
) return Boolean;
1504 pragma Inline
(Is_Suitable_SPARK_Derived_Type
);
1505 -- Determine whether arbitrary node N denotes a suitable derived type
1506 -- declaration for ABE processing using the SPARK rules.
1508 function Is_Suitable_SPARK_Instantiation
(N
: Node_Id
) return Boolean;
1509 pragma Inline
(Is_Suitable_SPARK_Instantiation
);
1510 -- Determine whether arbitrary node N denotes a suitable instantiation for
1511 -- ABE processing using the SPARK rules.
1513 function Is_Suitable_SPARK_Refined_State_Pragma
1514 (N
: Node_Id
) return Boolean;
1515 pragma Inline
(Is_Suitable_SPARK_Refined_State_Pragma
);
1516 -- Determine whether arbitrary node N denotes a suitable Refined_State
1517 -- pragma for ABE processing using the SPARK rules.
1519 function Is_Suitable_Variable_Assignment
(N
: Node_Id
) return Boolean;
1520 pragma Inline
(Is_Suitable_Variable_Assignment
);
1521 -- Determine whether arbitrary node N denotes a suitable assignment for ABE
1524 function Is_Suitable_Variable_Reference
(N
: Node_Id
) return Boolean;
1525 pragma Inline
(Is_Suitable_Variable_Reference
);
1526 -- Determine whether arbitrary node N is a suitable variable reference for
1529 function Is_Task_Entry
(Id
: Entity_Id
) return Boolean;
1530 pragma Inline
(Is_Task_Entry
);
1531 -- Determine whether arbitrary entity Id denotes a task entry
1533 function Is_Up_Level_Target
(Target_Decl
: Node_Id
) return Boolean;
1534 pragma Inline
(Is_Up_Level_Target
);
1535 -- Determine whether the current root resides at the declaration level. If
1536 -- this is the case, determine whether a target described by declaration
1537 -- Target_Decl is within a context which encloses the current root or is in
1538 -- a different unit.
1540 function Is_Visited_Body
(Body_Decl
: Node_Id
) return Boolean;
1541 pragma Inline
(Is_Visited_Body
);
1542 -- Determine whether subprogram body Body_Decl is already visited during a
1543 -- recursive traversal started from a top-level scenario.
1545 procedure Meet_Elaboration_Requirement
1547 Target_Id
: Entity_Id
;
1549 -- Determine whether elaboration requirement Req_Nam for scenario N with
1550 -- target Target_Id is met by the context of the main unit using the SPARK
1551 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an
1552 -- error if this is not the case.
1554 function Non_Private_View
(Typ
: Entity_Id
) return Entity_Id
;
1555 pragma Inline
(Non_Private_View
);
1556 -- Return the full view of private type Typ if available, otherwise return
1559 procedure Output_Active_Scenarios
(Error_Nod
: Node_Id
);
1560 -- Output the contents of the active scenario stack from earliest to latest
1561 -- to supplement an earlier error emitted for node Error_Nod.
1563 procedure Pop_Active_Scenario
(N
: Node_Id
);
1564 pragma Inline
(Pop_Active_Scenario
);
1565 -- Pop the top of the scenario stack. A check is made to ensure that the
1566 -- scenario being removed is the same as N.
1569 with procedure Process_Single_Activation
1571 Call_Attrs
: Call_Attributes
;
1573 Task_Attrs
: Task_Attributes
;
1574 State
: Processing_Attributes
);
1575 -- Perform ABE checks and diagnostics for task activation call Call
1576 -- which activates task Obj_Id. Call_Attrs are the attributes of the
1577 -- activation call. Task_Attrs are the attributes of the task type.
1578 -- State is the current state of the Processing phase.
1580 procedure Process_Activation_Generic
1582 Call_Attrs
: Call_Attributes
;
1583 State
: Processing_Attributes
);
1584 -- Perform ABE checks and diagnostics for activation call Call by invoking
1585 -- routine Process_Single_Activation on each task object being activated.
1586 -- Call_Attrs are the attributes of the activation call. State is the
1587 -- current state of the Processing phase.
1589 procedure Process_Conditional_ABE
1591 State
: Processing_Attributes
:= Initial_State
);
1592 -- Top-level dispatcher for processing of various elaboration scenarios.
1593 -- Perform conditional ABE checks and diagnostics for scenario N. State
1594 -- is the current state of the Processing phase.
1596 procedure Process_Conditional_ABE_Access
1598 State
: Processing_Attributes
);
1599 -- Perform ABE checks and diagnostics for 'Access to entry, operator, or
1600 -- subprogram denoted by Attr. State is the current state of the Processing
1603 procedure Process_Conditional_ABE_Activation_Impl
1605 Call_Attrs
: Call_Attributes
;
1607 Task_Attrs
: Task_Attributes
;
1608 State
: Processing_Attributes
);
1609 -- Perform common conditional ABE checks and diagnostics for call Call
1610 -- which activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs
1611 -- are the attributes of the activation call. Task_Attrs are the attributes
1612 -- of the task type. State is the current state of the Processing phase.
1614 procedure Process_Conditional_ABE_Call
1616 Call_Attrs
: Call_Attributes
;
1617 Target_Id
: Entity_Id
;
1618 State
: Processing_Attributes
);
1619 -- Top-level dispatcher for processing of calls. Perform ABE checks and
1620 -- diagnostics for call Call which invokes target Target_Id. Call_Attrs
1621 -- are the attributes of the call. State is the current state of the
1622 -- Processing phase.
1624 procedure Process_Conditional_ABE_Call_Ada
1626 Call_Attrs
: Call_Attributes
;
1627 Target_Id
: Entity_Id
;
1628 Target_Attrs
: Target_Attributes
;
1629 State
: Processing_Attributes
);
1630 -- Perform ABE checks and diagnostics for call Call which invokes target
1631 -- Target_Id using the Ada rules. Call_Attrs are the attributes of the
1632 -- call. Target_Attrs are attributes of the target. State is the current
1633 -- state of the Processing phase.
1635 procedure Process_Conditional_ABE_Call_SPARK
1637 Target_Id
: Entity_Id
;
1638 Target_Attrs
: Target_Attributes
;
1639 State
: Processing_Attributes
);
1640 -- Perform ABE checks and diagnostics for call Call which invokes target
1641 -- Target_Id using the SPARK rules. Target_Attrs denotes the attributes of
1642 -- the target. State is the current state of the Processing phase.
1644 procedure Process_Conditional_ABE_Instantiation
1645 (Exp_Inst
: Node_Id
;
1646 State
: Processing_Attributes
);
1647 -- Top-level dispatcher for processing of instantiations. Perform ABE
1648 -- checks and diagnostics for expanded instantiation Exp_Inst. State is
1649 -- the current state of the Processing phase.
1651 procedure Process_Conditional_ABE_Instantiation_Ada
1652 (Exp_Inst
: Node_Id
;
1654 Inst_Attrs
: Instantiation_Attributes
;
1656 Gen_Attrs
: Target_Attributes
;
1657 State
: Processing_Attributes
);
1658 -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst
1659 -- of generic Gen_Id using the Ada rules. Inst is the instantiation node.
1660 -- Inst_Attrs are the attributes of the instance. Gen_Attrs denotes the
1661 -- attributes of the generic. State is the current state of the Processing
1664 procedure Process_Conditional_ABE_Instantiation_SPARK
1667 Gen_Attrs
: Target_Attributes
;
1668 State
: Processing_Attributes
);
1669 -- Perform ABE checks and diagnostics for instantiation Inst of generic
1670 -- Gen_Id using the SPARK rules. Gen_Attrs denotes the attributes of the
1671 -- generic. State is the current state of the Processing phase.
1673 procedure Process_Conditional_ABE_Variable_Assignment
(Asmt
: Node_Id
);
1674 -- Top-level dispatcher for processing of variable assignments. Perform ABE
1675 -- checks and diagnostics for assignment statement Asmt.
1677 procedure Process_Conditional_ABE_Variable_Assignment_Ada
1679 Var_Id
: Entity_Id
);
1680 -- Perform ABE checks and diagnostics for assignment statement Asmt that
1681 -- updates the value of variable Var_Id using the Ada rules.
1683 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
1685 Var_Id
: Entity_Id
);
1686 -- Perform ABE checks and diagnostics for assignment statement Asmt that
1687 -- updates the value of variable Var_Id using the SPARK rules.
1689 procedure Process_Conditional_ABE_Variable_Reference
(Ref
: Node_Id
);
1690 -- Top-level dispatcher for processing of variable references. Perform ABE
1691 -- checks and diagnostics for variable reference Ref.
1693 procedure Process_Conditional_ABE_Variable_Reference_Read
1696 Attrs
: Variable_Attributes
);
1697 -- Perform ABE checks and diagnostics for reference Ref described by its
1698 -- attributes Attrs, that reads variable Var_Id.
1700 procedure Process_Guaranteed_ABE
(N
: Node_Id
);
1701 -- Top-level dispatcher for processing of scenarios which result in a
1704 procedure Process_Guaranteed_ABE_Activation_Impl
1706 Call_Attrs
: Call_Attributes
;
1708 Task_Attrs
: Task_Attributes
;
1709 State
: Processing_Attributes
);
1710 -- Perform common guaranteed ABE checks and diagnostics for call Call which
1711 -- activates task Obj_Id ignoring the Ada or SPARK rules. Call_Attrs are
1712 -- the attributes of the activation call. Task_Attrs are the attributes of
1713 -- the task type. State is provided for compatibility and is not used.
1715 procedure Process_Guaranteed_ABE_Call
1717 Call_Attrs
: Call_Attributes
;
1718 Target_Id
: Entity_Id
);
1719 -- Perform common guaranteed ABE checks and diagnostics for call Call which
1720 -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are
1721 -- the attributes of the call.
1723 procedure Process_Guaranteed_ABE_Instantiation
(Exp_Inst
: Node_Id
);
1724 -- Perform common guaranteed ABE checks and diagnostics for expanded
1725 -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK
1728 procedure Push_Active_Scenario
(N
: Node_Id
);
1729 pragma Inline
(Push_Active_Scenario
);
1730 -- Push scenario N on top of the scenario stack
1732 procedure Record_SPARK_Elaboration_Scenario
(N
: Node_Id
);
1733 pragma Inline
(Record_SPARK_Elaboration_Scenario
);
1734 -- Save SPARK scenario N in table SPARK_Scenarios for later processing
1736 procedure Reset_Visited_Bodies
;
1737 pragma Inline
(Reset_Visited_Bodies
);
1738 -- Clear the contents of table Visited_Bodies
1740 function Root_Scenario
return Node_Id
;
1741 pragma Inline
(Root_Scenario
);
1742 -- Return the top-level scenario which started a recursive search for other
1743 -- scenarios. It is assumed that there is a valid top-level scenario on the
1744 -- active scenario stack.
1746 procedure Set_Early_Call_Region
(Body_Id
: Entity_Id
; Start
: Node_Id
);
1747 pragma Inline
(Set_Early_Call_Region
);
1748 -- Associate an early call region with begins at construct Start with entry
1749 -- or subprogram body Body_Id.
1751 procedure Set_Elaboration_Status
1752 (Unit_Id
: Entity_Id
;
1753 Val
: Elaboration_Attributes
);
1754 pragma Inline
(Set_Elaboration_Status
);
1755 -- Associate an set of elaboration attributes with unit Unit_Id
1757 procedure Set_Is_Recorded_SPARK_Scenario
1759 Val
: Boolean := True);
1760 pragma Inline
(Set_Is_Recorded_SPARK_Scenario
);
1761 -- Mark scenario N as being recorded in table SPARK_Scenarios
1763 procedure Set_Is_Recorded_Top_Level_Scenario
1765 Val
: Boolean := True);
1766 pragma Inline
(Set_Is_Recorded_Top_Level_Scenario
);
1767 -- Mark scenario N as being recorded in table Top_Level_Scenarios
1769 procedure Set_Is_Visited_Body
(Subp_Body
: Node_Id
);
1770 pragma Inline
(Set_Is_Visited_Body
);
1771 -- Mark subprogram body Subp_Body as being visited during a recursive
1772 -- traversal started from a top-level scenario.
1774 function Static_Elaboration_Checks
return Boolean;
1775 pragma Inline
(Static_Elaboration_Checks
);
1776 -- Determine whether the static model is in effect
1778 procedure Traverse_Body
(N
: Node_Id
; State
: Processing_Attributes
);
1779 -- Inspect the declarative and statement lists of subprogram body N for
1780 -- suitable elaboration scenarios and process them. State is the current
1781 -- state of the Processing phase.
1783 procedure Update_Elaboration_Scenario
(New_N
: Node_Id
; Old_N
: Node_Id
);
1784 pragma Inline
(Update_Elaboration_Scenario
);
1785 -- Update all relevant internal data structures when scenario Old_N is
1786 -- transformed into scenario New_N by Atree.Rewrite.
1788 -----------------------
1789 -- Build_Call_Marker --
1790 -----------------------
1792 procedure Build_Call_Marker
(N
: Node_Id
) is
1793 function In_External_Context
1795 Target_Attrs
: Target_Attributes
) return Boolean;
1796 pragma Inline
(In_External_Context
);
1797 -- Determine whether a target described by attributes Target_Attrs is
1798 -- external to call Call which must reside within an instance.
1800 function In_Premature_Context
(Call
: Node_Id
) return Boolean;
1801 -- Determine whether call Call appears within a premature context
1803 function Is_Bridge_Target
(Id
: Entity_Id
) return Boolean;
1804 pragma Inline
(Is_Bridge_Target
);
1805 -- Determine whether arbitrary entity Id denotes a bridge target
1807 function Is_Default_Expression
(Call
: Node_Id
) return Boolean;
1808 pragma Inline
(Is_Default_Expression
);
1809 -- Determine whether call Call acts as the expression of a defaulted
1810 -- parameter within a source call.
1812 function Is_Generic_Formal_Subp
(Subp_Id
: Entity_Id
) return Boolean;
1813 pragma Inline
(Is_Generic_Formal_Subp
);
1814 -- Determine whether subprogram Subp_Id denotes a generic formal
1815 -- subprogram which appears in the "prologue" of an instantiation.
1817 -------------------------
1818 -- In_External_Context --
1819 -------------------------
1821 function In_External_Context
1823 Target_Attrs
: Target_Attributes
) return Boolean
1826 Inst_Body
: Node_Id
;
1827 Inst_Decl
: Node_Id
;
1830 -- Performance note: parent traversal
1832 Inst
:= Find_Enclosing_Instance
(Call
);
1834 -- The call appears within an instance
1836 if Present
(Inst
) then
1838 -- The call comes from the main unit and the target does not
1840 if In_Extended_Main_Code_Unit
(Call
)
1841 and then not In_Extended_Main_Code_Unit
(Target_Attrs
.Spec_Decl
)
1845 -- Otherwise the target declaration must not appear within the
1846 -- instance spec or body.
1849 Extract_Instance_Attributes
1851 Inst_Decl
=> Inst_Decl
,
1852 Inst_Body
=> Inst_Body
);
1854 -- Performance note: parent traversal
1856 return not In_Subtree
1857 (N
=> Target_Attrs
.Spec_Decl
,
1859 Root2
=> Inst_Body
);
1864 end In_External_Context
;
1866 --------------------------
1867 -- In_Premature_Context --
1868 --------------------------
1870 function In_Premature_Context
(Call
: Node_Id
) return Boolean is
1874 -- Climb the parent chain looking for premature contexts
1876 Par
:= Parent
(Call
);
1877 while Present
(Par
) loop
1879 -- Aspect specifications and generic associations are premature
1880 -- contexts because nested calls has not been relocated to their
1883 if Nkind_In
(Par
, N_Aspect_Specification
,
1884 N_Generic_Association
)
1888 -- Prevent the search from going too far
1890 elsif Is_Body_Or_Package_Declaration
(Par
) then
1894 Par
:= Parent
(Par
);
1898 end In_Premature_Context
;
1900 ----------------------
1901 -- Is_Bridge_Target --
1902 ----------------------
1904 function Is_Bridge_Target
(Id
: Entity_Id
) return Boolean is
1907 Is_Accept_Alternative_Proc
(Id
)
1908 or else Is_Finalizer_Proc
(Id
)
1909 or else Is_Partial_Invariant_Proc
(Id
)
1910 or else Is_Postconditions_Proc
(Id
)
1911 or else Is_TSS
(Id
, TSS_Deep_Adjust
)
1912 or else Is_TSS
(Id
, TSS_Deep_Finalize
)
1913 or else Is_TSS
(Id
, TSS_Deep_Initialize
);
1914 end Is_Bridge_Target
;
1916 ---------------------------
1917 -- Is_Default_Expression --
1918 ---------------------------
1920 function Is_Default_Expression
(Call
: Node_Id
) return Boolean is
1921 Outer_Call
: constant Node_Id
:= Parent
(Call
);
1922 Outer_Nam
: Node_Id
;
1925 -- To qualify, the node must appear immediately within a source call
1926 -- which invokes a source target.
1928 if Nkind_In
(Outer_Call
, N_Entry_Call_Statement
,
1930 N_Procedure_Call_Statement
)
1931 and then Comes_From_Source
(Outer_Call
)
1933 Outer_Nam
:= Extract_Call_Name
(Outer_Call
);
1936 Is_Entity_Name
(Outer_Nam
)
1937 and then Present
(Entity
(Outer_Nam
))
1938 and then Is_Subprogram_Or_Entry
(Entity
(Outer_Nam
))
1939 and then Comes_From_Source
(Entity
(Outer_Nam
));
1943 end Is_Default_Expression
;
1945 ----------------------------
1946 -- Is_Generic_Formal_Subp --
1947 ----------------------------
1949 function Is_Generic_Formal_Subp
(Subp_Id
: Entity_Id
) return Boolean is
1950 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
1951 Context
: constant Node_Id
:= Parent
(Subp_Decl
);
1954 -- To qualify, the subprogram must rename a generic actual subprogram
1955 -- where the enclosing context is an instantiation.
1958 Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
1959 and then not Comes_From_Source
(Subp_Decl
)
1960 and then Nkind_In
(Context
, N_Function_Specification
,
1961 N_Package_Specification
,
1962 N_Procedure_Specification
)
1963 and then Present
(Generic_Parent
(Context
));
1964 end Is_Generic_Formal_Subp
;
1968 Call_Attrs
: Call_Attributes
;
1971 Target_Attrs
: Target_Attributes
;
1972 Target_Id
: Entity_Id
;
1974 -- Start of processing for Build_Call_Marker
1977 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
1978 -- enabled) is in effect because the legacy ABE mechanism does not need
1979 -- to carry out this action.
1981 if Legacy_Elaboration_Checks
then
1984 -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are
1985 -- not performed in this mode.
1987 elsif ASIS_Mode
then
1990 -- Nothing to do when the call is being preanalyzed as the marker will
1991 -- be inserted in the wrong place.
1993 elsif Preanalysis_Active
then
1996 -- Nothing to do when the input does not denote a call or a requeue
1998 elsif not Nkind_In
(N
, N_Entry_Call_Statement
,
2000 N_Procedure_Call_Statement
,
2001 N_Requeue_Statement
)
2005 -- Nothing to do when the input denotes entry call or requeue statement,
2006 -- and switch -gnatd_e (ignore entry calls and requeue statements for
2007 -- elaboration) is in effect.
2009 elsif Debug_Flag_Underscore_E
2010 and then Nkind_In
(N
, N_Entry_Call_Statement
, N_Requeue_Statement
)
2015 Call_Nam
:= Extract_Call_Name
(N
);
2017 -- Nothing to do when the call is erroneous or left in a bad state
2019 if not (Is_Entity_Name
(Call_Nam
)
2020 and then Present
(Entity
(Call_Nam
))
2021 and then Is_Subprogram_Or_Entry
(Entity
(Call_Nam
)))
2025 -- Nothing to do when the call invokes a generic formal subprogram and
2026 -- switch -gnatd.G (ignore calls through generic formal parameters for
2027 -- elaboration) is in effect. This check must be performed with the
2028 -- direct target of the call to avoid the side effects of mapping
2029 -- actuals to formals using renamings.
2031 elsif Debug_Flag_Dot_GG
2032 and then Is_Generic_Formal_Subp
(Entity
(Call_Nam
))
2036 -- Nothing to do when the call is analyzed/resolved too early within an
2037 -- intermediate context. This check is saved for last because it incurs
2038 -- a performance penalty.
2040 -- Performance note: parent traversal
2042 elsif In_Premature_Context
(N
) then
2046 Extract_Call_Attributes
2048 Target_Id
=> Target_Id
,
2049 Attrs
=> Call_Attrs
);
2051 Extract_Target_Attributes
2052 (Target_Id
=> Target_Id
,
2053 Attrs
=> Target_Attrs
);
2055 -- Nothing to do when the call appears within the expanded spec or
2056 -- body of an instantiated generic, the call does not invoke a generic
2057 -- formal subprogram, the target is external to the instance, and switch
2058 -- -gnatdL (ignore external calls from instances for elaboration) is in
2062 and then not Is_Generic_Formal_Subp
(Entity
(Call_Nam
))
2064 -- Performance note: parent traversal
2066 and then In_External_Context
2068 Target_Attrs
=> Target_Attrs
)
2072 -- Nothing to do when the call invokes an assertion pragma procedure
2073 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is
2076 elsif Debug_Flag_Underscore_P
2077 and then Is_Assertion_Pragma_Target
(Target_Id
)
2081 -- Source calls to source targets are always considered because they
2082 -- reflect the original call graph.
2084 elsif Target_Attrs
.From_Source
and then Call_Attrs
.From_Source
then
2087 -- A call to a source function which acts as the default expression in
2088 -- another call requires special detection.
2090 elsif Target_Attrs
.From_Source
2091 and then Nkind
(N
) = N_Function_Call
2092 and then Is_Default_Expression
(N
)
2096 -- The target emulates Ada semantics
2098 elsif Is_Ada_Semantic_Target
(Target_Id
) then
2101 -- The target acts as a link between scenarios
2103 elsif Is_Bridge_Target
(Target_Id
) then
2106 -- The target emulates SPARK semantics
2108 elsif Is_SPARK_Semantic_Target
(Target_Id
) then
2111 -- Otherwise the call is not suitable for ABE processing. This prevents
2112 -- the generation of call markers which will never play a role in ABE
2119 -- At this point it is known that the call will play some role in ABE
2120 -- checks and diagnostics. Create a corresponding call marker in case
2121 -- the original call is heavily transformed by expansion later on.
2123 Marker
:= Make_Call_Marker
(Sloc
(N
));
2125 -- Inherit the attributes of the original call
2127 Set_Target
(Marker
, Target_Id
);
2128 Set_Is_Declaration_Level_Node
(Marker
, Call_Attrs
.In_Declarations
);
2129 Set_Is_Dispatching_Call
(Marker
, Call_Attrs
.Is_Dispatching
);
2130 Set_Is_Elaboration_Checks_OK_Node
2131 (Marker
, Call_Attrs
.Elab_Checks_OK
);
2132 Set_Is_Elaboration_Warnings_OK_Node
2133 (Marker
, Call_Attrs
.Elab_Warnings_OK
);
2134 Set_Is_Ignored_Ghost_Node
(Marker
, Call_Attrs
.Ghost_Mode_Ignore
);
2135 Set_Is_Source_Call
(Marker
, Call_Attrs
.From_Source
);
2136 Set_Is_SPARK_Mode_On_Node
(Marker
, Call_Attrs
.SPARK_Mode_On
);
2138 -- The marker is inserted prior to the original call. This placement has
2139 -- several desirable effects:
2141 -- 1) The marker appears in the same context, in close proximity to
2147 -- 2) Inserting the marker prior to the call ensures that an ABE check
2148 -- will take effect prior to the call.
2154 -- 3) The above two properties are preserved even when the call is a
2155 -- function which is subsequently relocated in order to capture its
2156 -- result. Note that if the call is relocated to a new context, the
2157 -- relocated call will receive a marker of its own.
2161 -- Temp : ... := Func_Call ...;
2164 -- The insertion must take place even when the call does not occur in
2165 -- the main unit to keep the tree symmetric. This ensures that internal
2166 -- name serialization is consistent in case the call marker causes the
2167 -- tree to transform in some way.
2169 Insert_Action
(N
, Marker
);
2171 -- The marker becomes the "corresponding" scenario for the call. Save
2172 -- the marker for later processing by the ABE phase.
2174 Record_Elaboration_Scenario
(Marker
);
2175 end Build_Call_Marker
;
2177 -------------------------------------
2178 -- Build_Variable_Reference_Marker --
2179 -------------------------------------
2181 procedure Build_Variable_Reference_Marker
2186 function In_Pragma
(Nod
: Node_Id
) return Boolean;
2187 -- Determine whether arbitrary node Nod appears within a pragma
2193 function In_Pragma
(Nod
: Node_Id
) return Boolean is
2198 while Present
(Par
) loop
2199 if Nkind
(Par
) = N_Pragma
then
2202 -- Prevent the search from going too far
2204 elsif Is_Body_Or_Package_Declaration
(Par
) then
2208 Par
:= Parent
(Par
);
2218 Var_Attrs
: Variable_Attributes
;
2221 -- Start of processing for Build_Variable_Reference_Marker
2224 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
2225 -- enabled) is in effect because the legacy ABE mechanism does not need
2226 -- to carry out this action.
2228 if Legacy_Elaboration_Checks
then
2231 -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are
2232 -- not performed in this mode.
2234 elsif ASIS_Mode
then
2237 -- Nothing to do when the reference is being preanalyzed as the marker
2238 -- will be inserted in the wrong place.
2240 elsif Preanalysis_Active
then
2243 -- Nothing to do when the input does not denote a reference
2245 elsif not Nkind_In
(N
, N_Expanded_Name
, N_Identifier
) then
2248 -- Nothing to do for internally-generated references
2250 elsif not Comes_From_Source
(N
) then
2253 -- Nothing to do when the reference is erroneous, left in a bad state,
2254 -- or does not denote a variable.
2256 elsif not (Present
(Entity
(N
))
2257 and then Ekind
(Entity
(N
)) = E_Variable
2258 and then Entity
(N
) /= Any_Id
)
2263 Extract_Variable_Reference_Attributes
2266 Attrs
=> Var_Attrs
);
2268 Prag
:= SPARK_Pragma
(Var_Id
);
2270 if Comes_From_Source
(Var_Id
)
2272 -- Both the variable and the reference must appear in SPARK_Mode On
2273 -- regions because this scenario falls under the SPARK rules.
2275 and then Present
(Prag
)
2276 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
2277 and then Is_SPARK_Mode_On_Node
(N
)
2279 -- The reference must not be considered when it appears in a pragma.
2280 -- If the pragma has run-time semantics, then the reference will be
2281 -- reconsidered once the pragma is expanded.
2283 -- Performance note: parent traversal
2285 and then not In_Pragma
(N
)
2289 -- Otherwise the reference is not suitable for ABE processing. This
2290 -- prevents the generation of variable markers which will never play
2291 -- a role in ABE diagnostics.
2297 -- At this point it is known that the variable reference will play some
2298 -- role in ABE checks and diagnostics. Create a corresponding variable
2299 -- marker in case the original variable reference is folded or optimized
2302 Marker
:= Make_Variable_Reference_Marker
(Sloc
(N
));
2304 -- Inherit the attributes of the original variable reference
2306 Set_Target
(Marker
, Var_Id
);
2307 Set_Is_Read
(Marker
, Read
);
2308 Set_Is_Write
(Marker
, Write
);
2310 -- The marker is inserted prior to the original variable reference. The
2311 -- insertion must take place even when the reference does not occur in
2312 -- the main unit to keep the tree symmetric. This ensures that internal
2313 -- name serialization is consistent in case the variable marker causes
2314 -- the tree to transform in some way.
2316 Insert_Action
(N
, Marker
);
2318 -- The marker becomes the "corresponding" scenario for the reference.
2319 -- Save the marker for later processing for the ABE phase.
2321 Record_Elaboration_Scenario
(Marker
);
2322 end Build_Variable_Reference_Marker
;
2324 ---------------------------------
2325 -- Check_Elaboration_Scenarios --
2326 ---------------------------------
2328 procedure Check_Elaboration_Scenarios
is
2330 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
2331 -- enabled) is in effect because the legacy ABE mechanism does not need
2332 -- to carry out this action.
2334 if Legacy_Elaboration_Checks
then
2337 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics
2338 -- are performed in this mode.
2340 elsif ASIS_Mode
then
2344 -- Examine the context of the main unit and record all units with prior
2345 -- elaboration with respect to it.
2347 Find_Elaborated_Units
;
2349 -- Examine each top-level scenario saved during the Recording phase for
2350 -- conditional ABEs and perform various actions depending on the model
2351 -- in effect. The table of visited bodies is created for each new top-
2354 for Index
in Top_Level_Scenarios
.First
.. Top_Level_Scenarios
.Last
loop
2355 Reset_Visited_Bodies
;
2357 Process_Conditional_ABE
(Top_Level_Scenarios
.Table
(Index
));
2360 -- Examine each SPARK scenario saved during the Recording phase which
2361 -- is not necessarily executable during elaboration, but still requires
2362 -- elaboration-related checks.
2364 for Index
in SPARK_Scenarios
.First
.. SPARK_Scenarios
.Last
loop
2365 Check_SPARK_Scenario
(SPARK_Scenarios
.Table
(Index
));
2367 end Check_Elaboration_Scenarios
;
2369 ------------------------------
2370 -- Check_Preelaborated_Call --
2371 ------------------------------
2373 procedure Check_Preelaborated_Call
(Call
: Node_Id
) is
2374 function In_Preelaborated_Context
(N
: Node_Id
) return Boolean;
2375 -- Determine whether arbitrary node appears in a preelaborated context
2377 ------------------------------
2378 -- In_Preelaborated_Context --
2379 ------------------------------
2381 function In_Preelaborated_Context
(N
: Node_Id
) return Boolean is
2382 Body_Id
: constant Entity_Id
:= Find_Code_Unit
(N
);
2383 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Body_Id
);
2386 -- The node appears within a package body whose corresponding spec is
2387 -- subject to pragma Remote_Call_Interface or Remote_Types. This does
2388 -- not result in a preelaborated context because the package body may
2389 -- be on another machine.
2391 if Ekind
(Body_Id
) = E_Package_Body
2392 and then Ekind_In
(Spec_Id
, E_Generic_Package
, E_Package
)
2393 and then (Is_Remote_Call_Interface
(Spec_Id
)
2394 or else Is_Remote_Types
(Spec_Id
))
2398 -- Otherwise the node appears within a preelaborated context when the
2399 -- associated unit is preelaborated.
2402 return Is_Preelaborated_Unit
(Spec_Id
);
2404 end In_Preelaborated_Context
;
2408 Call_Attrs
: Call_Attributes
;
2409 Level
: Enclosing_Level_Kind
;
2410 Target_Id
: Entity_Id
;
2412 -- Start of processing for Check_Preelaborated_Call
2415 Extract_Call_Attributes
2417 Target_Id
=> Target_Id
,
2418 Attrs
=> Call_Attrs
);
2420 -- Nothing to do when the call is internally generated because it is
2421 -- assumed that it will never violate preelaboration.
2423 if not Call_Attrs
.From_Source
then
2427 -- Performance note: parent traversal
2429 Level
:= Find_Enclosing_Level
(Call
);
2431 -- Library-level calls are always considered because they are part of
2432 -- the associated unit's elaboration actions.
2434 if Level
in Library_Level
then
2437 -- Calls at the library level of a generic package body must be checked
2438 -- because they would render an instantiation illegal if the template is
2439 -- marked as preelaborated. Note that this does not apply to calls at
2440 -- the library level of a generic package spec.
2442 elsif Level
= Generic_Package_Body
then
2445 -- Otherwise the call does not appear at the proper level and must not
2446 -- be considered for this check.
2452 -- The call appears within a preelaborated unit. Emit a warning only for
2453 -- internal uses, otherwise this is an error.
2455 if In_Preelaborated_Context
(Call
) then
2456 Error_Msg_Warn
:= GNAT_Mode
;
2458 ("<<non-static call not allowed in preelaborated unit", Call
);
2460 end Check_Preelaborated_Call
;
2462 ------------------------------
2463 -- Check_SPARK_Derived_Type --
2464 ------------------------------
2466 procedure Check_SPARK_Derived_Type
(Typ_Decl
: Node_Id
) is
2467 Typ
: constant Entity_Id
:= Defining_Entity
(Typ_Decl
);
2469 -- NOTE: The routines within Check_SPARK_Derived_Type are intentionally
2470 -- unnested to avoid deep indentation of code.
2472 Stop_Check
: exception;
2473 -- This exception is raised when the freeze node violates the placement
2476 procedure Check_Overriding_Primitive
2479 pragma Inline
(Check_Overriding_Primitive
);
2480 -- Verify that freeze node FNode is within the early call region of
2481 -- overriding primitive Prim's body.
2483 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
;
2484 pragma Inline
(Freeze_Node_Location
);
2485 -- Return a more accurate source location associated with freeze node
2488 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean;
2489 pragma Inline
(Precedes_Source_Construct
);
2490 -- Determine whether arbitrary node N appears prior to some source
2493 procedure Suggest_Elaborate_Body
2495 Body_Decl
: Node_Id
;
2496 Error_Nod
: Node_Id
);
2497 pragma Inline
(Suggest_Elaborate_Body
);
2498 -- Suggest the use of pragma Elaborate_Body when the pragma will allow
2499 -- for node N to appear within the early call region of subprogram body
2500 -- Body_Decl. The suggestion is attached to Error_Nod as a continuation
2503 --------------------------------
2504 -- Check_Overriding_Primitive --
2505 --------------------------------
2507 procedure Check_Overriding_Primitive
2511 Prim_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Prim
);
2512 Body_Decl
: Node_Id
;
2513 Body_Id
: Entity_Id
;
2517 Body_Id
:= Corresponding_Body
(Prim_Decl
);
2519 -- Nothing to do when the primitive does not have a corresponding
2520 -- body. This can happen when the unit with the bodies is not the
2521 -- main unit subjected to ABE checks.
2523 if No
(Body_Id
) then
2526 -- The primitive overrides a parent or progenitor primitive
2528 elsif Present
(Overridden_Operation
(Prim
)) then
2530 -- Nothing to do when overriding an interface primitive happens by
2531 -- inheriting a non-interface primitive as the check would be done
2532 -- on the parent primitive.
2534 if Present
(Alias
(Prim
)) then
2538 -- Nothing to do when the primitive is not overriding. The body of
2539 -- such a primitive cannot be targeted by a dispatching call which
2540 -- is executable during elaboration, and cannot cause an ABE.
2546 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
2547 Region
:= Find_Early_Call_Region
(Body_Decl
);
2549 -- The freeze node appears prior to the early call region of the
2552 -- IMPORTANT: This check must always be performed even when -gnatd.v
2553 -- (enforce SPARK elaboration rules in SPARK code) is not specified
2554 -- because the static model cannot guarantee the absence of ABEs in
2555 -- in the presence of dispatching calls.
2557 if Earlier_In_Extended_Unit
(FNode
, Region
) then
2558 Error_Msg_Node_2
:= Prim
;
2560 ("first freezing point of type & must appear within early call "
2561 & "region of primitive body & (SPARK RM 7.7(8))",
2564 Error_Msg_Sloc
:= Sloc
(Region
);
2565 Error_Msg_N
("\region starts #", Typ_Decl
);
2567 Error_Msg_Sloc
:= Sloc
(Body_Decl
);
2568 Error_Msg_N
("\region ends #", Typ_Decl
);
2570 Error_Msg_Sloc
:= Freeze_Node_Location
(FNode
);
2571 Error_Msg_N
("\first freezing point #", Typ_Decl
);
2573 -- If applicable, suggest the use of pragma Elaborate_Body in the
2574 -- associated package spec.
2576 Suggest_Elaborate_Body
2578 Body_Decl
=> Body_Decl
,
2579 Error_Nod
=> Typ_Decl
);
2583 end Check_Overriding_Primitive
;
2585 --------------------------
2586 -- Freeze_Node_Location --
2587 --------------------------
2589 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
is
2590 Context
: constant Node_Id
:= Parent
(FNode
);
2591 Loc
: constant Source_Ptr
:= Sloc
(FNode
);
2593 Prv_Decls
: List_Id
;
2594 Vis_Decls
: List_Id
;
2597 -- In general, the source location of the freeze node is as close as
2598 -- possible to the real freeze point, except when the freeze node is
2599 -- at the "bottom" of a package spec.
2601 if Nkind
(Context
) = N_Package_Specification
then
2602 Prv_Decls
:= Private_Declarations
(Context
);
2603 Vis_Decls
:= Visible_Declarations
(Context
);
2605 -- The freeze node appears in the private declarations of the
2608 if Present
(Prv_Decls
)
2609 and then List_Containing
(FNode
) = Prv_Decls
2613 -- The freeze node appears in the visible declarations of the
2614 -- package and there are no private declarations.
2616 elsif Present
(Vis_Decls
)
2617 and then List_Containing
(FNode
) = Vis_Decls
2618 and then (No
(Prv_Decls
) or else Is_Empty_List
(Prv_Decls
))
2622 -- Otherwise the freeze node is not in the "last" declarative list
2623 -- of the package. Use the existing source location of the freeze
2630 -- The freeze node appears at the "bottom" of the package when it
2631 -- is in the "last" declarative list and is either the last in the
2632 -- list or is followed by internal constructs only. In that case
2633 -- the more appropriate source location is that of the package end
2636 if not Precedes_Source_Construct
(FNode
) then
2637 return Sloc
(End_Label
(Context
));
2642 end Freeze_Node_Location
;
2644 -------------------------------
2645 -- Precedes_Source_Construct --
2646 -------------------------------
2648 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean is
2653 while Present
(Decl
) loop
2654 if Comes_From_Source
(Decl
) then
2657 -- A generated body for a source expression function is treated as
2658 -- a source construct.
2660 elsif Nkind
(Decl
) = N_Subprogram_Body
2661 and then Was_Expression_Function
(Decl
)
2662 and then Comes_From_Source
(Original_Node
(Decl
))
2671 end Precedes_Source_Construct
;
2673 ----------------------------
2674 -- Suggest_Elaborate_Body --
2675 ----------------------------
2677 procedure Suggest_Elaborate_Body
2679 Body_Decl
: Node_Id
;
2680 Error_Nod
: Node_Id
)
2682 Unt
: constant Node_Id
:= Unit
(Cunit
(Main_Unit
));
2686 -- The suggestion applies only when the subprogram body resides in a
2687 -- compilation package body, and a pragma Elaborate_Body would allow
2688 -- for the node to appear in the early call region of the subprogram
2689 -- body. This implies that all code from the subprogram body up to
2690 -- the node is preelaborable.
2692 if Nkind
(Unt
) = N_Package_Body
then
2694 -- Find the start of the early call region again assuming that the
2695 -- package spec has pragma Elaborate_Body. Note that the internal
2696 -- data structures are intentionally not updated because this is a
2697 -- speculative search.
2700 Find_Early_Call_Region
2701 (Body_Decl
=> Body_Decl
,
2702 Assume_Elab_Body
=> True,
2703 Skip_Memoization
=> True);
2705 -- If the node appears within the early call region, assuming that
2706 -- the package spec carries pragma Elaborate_Body, then it is safe
2707 -- to suggest the pragma.
2709 if Earlier_In_Extended_Unit
(Region
, N
) then
2710 Error_Msg_Name_1
:= Name_Elaborate_Body
;
2712 ("\consider adding pragma % in spec of unit &",
2713 Error_Nod
, Defining_Entity
(Unt
));
2716 end Suggest_Elaborate_Body
;
2720 FNode
: constant Node_Id
:= Freeze_Node
(Typ
);
2721 Prims
: constant Elist_Id
:= Direct_Primitive_Operations
(Typ
);
2723 Prim_Elmt
: Elmt_Id
;
2725 -- Start of processing for Check_SPARK_Derived_Type
2728 -- A type should have its freeze node set by the time SPARK scenarios
2729 -- are being verified.
2731 pragma Assert
(Present
(FNode
));
2733 -- Verify that the freeze node of the derived type is within the early
2734 -- call region of each overriding primitive body (SPARK RM 7.7(8)).
2736 if Present
(Prims
) then
2737 Prim_Elmt
:= First_Elmt
(Prims
);
2738 while Present
(Prim_Elmt
) loop
2739 Check_Overriding_Primitive
2740 (Prim
=> Node
(Prim_Elmt
),
2743 Next_Elmt
(Prim_Elmt
);
2750 end Check_SPARK_Derived_Type
;
2752 -------------------------------
2753 -- Check_SPARK_Instantiation --
2754 -------------------------------
2756 procedure Check_SPARK_Instantiation
(Exp_Inst
: Node_Id
) is
2757 Gen_Attrs
: Target_Attributes
;
2760 Inst_Attrs
: Instantiation_Attributes
;
2761 Inst_Id
: Entity_Id
;
2764 Extract_Instantiation_Attributes
2765 (Exp_Inst
=> Exp_Inst
,
2769 Attrs
=> Inst_Attrs
);
2771 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
2773 -- The instantiation and the generic body are both in the main unit
2775 if Present
(Gen_Attrs
.Body_Decl
)
2776 and then In_Extended_Main_Code_Unit
(Gen_Attrs
.Body_Decl
)
2778 -- If the instantiation appears prior to the generic body, then the
2779 -- instantiation is illegal (SPARK RM 7.7(6)).
2781 -- IMPORTANT: This check must always be performed even when -gnatd.v
2782 -- (enforce SPARK elaboration rules in SPARK code) is not specified
2783 -- because the rule prevents use-before-declaration of objects that
2784 -- may precede the generic body.
2786 and then Earlier_In_Extended_Unit
(Inst
, Gen_Attrs
.Body_Decl
)
2788 Error_Msg_NE
("cannot instantiate & before body seen", Inst
, Gen_Id
);
2790 end Check_SPARK_Instantiation
;
2792 ---------------------------------
2793 -- Check_SPARK_Model_In_Effect --
2794 ---------------------------------
2796 SPARK_Model_Warning_Posted
: Boolean := False;
2797 -- This flag prevents the same SPARK model-related warning from being
2798 -- emitted multiple times.
2800 procedure Check_SPARK_Model_In_Effect
(N
: Node_Id
) is
2802 -- Do not emit the warning multiple times as this creates useless noise
2804 if SPARK_Model_Warning_Posted
then
2807 -- SPARK rule verification requires the "strict" static model
2809 elsif Static_Elaboration_Checks
and not Relaxed_Elaboration_Checks
then
2812 -- Any other combination of models does not guarantee the absence of ABE
2813 -- problems for SPARK rule verification purposes. Note that there is no
2814 -- need to check for the legacy ABE mechanism because the legacy code
2815 -- has its own orthogonal processing for SPARK rules.
2818 SPARK_Model_Warning_Posted
:= True;
2821 ("??SPARK elaboration checks require static elaboration model", N
);
2823 if Dynamic_Elaboration_Checks
then
2824 Error_Msg_N
("\dynamic elaboration model is in effect", N
);
2826 pragma Assert
(Relaxed_Elaboration_Checks
);
2827 Error_Msg_N
("\relaxed elaboration model is in effect", N
);
2830 end Check_SPARK_Model_In_Effect
;
2832 --------------------------
2833 -- Check_SPARK_Scenario --
2834 --------------------------
2836 procedure Check_SPARK_Scenario
(N
: Node_Id
) is
2838 -- Ensure that a suitable elaboration model is in effect for SPARK rule
2841 Check_SPARK_Model_In_Effect
(N
);
2843 -- Add the current scenario to the stack of active scenarios
2845 Push_Active_Scenario
(N
);
2847 if Is_Suitable_SPARK_Derived_Type
(N
) then
2848 Check_SPARK_Derived_Type
(N
);
2850 elsif Is_Suitable_SPARK_Instantiation
(N
) then
2851 Check_SPARK_Instantiation
(N
);
2853 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
2854 Check_SPARK_Refined_State_Pragma
(N
);
2857 -- Remove the current scenario from the stack of active scenarios once
2858 -- all ABE diagnostics and checks have been performed.
2860 Pop_Active_Scenario
(N
);
2861 end Check_SPARK_Scenario
;
2863 --------------------------------------
2864 -- Check_SPARK_Refined_State_Pragma --
2865 --------------------------------------
2867 procedure Check_SPARK_Refined_State_Pragma
(N
: Node_Id
) is
2869 -- NOTE: The routines within Check_SPARK_Refined_State_Pragma are
2870 -- intentionally unnested to avoid deep indentation of code.
2872 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
);
2873 pragma Inline
(Check_SPARK_Constituent
);
2874 -- Ensure that a single constituent Constit_Id is elaborated prior to
2877 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
);
2878 pragma Inline
(Check_SPARK_Constituents
);
2879 -- Ensure that all constituents found in list Constits are elaborated
2880 -- prior to the main unit.
2882 procedure Check_SPARK_Initialized_State
(State
: Node_Id
);
2883 pragma Inline
(Check_SPARK_Initialized_State
);
2884 -- Ensure that the constituents of single abstract state State are
2885 -- elaborated prior to the main unit.
2887 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
);
2888 pragma Inline
(Check_SPARK_Initialized_States
);
2889 -- Ensure that the constituents of all abstract states which appear in
2890 -- the Initializes pragma of package Pack_Id are elaborated prior to the
2893 -----------------------------
2894 -- Check_SPARK_Constituent --
2895 -----------------------------
2897 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
) is
2901 -- Nothing to do for "null" constituents
2903 if Nkind
(Constit_Id
) = N_Null
then
2906 -- Nothing to do for illegal constituents
2908 elsif Error_Posted
(Constit_Id
) then
2912 Prag
:= SPARK_Pragma
(Constit_Id
);
2914 -- The check applies only when the constituent is subject to pragma
2918 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
2920 -- An external constituent of an abstract state which appears in
2921 -- the Initializes pragma of a package spec imposes an Elaborate
2922 -- requirement on the context of the main unit. Determine whether
2923 -- the context has a pragma strong enough to meet the requirement.
2925 -- IMPORTANT: This check is performed only when -gnatd.v (enforce
2926 -- SPARK elaboration rules in SPARK code) is in effect because the
2927 -- static model can ensure the prior elaboration of the unit which
2928 -- contains a constituent by installing implicit Elaborate pragma.
2930 if Debug_Flag_Dot_V
then
2931 Meet_Elaboration_Requirement
2933 Target_Id
=> Constit_Id
,
2934 Req_Nam
=> Name_Elaborate
);
2936 -- Otherwise ensure that the unit with the external constituent is
2937 -- elaborated prior to the main unit.
2940 Ensure_Prior_Elaboration
2942 Unit_Id
=> Find_Top_Unit
(Constit_Id
),
2943 Prag_Nam
=> Name_Elaborate
,
2944 State
=> Initial_State
);
2947 end Check_SPARK_Constituent
;
2949 ------------------------------
2950 -- Check_SPARK_Constituents --
2951 ------------------------------
2953 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
) is
2954 Constit_Elmt
: Elmt_Id
;
2957 if Present
(Constits
) then
2958 Constit_Elmt
:= First_Elmt
(Constits
);
2959 while Present
(Constit_Elmt
) loop
2960 Check_SPARK_Constituent
(Node
(Constit_Elmt
));
2961 Next_Elmt
(Constit_Elmt
);
2964 end Check_SPARK_Constituents
;
2966 -----------------------------------
2967 -- Check_SPARK_Initialized_State --
2968 -----------------------------------
2970 procedure Check_SPARK_Initialized_State
(State
: Node_Id
) is
2972 State_Id
: Entity_Id
;
2975 -- Nothing to do for "null" initialization items
2977 if Nkind
(State
) = N_Null
then
2980 -- Nothing to do for illegal states
2982 elsif Error_Posted
(State
) then
2986 State_Id
:= Entity_Of
(State
);
2988 -- Sanitize the state
2990 if No
(State_Id
) then
2993 elsif Error_Posted
(State_Id
) then
2996 elsif Ekind
(State_Id
) /= E_Abstract_State
then
3000 -- The check is performed only when the abstract state is subject to
3003 Prag
:= SPARK_Pragma
(State_Id
);
3006 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
3008 Check_SPARK_Constituents
(Refinement_Constituents
(State_Id
));
3010 end Check_SPARK_Initialized_State
;
3012 ------------------------------------
3013 -- Check_SPARK_Initialized_States --
3014 ------------------------------------
3016 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
) is
3017 Prag
: constant Node_Id
:= Get_Pragma
(Pack_Id
, Pragma_Initializes
);
3022 if Present
(Prag
) then
3023 Inits
:= Expression
(Get_Argument
(Prag
, Pack_Id
));
3025 -- Avoid processing a "null" initialization list. The only other
3026 -- alternative is an aggregate.
3028 if Nkind
(Inits
) = N_Aggregate
then
3030 -- The initialization items appear in list form:
3034 if Present
(Expressions
(Inits
)) then
3035 Init
:= First
(Expressions
(Inits
));
3036 while Present
(Init
) loop
3037 Check_SPARK_Initialized_State
(Init
);
3042 -- The initialization items appear in associated form:
3044 -- (state1 => item1,
3045 -- state2 => (item2, item3))
3047 if Present
(Component_Associations
(Inits
)) then
3048 Init
:= First
(Component_Associations
(Inits
));
3049 while Present
(Init
) loop
3050 Check_SPARK_Initialized_State
(Init
);
3056 end Check_SPARK_Initialized_States
;
3060 Pack_Body
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
3062 -- Start of processing for Check_SPARK_Refined_State_Pragma
3065 -- Pragma Refined_State must be associated with a package body
3068 (Present
(Pack_Body
) and then Nkind
(Pack_Body
) = N_Package_Body
);
3070 -- Verify that each external contitunent of an abstract state mentioned
3071 -- in pragma Initializes is properly elaborated.
3073 Check_SPARK_Initialized_States
(Unique_Defining_Entity
(Pack_Body
));
3074 end Check_SPARK_Refined_State_Pragma
;
3076 ----------------------
3077 -- Compilation_Unit --
3078 ----------------------
3080 function Compilation_Unit
(Unit_Id
: Entity_Id
) return Node_Id
is
3081 Comp_Unit
: Node_Id
;
3084 Comp_Unit
:= Parent
(Unit_Id
);
3086 -- Handle the case where a concurrent subunit is rewritten as a null
3087 -- statement due to expansion activities.
3089 if Nkind
(Comp_Unit
) = N_Null_Statement
3090 and then Nkind_In
(Original_Node
(Comp_Unit
), N_Protected_Body
,
3093 Comp_Unit
:= Parent
(Comp_Unit
);
3094 pragma Assert
(Nkind
(Comp_Unit
) = N_Subunit
);
3096 -- Otherwise use the declaration node of the unit
3099 Comp_Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
3102 -- Handle the case where a subprogram instantiation which acts as a
3103 -- compilation unit is expanded into an anonymous package that wraps
3104 -- the instantiated subprogram.
3106 if Nkind
(Comp_Unit
) = N_Package_Specification
3107 and then Nkind_In
(Original_Node
(Parent
(Comp_Unit
)),
3108 N_Function_Instantiation
,
3109 N_Procedure_Instantiation
)
3111 Comp_Unit
:= Parent
(Parent
(Comp_Unit
));
3113 -- Handle the case where the compilation unit is a subunit
3115 elsif Nkind
(Comp_Unit
) = N_Subunit
then
3116 Comp_Unit
:= Parent
(Comp_Unit
);
3119 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
3122 end Compilation_Unit
;
3124 -----------------------
3125 -- Early_Call_Region --
3126 -----------------------
3128 function Early_Call_Region
(Body_Id
: Entity_Id
) return Node_Id
is
3130 pragma Assert
(Ekind_In
(Body_Id
, E_Entry
,
3134 E_Subprogram_Body
));
3136 if Early_Call_Regions_In_Use
then
3137 return Early_Call_Regions
.Get
(Body_Id
);
3140 return Early_Call_Regions_No_Element
;
3141 end Early_Call_Region
;
3143 -----------------------------
3144 -- Early_Call_Regions_Hash --
3145 -----------------------------
3147 function Early_Call_Regions_Hash
3148 (Key
: Entity_Id
) return Early_Call_Regions_Index
3151 return Early_Call_Regions_Index
(Key
mod Early_Call_Regions_Max
);
3152 end Early_Call_Regions_Hash
;
3158 procedure Elab_Msg_NE
3165 function Prefix
return String;
3166 -- Obtain the prefix of the message
3168 function Suffix
return String;
3169 -- Obtain the suffix of the message
3175 function Prefix
return String is
3188 function Suffix
return String is
3197 -- Start of processing for Elab_Msg_NE
3200 Error_Msg_NE
(Prefix
& Msg
& Suffix
, N
, Id
);
3203 ------------------------
3204 -- Elaboration_Status --
3205 ------------------------
3207 function Elaboration_Status
3208 (Unit_Id
: Entity_Id
) return Elaboration_Attributes
3211 if Elaboration_Statuses_In_Use
then
3212 return Elaboration_Statuses
.Get
(Unit_Id
);
3215 return Elaboration_Statuses_No_Element
;
3216 end Elaboration_Status
;
3218 -------------------------------
3219 -- Elaboration_Statuses_Hash --
3220 -------------------------------
3222 function Elaboration_Statuses_Hash
3223 (Key
: Entity_Id
) return Elaboration_Statuses_Index
3226 return Elaboration_Statuses_Index
(Key
mod Elaboration_Statuses_Max
);
3227 end Elaboration_Statuses_Hash
;
3229 ------------------------------
3230 -- Ensure_Prior_Elaboration --
3231 ------------------------------
3233 procedure Ensure_Prior_Elaboration
3235 Unit_Id
: Entity_Id
;
3237 State
: Processing_Attributes
)
3240 pragma Assert
(Nam_In
(Prag_Nam
, Name_Elaborate
, Name_Elaborate_All
));
3242 -- Nothing to do when the caller has suppressed the generation of
3243 -- implicit Elaborate[_All] pragmas.
3245 if State
.Suppress_Implicit_Pragmas
then
3248 -- Nothing to do when the need for prior elaboration came from a partial
3249 -- finalization routine which occurs in an initialization context. This
3250 -- behaviour parallels that of the old ABE mechanism.
3252 elsif State
.Within_Partial_Finalization
then
3255 -- Nothing to do when the need for prior elaboration came from a task
3256 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on
3257 -- task bodies) is in effect.
3259 elsif Debug_Flag_Dot_Y
and then State
.Within_Task_Body
then
3262 -- Nothing to do when the unit is elaborated prior to the main unit.
3263 -- This check must also consider the following cases:
3265 -- * No check is made against the context of the main unit because this
3266 -- is specific to the elaboration model in effect and requires custom
3267 -- handling (see Ensure_xxx_Prior_Elaboration).
3269 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
3270 -- Elaborate[_All] MUST be generated even though Unit_Id is always
3271 -- elaborated prior to the main unit. This is a conservative strategy
3272 -- which ensures that other units withed by Unit_Id will not lead to
3275 -- package A is package body A is
3276 -- procedure ABE; procedure ABE is ... end ABE;
3280 -- package B is package body B is
3281 -- pragma Elaborate_Body; procedure Proc is
3283 -- procedure Proc; A.ABE;
3284 -- package B; end Proc;
3288 -- package C is package body C is
3294 -- In the example above, the elaboration of C invokes B.Proc. B is
3295 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is
3296 -- generated for B in C, then the following elaboratio order will lead
3299 -- spec of A elaborated
3300 -- spec of B elaborated
3301 -- body of B elaborated
3302 -- spec of C elaborated
3303 -- body of C elaborated <-- calls B.Proc which calls A.ABE
3304 -- body of A elaborated <-- problem
3306 -- The generation of an implicit pragma Elaborate_All (B) ensures that
3307 -- the elaboration order mechanism will not pick the above order.
3309 -- An implicit Elaborate is NOT generated when the unit is subject to
3310 -- Elaborate_Body because both pragmas have the exact same effect.
3312 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST
3313 -- NOT be generated in this case because a unit cannot depend on its
3314 -- own elaboration. This case is therefore treated as valid prior
3317 elsif Has_Prior_Elaboration
3318 (Unit_Id
=> Unit_Id
,
3319 Same_Unit_OK
=> True,
3320 Elab_Body_OK
=> Prag_Nam
= Name_Elaborate
)
3324 -- Suggest the use of pragma Prag_Nam when the dynamic model is in
3327 elsif Dynamic_Elaboration_Checks
then
3328 Ensure_Prior_Elaboration_Dynamic
3331 Prag_Nam
=> Prag_Nam
);
3333 -- Install an implicit pragma Prag_Nam when the static model is in
3337 pragma Assert
(Static_Elaboration_Checks
);
3339 Ensure_Prior_Elaboration_Static
3342 Prag_Nam
=> Prag_Nam
);
3344 end Ensure_Prior_Elaboration
;
3346 --------------------------------------
3347 -- Ensure_Prior_Elaboration_Dynamic --
3348 --------------------------------------
3350 procedure Ensure_Prior_Elaboration_Dynamic
3352 Unit_Id
: Entity_Id
;
3355 procedure Info_Missing_Pragma
;
3356 pragma Inline
(Info_Missing_Pragma
);
3357 -- Output information concerning missing Elaborate or Elaborate_All
3358 -- pragma with name Prag_Nam for scenario N, which would ensure the
3359 -- prior elaboration of Unit_Id.
3361 -------------------------
3362 -- Info_Missing_Pragma --
3363 -------------------------
3365 procedure Info_Missing_Pragma
is
3367 -- Internal units are ignored as they cause unnecessary noise
3369 if not In_Internal_Unit
(Unit_Id
) then
3371 -- The name of the unit subjected to the elaboration pragma is
3372 -- fully qualified to improve the clarity of the info message.
3374 Error_Msg_Name_1
:= Prag_Nam
;
3375 Error_Msg_Qual_Level
:= Nat
'Last;
3377 Error_Msg_NE
("info: missing pragma % for unit &", N
, Unit_Id
);
3378 Error_Msg_Qual_Level
:= 0;
3380 end Info_Missing_Pragma
;
3384 Elab_Attrs
: Elaboration_Attributes
;
3385 Level
: Enclosing_Level_Kind
;
3387 -- Start of processing for Ensure_Prior_Elaboration_Dynamic
3390 Elab_Attrs
:= Elaboration_Status
(Unit_Id
);
3392 -- Nothing to do when the unit is guaranteed prior elaboration by means
3393 -- of a source Elaborate[_All] pragma.
3395 if Present
(Elab_Attrs
.Source_Pragma
) then
3399 -- Output extra information on a missing Elaborate[_All] pragma when
3400 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
3403 if Elab_Info_Messages
then
3405 -- Performance note: parent traversal
3407 Level
:= Find_Enclosing_Level
(N
);
3409 -- Declaration-level scenario
3411 if (Is_Suitable_Call
(N
) or else Is_Suitable_Instantiation
(N
))
3412 and then Level
= Declaration_Level
3416 -- Library-level scenario
3418 elsif Level
in Library_Level
then
3421 -- Instantiation library-level scenario
3423 elsif Level
= Instantiation
then
3426 -- Otherwise the scenario does not appear at the proper level and
3427 -- cannot possibly act as a top-level scenario.
3433 Info_Missing_Pragma
;
3435 end Ensure_Prior_Elaboration_Dynamic
;
3437 -------------------------------------
3438 -- Ensure_Prior_Elaboration_Static --
3439 -------------------------------------
3441 procedure Ensure_Prior_Elaboration_Static
3443 Unit_Id
: Entity_Id
;
3446 function Find_With_Clause
3448 Withed_Id
: Entity_Id
) return Node_Id
;
3449 pragma Inline
(Find_With_Clause
);
3450 -- Find a nonlimited with clause in the list of context items Items
3451 -- that withs unit Withed_Id. Return Empty if no such clause is found.
3453 procedure Info_Implicit_Pragma
;
3454 pragma Inline
(Info_Implicit_Pragma
);
3455 -- Output information concerning an implicitly generated Elaborate or
3456 -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures
3457 -- the prior elaboration of unit Unit_Id.
3459 ----------------------
3460 -- Find_With_Clause --
3461 ----------------------
3463 function Find_With_Clause
3465 Withed_Id
: Entity_Id
) return Node_Id
3470 -- Examine the context clauses looking for a suitable with. Note that
3471 -- limited clauses do not affect the elaboration order.
3473 Item
:= First
(Items
);
3474 while Present
(Item
) loop
3475 if Nkind
(Item
) = N_With_Clause
3476 and then not Error_Posted
(Item
)
3477 and then not Limited_Present
(Item
)
3478 and then Entity
(Name
(Item
)) = Withed_Id
3487 end Find_With_Clause
;
3489 --------------------------
3490 -- Info_Implicit_Pragma --
3491 --------------------------
3493 procedure Info_Implicit_Pragma
is
3495 -- Internal units are ignored as they cause unnecessary noise
3497 if not In_Internal_Unit
(Unit_Id
) then
3499 -- The name of the unit subjected to the elaboration pragma is
3500 -- fully qualified to improve the clarity of the info message.
3502 Error_Msg_Name_1
:= Prag_Nam
;
3503 Error_Msg_Qual_Level
:= Nat
'Last;
3506 ("info: implicit pragma % generated for unit &", N
, Unit_Id
);
3508 Error_Msg_Qual_Level
:= 0;
3509 Output_Active_Scenarios
(N
);
3511 end Info_Implicit_Pragma
;
3515 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
3516 Loc
: constant Source_Ptr
:= Sloc
(Main_Cunit
);
3517 Unit_Cunit
: constant Node_Id
:= Compilation_Unit
(Unit_Id
);
3520 Elab_Attrs
: Elaboration_Attributes
;
3523 -- Start of processing for Ensure_Prior_Elaboration_Static
3526 Elab_Attrs
:= Elaboration_Status
(Unit_Id
);
3528 -- Nothing to do when the unit is guaranteed prior elaboration by means
3529 -- of a source Elaborate[_All] pragma.
3531 if Present
(Elab_Attrs
.Source_Pragma
) then
3534 -- Nothing to do when the unit has an existing implicit Elaborate[_All]
3535 -- pragma installed by a previous scenario.
3537 elsif Present
(Elab_Attrs
.With_Clause
) then
3539 -- The unit is already guaranteed prior elaboration by means of an
3540 -- implicit Elaborate pragma, however the current scenario imposes
3541 -- a stronger requirement of Elaborate_All. "Upgrade" the existing
3542 -- pragma to match this new requirement.
3544 if Elaborate_Desirable
(Elab_Attrs
.With_Clause
)
3545 and then Prag_Nam
= Name_Elaborate_All
3547 Set_Elaborate_All_Desirable
(Elab_Attrs
.With_Clause
);
3548 Set_Elaborate_Desirable
(Elab_Attrs
.With_Clause
, False);
3554 -- At this point it is known that the unit has no prior elaboration
3555 -- according to pragmas and hierarchical relationships.
3557 Items
:= Context_Items
(Main_Cunit
);
3561 Set_Context_Items
(Main_Cunit
, Items
);
3564 -- Locate the with clause for the unit. Note that there may not be a
3565 -- clause if the unit is visible through a subunit-body, body-spec, or
3566 -- spec-parent relationship.
3571 Withed_Id
=> Unit_Id
);
3576 -- Note that adding implicit with clauses is safe because analysis,
3577 -- resolution, and expansion have already taken place and it is not
3578 -- possible to interfere with visibility.
3582 Make_With_Clause
(Loc
,
3583 Name
=> New_Occurrence_Of
(Unit_Id
, Loc
));
3585 Set_Implicit_With
(Clause
);
3586 Set_Library_Unit
(Clause
, Unit_Cunit
);
3588 -- The following is a kludge to satisfy a GPRbuild requirement. In
3589 -- general, internal with clauses should be encoded on a 'Z' line in
3590 -- ALI files, but due to an old bug, they are encoded as source with
3591 -- clauses on a 'W' line. As a result, these "semi-implicit" clauses
3592 -- introduce spurious build dependencies in GPRbuild. The only way to
3593 -- eliminate this effect is to mark the implicit clauses as generated
3594 -- for an instantiation.
3596 Set_Implicit_With_From_Instantiation
(Clause
);
3598 Append_To
(Items
, Clause
);
3601 -- Mark the with clause depending on the pragma required
3603 if Prag_Nam
= Name_Elaborate
then
3604 Set_Elaborate_Desirable
(Clause
);
3606 Set_Elaborate_All_Desirable
(Clause
);
3609 -- The implicit Elaborate[_All] ensures the prior elaboration of the
3610 -- unit. Include the unit in the elaboration context of the main unit.
3612 Set_Elaboration_Status
3613 (Unit_Id
=> Unit_Id
,
3614 Val
=> Elaboration_Attributes
'(Source_Pragma => Empty,
3615 With_Clause => Clause));
3617 -- Output extra information on an implicit Elaborate[_All] pragma when
3618 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is
3621 if Elab_Info_Messages then
3622 Info_Implicit_Pragma;
3624 end Ensure_Prior_Elaboration_Static;
3626 -----------------------------
3627 -- Extract_Assignment_Name --
3628 -----------------------------
3630 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is
3636 -- When the name denotes an array or record component, find the whole
3639 while Nkind_In (Nam, N_Explicit_Dereference,
3640 N_Indexed_Component,
3641 N_Selected_Component,
3644 Nam := Prefix (Nam);
3648 end Extract_Assignment_Name;
3650 -----------------------------
3651 -- Extract_Call_Attributes --
3652 -----------------------------
3654 procedure Extract_Call_Attributes
3656 Target_Id : out Entity_Id;
3657 Attrs : out Call_Attributes)
3659 From_Source : Boolean;
3660 In_Declarations : Boolean;
3661 Is_Dispatching : Boolean;
3664 -- Extraction for call markers
3666 if Nkind (Call) = N_Call_Marker then
3667 Target_Id := Target (Call);
3668 From_Source := Is_Source_Call (Call);
3669 In_Declarations := Is_Declaration_Level_Node (Call);
3670 Is_Dispatching := Is_Dispatching_Call (Call);
3672 -- Extraction for entry calls, requeue, and subprogram calls
3675 pragma Assert (Nkind_In (Call, N_Entry_Call_Statement,
3677 N_Procedure_Call_Statement,
3678 N_Requeue_Statement));
3680 Target_Id := Entity (Extract_Call_Name (Call));
3681 From_Source := Comes_From_Source (Call);
3683 -- Performance note: parent traversal
3685 In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level;
3687 Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
3688 and then Present (Controlling_Argument (Call));
3691 -- Obtain the original entry or subprogram which the target may rename
3692 -- except when the target is an instantiation. In this case the alias
3693 -- is the internally generated subprogram which appears within the the
3694 -- anonymous package created for the instantiation. Such an alias is not
3695 -- a suitable target.
3697 if not (Is_Subprogram (Target_Id)
3698 and then Is_Generic_Instance (Target_Id))
3700 Target_Id := Get_Renamed_Entity (Target_Id);
3703 -- Set all attributes
3705 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call);
3706 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call);
3707 Attrs.From_Source := From_Source;
3708 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call);
3709 Attrs.In_Declarations := In_Declarations;
3710 Attrs.Is_Dispatching := Is_Dispatching;
3711 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call);
3712 end Extract_Call_Attributes;
3714 -----------------------
3715 -- Extract_Call_Name --
3716 -----------------------
3718 function Extract_Call_Name (Call : Node_Id) return Node_Id is
3724 -- When the call invokes an entry family, the name appears as an indexed
3727 if Nkind (Nam) = N_Indexed_Component then
3728 Nam := Prefix (Nam);
3731 -- When the call employs the object.operation form, the name appears as
3732 -- a selected component.
3734 if Nkind (Nam) = N_Selected_Component then
3735 Nam := Selector_Name (Nam);
3739 end Extract_Call_Name;
3741 ---------------------------------
3742 -- Extract_Instance_Attributes --
3743 ---------------------------------
3745 procedure Extract_Instance_Attributes
3746 (Exp_Inst : Node_Id;
3747 Inst_Body : out Node_Id;
3748 Inst_Decl : out Node_Id)
3750 Body_Id : Entity_Id;
3753 -- Assume that the attributes are unavailable
3758 -- Generic package or subprogram spec
3760 if Nkind_In (Exp_Inst, N_Package_Declaration,
3761 N_Subprogram_Declaration)
3763 Inst_Decl := Exp_Inst;
3764 Body_Id := Corresponding_Body (Inst_Decl);
3766 if Present (Body_Id) then
3767 Inst_Body := Unit_Declaration_Node (Body_Id);
3770 -- Generic package or subprogram body
3774 (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body));
3776 Inst_Body := Exp_Inst;
3777 Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body));
3779 end Extract_Instance_Attributes;
3781 --------------------------------------
3782 -- Extract_Instantiation_Attributes --
3783 --------------------------------------
3785 procedure Extract_Instantiation_Attributes
3786 (Exp_Inst : Node_Id;
3788 Inst_Id : out Entity_Id;
3789 Gen_Id : out Entity_Id;
3790 Attrs : out Instantiation_Attributes)
3793 Inst := Original_Node (Exp_Inst);
3794 Inst_Id := Defining_Entity (Inst);
3796 -- Traverse a possible chain of renamings to obtain the original generic
3797 -- being instantiatied.
3799 Gen_Id := Get_Renamed_Entity (Entity (Name (Inst)));
3801 -- Set all attributes
3803 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst);
3804 Attrs.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst);
3805 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst);
3806 Attrs.In_Declarations := Is_Declaration_Level_Node (Inst);
3807 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst);
3808 end Extract_Instantiation_Attributes;
3810 -------------------------------
3811 -- Extract_Target_Attributes --
3812 -------------------------------
3814 procedure Extract_Target_Attributes
3815 (Target_Id : Entity_Id;
3816 Attrs : out Target_Attributes)
3818 procedure Extract_Package_Or_Subprogram_Attributes
3819 (Spec_Id : out Entity_Id;
3820 Body_Decl : out Node_Id);
3821 -- Obtain the attributes associated with a package or a subprogram.
3822 -- Spec_Id is the package or subprogram. Body_Decl is the declaration
3823 -- of the corresponding package or subprogram body.
3825 procedure Extract_Protected_Entry_Attributes
3826 (Spec_Id : out Entity_Id;
3827 Body_Decl : out Node_Id;
3828 Body_Barf : out Node_Id);
3829 -- Obtain the attributes associated with a protected entry [family].
3830 -- Spec_Id is the entity of the protected body subprogram. Body_Decl
3831 -- is the declaration of Spec_Id's corresponding body. Body_Barf is
3832 -- the declaration of the barrier function body.
3834 procedure Extract_Protected_Subprogram_Attributes
3835 (Spec_Id : out Entity_Id;
3836 Body_Decl : out Node_Id);
3837 -- Obtain the attributes associated with a protected subprogram. Formal
3838 -- Spec_Id is the entity of the protected body subprogram. Body_Decl is
3839 -- the declaration of Spec_Id's corresponding body.
3841 procedure Extract_Task_Entry_Attributes
3842 (Spec_Id : out Entity_Id;
3843 Body_Decl : out Node_Id);
3844 -- Obtain the attributes associated with a task entry [family]. Formal
3845 -- Spec_Id is the entity of the task body procedure. Body_Decl is the
3846 -- declaration of Spec_Id's corresponding body.
3848 ----------------------------------------------
3849 -- Extract_Package_Or_Subprogram_Attributes --
3850 ----------------------------------------------
3852 procedure Extract_Package_Or_Subprogram_Attributes
3853 (Spec_Id : out Entity_Id;
3854 Body_Decl : out Node_Id)
3856 Body_Id : Entity_Id;
3857 Init_Id : Entity_Id;
3858 Spec_Decl : Node_Id;
3861 -- Assume that the body is not available
3864 Spec_Id := Target_Id;
3866 -- For body retrieval purposes, the entity of the initial declaration
3867 -- is that of the spec.
3871 -- The only exception to the above is a function which returns a
3872 -- constrained array type in a SPARK-to-C compilation. In this case
3873 -- the function receives a corresponding procedure which has an out
3874 -- parameter. The proper body for ABE checks and diagnostics is that
3875 -- of the procedure.
3877 if Ekind (Init_Id) = E_Function
3878 and then Rewritten_For_C (Init_Id)
3880 Init_Id := Corresponding_Procedure (Init_Id);
3883 -- Extract the attributes of the body
3885 Spec_Decl := Unit_Declaration_Node (Init_Id);
3887 -- The initial declaration is a stand alone subprogram body
3889 if Nkind (Spec_Decl) = N_Subprogram_Body then
3890 Body_Decl := Spec_Decl;
3892 -- Otherwise the package or subprogram has a spec and a completing
3895 elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
3896 N_Generic_Subprogram_Declaration,
3897 N_Package_Declaration,
3898 N_Subprogram_Body_Stub,
3899 N_Subprogram_Declaration)
3901 Body_Id := Corresponding_Body (Spec_Decl);
3903 if Present (Body_Id) then
3904 Body_Decl := Unit_Declaration_Node (Body_Id);
3907 end Extract_Package_Or_Subprogram_Attributes;
3909 ----------------------------------------
3910 -- Extract_Protected_Entry_Attributes --
3911 ----------------------------------------
3913 procedure Extract_Protected_Entry_Attributes
3914 (Spec_Id : out Entity_Id;
3915 Body_Decl : out Node_Id;
3916 Body_Barf : out Node_Id)
3918 Barf_Id : Entity_Id;
3919 Body_Id : Entity_Id;
3922 -- Assume that the bodies are not available
3927 -- When the entry [family] has already been expanded, it carries both
3928 -- the procedure which emulates the behavior of the entry [family] as
3929 -- well as the barrier function.
3931 if Present (Protected_Body_Subprogram (Target_Id)) then
3932 Spec_Id := Protected_Body_Subprogram (Target_Id);
3934 -- Extract the attributes of the barrier function
3938 (Unit_Declaration_Node (Barrier_Function (Target_Id)));
3940 if Present (Barf_Id) then
3941 Body_Barf := Unit_Declaration_Node (Barf_Id);
3944 -- Otherwise no expansion took place
3947 Spec_Id := Target_Id;
3950 -- Extract the attributes of the entry body
3952 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
3954 if Present (Body_Id) then
3955 Body_Decl := Unit_Declaration_Node (Body_Id);
3957 end Extract_Protected_Entry_Attributes;
3959 ---------------------------------------------
3960 -- Extract_Protected_Subprogram_Attributes --
3961 ---------------------------------------------
3963 procedure Extract_Protected_Subprogram_Attributes
3964 (Spec_Id : out Entity_Id;
3965 Body_Decl : out Node_Id)
3967 Body_Id : Entity_Id;
3970 -- Assume that the body is not available
3974 -- When the protected subprogram has already been expanded, it
3975 -- carries the subprogram which seizes the lock and invokes the
3976 -- original statements.
3978 if Present (Protected_Subprogram (Target_Id)) then
3980 Protected_Body_Subprogram (Protected_Subprogram (Target_Id));
3982 -- Otherwise no expansion took place
3985 Spec_Id := Target_Id;
3988 -- Extract the attributes of the body
3990 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
3992 if Present (Body_Id) then
3993 Body_Decl := Unit_Declaration_Node (Body_Id);
3995 end Extract_Protected_Subprogram_Attributes;
3997 -----------------------------------
3998 -- Extract_Task_Entry_Attributes --
3999 -----------------------------------
4001 procedure Extract_Task_Entry_Attributes
4002 (Spec_Id : out Entity_Id;
4003 Body_Decl : out Node_Id)
4005 Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id));
4006 Body_Id : Entity_Id;
4009 -- Assume that the body is not available
4013 -- The the task type has already been expanded, it carries the
4014 -- procedure which emulates the behavior of the task body.
4016 if Present (Task_Body_Procedure (Task_Typ)) then
4017 Spec_Id := Task_Body_Procedure (Task_Typ);
4019 -- Otherwise no expansion took place
4022 Spec_Id := Task_Typ;
4025 -- Extract the attributes of the body
4027 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4029 if Present (Body_Id) then
4030 Body_Decl := Unit_Declaration_Node (Body_Id);
4032 end Extract_Task_Entry_Attributes;
4036 Prag : constant Node_Id := SPARK_Pragma (Target_Id);
4037 Body_Barf : Node_Id;
4038 Body_Decl : Node_Id;
4039 Spec_Id : Entity_Id;
4041 -- Start of processing for Extract_Target_Attributes
4044 -- Assume that the body of the barrier function is not available
4048 -- The target is a protected entry [family]
4050 if Is_Protected_Entry (Target_Id) then
4051 Extract_Protected_Entry_Attributes
4052 (Spec_Id => Spec_Id,
4053 Body_Decl => Body_Decl,
4054 Body_Barf => Body_Barf);
4056 -- The target is a protected subprogram
4058 elsif Is_Protected_Subp (Target_Id)
4059 or else Is_Protected_Body_Subp (Target_Id)
4061 Extract_Protected_Subprogram_Attributes
4062 (Spec_Id => Spec_Id,
4063 Body_Decl => Body_Decl);
4065 -- The target is a task entry [family]
4067 elsif Is_Task_Entry (Target_Id) then
4068 Extract_Task_Entry_Attributes
4069 (Spec_Id => Spec_Id,
4070 Body_Decl => Body_Decl);
4072 -- Otherwise the target is a package or a subprogram
4075 Extract_Package_Or_Subprogram_Attributes
4076 (Spec_Id => Spec_Id,
4077 Body_Decl => Body_Decl);
4080 -- Set all attributes
4082 Attrs.Body_Barf := Body_Barf;
4083 Attrs.Body_Decl := Body_Decl;
4084 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id);
4085 Attrs.From_Source := Comes_From_Source (Target_Id);
4086 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id);
4087 Attrs.SPARK_Mode_On :=
4088 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
4089 Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id);
4090 Attrs.Spec_Id := Spec_Id;
4091 Attrs.Unit_Id := Find_Top_Unit (Target_Id);
4093 -- At this point certain attributes should always be available
4095 pragma Assert (Present (Attrs.Spec_Decl));
4096 pragma Assert (Present (Attrs.Spec_Id));
4097 pragma Assert (Present (Attrs.Unit_Id));
4098 end Extract_Target_Attributes;
4100 -----------------------------
4101 -- Extract_Task_Attributes --
4102 -----------------------------
4104 procedure Extract_Task_Attributes
4106 Attrs : out Task_Attributes)
4108 Task_Typ : constant Entity_Id := Non_Private_View (Typ);
4110 Body_Decl : Node_Id;
4111 Body_Id : Entity_Id;
4113 Spec_Id : Entity_Id;
4116 -- Assume that the body of the task procedure is not available
4120 -- The initial declaration is that of the task body procedure
4122 Spec_Id := Get_Task_Body_Procedure (Task_Typ);
4123 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
4125 if Present (Body_Id) then
4126 Body_Decl := Unit_Declaration_Node (Body_Id);
4129 Prag := SPARK_Pragma (Task_Typ);
4131 -- Set all attributes
4133 Attrs.Body_Decl := Body_Decl;
4134 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ);
4135 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ);
4136 Attrs.SPARK_Mode_On :=
4137 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
4138 Attrs.Spec_Id := Spec_Id;
4139 Attrs.Task_Decl := Declaration_Node (Task_Typ);
4140 Attrs.Unit_Id := Find_Top_Unit (Task_Typ);
4142 -- At this point certain attributes should always be available
4144 pragma Assert (Present (Attrs.Spec_Id));
4145 pragma Assert (Present (Attrs.Task_Decl));
4146 pragma Assert (Present (Attrs.Unit_Id));
4147 end Extract_Task_Attributes;
4149 -------------------------------------------
4150 -- Extract_Variable_Reference_Attributes --
4151 -------------------------------------------
4153 procedure Extract_Variable_Reference_Attributes
4155 Var_Id : out Entity_Id;
4156 Attrs : out Variable_Attributes)
4158 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id;
4159 -- Obtain the ultimate renamed variable of variable Id
4161 --------------------------
4162 -- Get_Renamed_Variable --
4163 --------------------------
4165 function Get_Renamed_Variable (Id : Entity_Id) return Entity_Id is
4170 while Present (Renamed_Entity (Ren_Id))
4171 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity
4173 Ren_Id := Renamed_Entity (Ren_Id);
4177 end Get_Renamed_Variable;
4179 -- Start of processing for Extract_Variable_Reference_Attributes
4182 -- Extraction for variable reference markers
4184 if Nkind (Ref) = N_Variable_Reference_Marker then
4185 Var_Id := Target (Ref);
4187 -- Extraction for expanded names and identifiers
4190 Var_Id := Entity (Ref);
4193 -- Obtain the original variable which the reference mentions
4195 Var_Id := Get_Renamed_Variable (Var_Id);
4196 Attrs.Unit_Id := Find_Top_Unit (Var_Id);
4198 -- At this point certain attributes should always be available
4200 pragma Assert (Present (Attrs.Unit_Id));
4201 end Extract_Variable_Reference_Attributes;
4203 --------------------
4204 -- Find_Code_Unit --
4205 --------------------
4207 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is
4209 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N))));
4212 ----------------------------
4213 -- Find_Early_Call_Region --
4214 ----------------------------
4216 function Find_Early_Call_Region
4217 (Body_Decl : Node_Id;
4218 Assume_Elab_Body : Boolean := False;
4219 Skip_Memoization : Boolean := False) return Node_Id
4221 -- NOTE: The routines within Find_Early_Call_Region are intentionally
4222 -- unnested to avoid deep indentation of code.
4224 ECR_Found : exception;
4225 -- This exception is raised when the early call region has been found
4227 Start : Node_Id := Empty;
4228 -- The start of the early call region. This variable is updated by the
4229 -- various nested routines. Due to the use of exceptions, the variable
4230 -- must be global to the nested routines.
4232 -- The algorithm implemented in this routine attempts to find the early
4233 -- call region of a subprogram body by inspecting constructs in reverse
4234 -- declarative order, while navigating the tree. The algorithm consists
4235 -- of an Inspection phase and an Advancement phase. The pseudocode is as
4240 -- advancement phase
4243 -- The infinite loop is terminated by raising exception ECR_Found. The
4244 -- algorithm utilizes two pointers, Curr and Start, to represent the
4245 -- current construct to inspect and the start of the early call region.
4247 -- IMPORTANT: The algorithm must maintain the following invariant at all
4248 -- time for it to function properly - a nested construct is entered only
4249 -- when it contains suitable constructs. This guarantees that leaving a
4250 -- nested or encapsulating construct functions properly.
4252 -- The Inspection phase determines whether the current construct is non-
4253 -- preelaborable, and if it is, the algorithm terminates.
4255 -- The Advancement phase walks the tree in reverse declarative order,
4256 -- while entering and leaving nested and encapsulating constructs. It
4257 -- may also terminate the elaborithm. There are several special cases
4264 -- <construct N-1> <- Curr
4265 -- <construct N> <- Start
4266 -- <subprogram body>
4268 -- In the general case, a declarative or statement list is traversed in
4269 -- reverse order where Curr is the lead pointer, and Start indicates the
4270 -- last preelaborable construct.
4272 -- 2) Entering handled bodies
4274 -- package body Nested is <- Curr (2.3)
4275 -- <declarations> <- Curr (2.2)
4277 -- <statements> <- Curr (2.1)
4279 -- <construct> <- Start
4281 -- In this case, the algorithm enters a handled body by starting from
4282 -- the last statement (2.1), or the last declaration (2.2), or the body
4283 -- is consumed (2.3) because it is empty and thus preelaborable.
4285 -- 3) Entering package declarations
4287 -- package Nested is <- Curr (2.3)
4288 -- <visible declarations> <- Curr (2.2)
4290 -- <private declarations> <- Curr (2.1)
4292 -- <construct> <- Start
4294 -- In this case, the algorithm enters a package declaration by starting
4295 -- from the last private declaration (2.1), the last visible declaration
4296 -- (2.2), or the package is consumed (2.3) because it is empty and thus
4299 -- 4) Transitioning from list to list of the same construct
4301 -- Certain constructs have two eligible lists. The algorithm must thus
4302 -- transition from the second to the first list when the second list is
4305 -- declare <- Curr (4.2)
4306 -- <declarations> <- Curr (4.1)
4308 -- <statements> <- Start
4311 -- In this case, the algorithm has exhausted the second list (statements
4312 -- in the example), and continues with the last declaration (4.1) or the
4313 -- construct is consumed (4.2) because it contains only preelaborable
4316 -- 5) Transitioning from list to construct
4318 -- tack body Task is <- Curr (5.1)
4320 -- <construct 1> <- Start
4322 -- In this case, the algorithm has exhausted a list, Curr is Empty, and
4323 -- the owner of the list is consumed (5.1).
4325 -- 6) Transitioning from unit to unit
4327 -- A package body with a spec subject to pragma Elaborate_Body extends
4328 -- the possible range of the early call region to the package spec.
4330 -- package Pack is <- Curr (6.3)
4331 -- pragma Elaborate_Body; <- Curr (6.2)
4332 -- <visible declarations> <- Curr (6.2)
4334 -- <private declarations> <- Curr (6.1)
4337 -- package body Pack is <- Curr, Start
4339 -- In this case, the algorithm has reached a package body compilation
4340 -- unit whose spec is subject to pragma Elaborate_Body, or the caller
4341 -- of the algorithm has specified this behavior. This transition is
4342 -- equivalent to 3).
4344 -- 7) Transitioning from unit to termination
4346 -- Reaching a compilation unit always terminates the algorithm as there
4347 -- are no more lists to examine. This must take 6) into account.
4349 -- 8) Transitioning from subunit to stub
4351 -- package body Pack is separate; <- Curr (8.1)
4354 -- package body Pack is <- Curr, Start
4356 -- Reaching a subunit continues the search from the corresponding stub
4359 procedure Advance (Curr : in out Node_Id);
4360 pragma Inline (Advance);
4361 -- Update the Curr and Start pointers depending on their location in the
4362 -- tree to the next eligible construct. This routine raises ECR_Found.
4364 procedure Enter_Handled_Body (Curr : in out Node_Id);
4365 pragma Inline (Enter_Handled_Body);
4366 -- Update the Curr and Start pointers to enter a nested handled body if
4367 -- applicable. This routine raises ECR_Found.
4369 procedure Enter_Package_Declaration (Curr : in out Node_Id);
4370 pragma Inline (Enter_Package_Declaration);
4371 -- Update the Curr and Start pointers to enter a nested package spec if
4372 -- applicable. This routine raises ECR_Found.
4374 function Find_ECR (N : Node_Id) return Node_Id;
4375 pragma Inline (Find_ECR);
4376 -- Find an early call region starting from arbitrary node N
4378 function Has_Suitable_Construct (List : List_Id) return Boolean;
4379 pragma Inline (Has_Suitable_Construct);
4380 -- Determine whether list List contains at least one suitable construct
4381 -- for inclusion into an early call region.
4383 procedure Include (N : Node_Id; Curr : out Node_Id);
4384 pragma Inline (Include);
4385 -- Update the Curr and Start pointers to include arbitrary construct N
4386 -- in the early call region. This routine raises ECR_Found.
4388 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean;
4389 pragma Inline (Is_OK_Preelaborable_Construct);
4390 -- Determine whether arbitrary node N denotes a preelaboration-safe
4393 function Is_Suitable_Construct (N : Node_Id) return Boolean;
4394 pragma Inline (Is_Suitable_Construct);
4395 -- Determine whether arbitrary node N denotes a suitable construct for
4396 -- inclusion into the early call region.
4398 procedure Transition_Body_Declarations
4400 Curr : in out Node_Id);
4401 pragma Inline (Transition_Body_Declarations);
4402 -- Update the Curr and Start pointers when construct Bod denotes a block
4403 -- statement or a suitable body. This routine raises ECR_Found.
4405 procedure Transition_Handled_Statements
4407 Curr : in out Node_Id);
4408 pragma Inline (Transition_Handled_Statements);
4409 -- Update the Curr and Start pointers when node HSS denotes a handled
4410 -- sequence of statements. This routine raises ECR_Found.
4412 procedure Transition_Spec_Declarations
4414 Curr : in out Node_Id);
4415 pragma Inline (Transition_Spec_Declarations);
4416 -- Update the Curr and Start pointers when construct Spec denotes
4417 -- a concurrent definition or a package spec. This routine raises
4420 procedure Transition_Unit (Unit : Node_Id; Curr : in out Node_Id);
4421 pragma Inline (Transition_Unit);
4422 -- Update the Curr and Start pointers when node Unit denotes a potential
4423 -- compilation unit. This routine raises ECR_Found.
4429 procedure Advance (Curr : in out Node_Id) is
4433 -- Curr denotes one of the following cases upon entry into this
4436 -- * Empty - There is no current construct when a declarative or a
4437 -- statement list has been exhausted. This does not necessarily
4438 -- indicate that the early call region has been computed as it
4439 -- may still be possible to transition to another list.
4441 -- * Encapsulator - The current construct encapsulates declarations
4442 -- and/or statements. This indicates that the early call region
4443 -- may extend within the nested construct.
4445 -- * Preelaborable - The current construct is always preelaborable
4446 -- because Find_ECR would not invoke Advance if this was not the
4449 -- The current construct is an encapsulator or is preelaborable
4451 if Present (Curr) then
4453 -- Enter encapsulators by inspecting their declarations and/or
4456 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then
4457 Enter_Handled_Body (Curr);
4459 elsif Nkind (Curr) = N_Package_Declaration then
4460 Enter_Package_Declaration (Curr);
4462 -- Early call regions have a property which can be exploited to
4463 -- optimize the algorithm.
4465 -- <preceding subprogram body>
4466 -- <preelaborable construct 1>
4468 -- <preelaborable construct N>
4469 -- <initiating subprogram body>
4471 -- If a traversal initiated from a subprogram body reaches a
4472 -- preceding subprogram body, then both bodies share the same
4473 -- early call region.
4475 -- The property results in the following desirable effects:
4477 -- * If the preceding body already has an early call region, then
4478 -- the initiating body can reuse it. This minimizes the amount
4479 -- of processing performed by the algorithm.
4481 -- * If the preceding body lack an early call region, then the
4482 -- algorithm can compute the early call region, and reuse it
4483 -- for the initiating body. This processing performs the same
4484 -- amount of work, but has the beneficial effect of computing
4485 -- the early call regions of all preceding bodies.
4487 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then
4489 Find_Early_Call_Region
4491 Assume_Elab_Body => Assume_Elab_Body,
4492 Skip_Memoization => Skip_Memoization);
4496 -- Otherwise current construct is preelaborable. Unpdate the early
4497 -- call region to include it.
4500 Include (Curr, Curr);
4503 -- Otherwise the current construct is missing, indicating that the
4504 -- current list has been exhausted. Depending on the context of the
4505 -- list, several transitions are possible.
4508 -- The invariant of the algorithm ensures that Curr and Start are
4509 -- at the same level of nesting at the point of a transition. The
4510 -- algorithm can determine which list the traversal came from by
4513 Context := Parent (Start);
4515 -- Attempt the following transitions:
4517 -- private declarations -> visible declarations
4518 -- private declarations -> upper level
4519 -- private declarations -> terminate
4520 -- visible declarations -> upper level
4521 -- visible declarations -> terminate
4523 if Nkind_In (Context, N_Package_Specification,
4524 N_Protected_Definition,
4527 Transition_Spec_Declarations (Context, Curr);
4529 -- Attempt the following transitions:
4531 -- statements -> declarations
4532 -- statements -> upper level
4533 -- statements -> corresponding package spec (Elab_Body)
4534 -- statements -> terminate
4536 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
4537 Transition_Handled_Statements (Context, Curr);
4539 -- Attempt the following transitions:
4541 -- declarations -> upper level
4542 -- declarations -> corresponding package spec (Elab_Body)
4543 -- declarations -> terminate
4545 elsif Nkind_In (Context, N_Block_Statement,
4552 Transition_Body_Declarations (Context, Curr);
4554 -- Otherwise it is not possible to transition. Stop the search
4555 -- because there are no more declarations or statements to check.
4563 --------------------------
4564 -- Enter_Handled_Body --
4565 --------------------------
4567 procedure Enter_Handled_Body (Curr : in out Node_Id) is
4568 Decls : constant List_Id := Declarations (Curr);
4569 HSS : constant Node_Id := Handled_Statement_Sequence (Curr);
4570 Stmts : List_Id := No_List;
4573 if Present (HSS) then
4574 Stmts := Statements (HSS);
4577 -- The handled body has a non-empty statement sequence. The construct
4578 -- to inspect is the last statement.
4580 if Has_Suitable_Construct (Stmts) then
4581 Curr := Last (Stmts);
4583 -- The handled body lacks statements, but has non-empty declarations.
4584 -- The construct to inspect is the last declaration.
4586 elsif Has_Suitable_Construct (Decls) then
4587 Curr := Last (Decls);
4589 -- Otherwise the handled body lacks both declarations and statements.
4590 -- The construct to inspect is the node which precedes the handled
4591 -- body. Update the early call region to include the handled body.
4594 Include (Curr, Curr);
4596 end Enter_Handled_Body;
4598 -------------------------------
4599 -- Enter_Package_Declaration --
4600 -------------------------------
4602 procedure Enter_Package_Declaration (Curr : in out Node_Id) is
4603 Pack_Spec : constant Node_Id := Specification (Curr);
4604 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec);
4605 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec);
4608 -- The package has a non-empty private declarations. The construct to
4609 -- inspect is the last private declaration.
4611 if Has_Suitable_Construct (Prv_Decls) then
4612 Curr := Last (Prv_Decls);
4614 -- The package lacks private declarations, but has non-empty visible
4615 -- declarations. In this case the construct to inspect is the last
4616 -- visible declaration.
4618 elsif Has_Suitable_Construct (Vis_Decls) then
4619 Curr := Last (Vis_Decls);
4621 -- Otherwise the package lacks any declarations. The construct to
4622 -- inspect is the node which precedes the package. Update the early
4623 -- call region to include the package declaration.
4626 Include (Curr, Curr);
4628 end Enter_Package_Declaration;
4634 function Find_ECR (N : Node_Id) return Node_Id is
4638 -- The early call region starts at N
4643 -- Inspect each node in reverse declarative order while going in and
4644 -- out of nested and enclosing constructs. Note that the only way to
4645 -- terminate this infinite loop is to raise exception ECR_Found.
4648 -- The current construct is not preelaboration-safe. Terminate the
4652 and then not Is_OK_Preelaborable_Construct (Curr)
4657 -- Advance to the next suitable construct. This may terminate the
4658 -- traversal by raising ECR_Found.
4668 ----------------------------
4669 -- Has_Suitable_Construct --
4670 ----------------------------
4672 function Has_Suitable_Construct (List : List_Id) return Boolean is
4676 -- Examine the list in reverse declarative order, looking for a
4677 -- suitable construct.
4679 if Present (List) then
4680 Item := Last (List);
4681 while Present (Item) loop
4682 if Is_Suitable_Construct (Item) then
4691 end Has_Suitable_Construct;
4697 procedure Include (N : Node_Id; Curr : out Node_Id) is
4701 -- The input node is a compilation unit. This terminates the search
4702 -- because there are no more lists to inspect and there are no more
4703 -- enclosing constructs to climb up to. The transitions are:
4705 -- private declarations -> terminate
4706 -- visible declarations -> terminate
4707 -- statements -> terminate
4708 -- declarations -> terminate
4710 if Nkind (Parent (Start)) = N_Compilation_Unit then
4713 -- Otherwise the input node is still within some list
4716 Curr := Prev (Start);
4720 -----------------------------------
4721 -- Is_OK_Preelaborable_Construct --
4722 -----------------------------------
4724 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is
4726 -- Assignment statements are acceptable as long as they were produced
4727 -- by the ABE mechanism to update elaboration flags.
4729 if Nkind (N) = N_Assignment_Statement then
4730 return Is_Elaboration_Code (N);
4732 -- Block statements are acceptable even though they directly violate
4733 -- preelaborability. The intention is not to penalize the early call
4734 -- region when a block contains only preelaborable constructs.
4737 -- Val : constant Integer := 1;
4739 -- pragma Assert (Val = 1);
4743 -- Note that the Advancement phase does enter blocks, and will detect
4744 -- any non-preelaborable declarations or statements within.
4746 elsif Nkind (N) = N_Block_Statement then
4750 -- Otherwise the construct must be preelaborable. The check must take
4751 -- the syntactic and semantic structure of the construct. DO NOT use
4752 -- Is_Preelaborable_Construct here.
4754 return not Is_Non_Preelaborable_Construct (N);
4755 end Is_OK_Preelaborable_Construct;
4757 ---------------------------
4758 -- Is_Suitable_Construct --
4759 ---------------------------
4761 function Is_Suitable_Construct (N : Node_Id) return Boolean is
4762 Context : constant Node_Id := Parent (N);
4765 -- An internally-generated statement sequence which contains only a
4766 -- single null statement is not a suitable construct because it is a
4767 -- byproduct of the parser. Such a null statement should be excluded
4768 -- from the early call region because it carries the source location
4769 -- of the "end" keyword, and may lead to confusing diagnistics.
4771 if Nkind (N) = N_Null_Statement
4772 and then not Comes_From_Source (N)
4773 and then Present (Context)
4774 and then Nkind (Context) = N_Handled_Sequence_Of_Statements
4775 and then not Comes_From_Source (N)
4780 -- Otherwise only constructs which correspond to pure Ada constructs
4781 -- are considered suitable.
4786 | N_Freeze_Generic_Entity
4787 | N_Implicit_Label_Declaration
4789 | N_Pop_Constraint_Error_Label
4790 | N_Pop_Program_Error_Label
4791 | N_Pop_Storage_Error_Label
4792 | N_Push_Constraint_Error_Label
4793 | N_Push_Program_Error_Label
4794 | N_Push_Storage_Error_Label
4795 | N_SCIL_Dispatch_Table_Tag_Init
4796 | N_SCIL_Dispatching_Call
4797 | N_SCIL_Membership_Test
4798 | N_Variable_Reference_Marker
4805 end Is_Suitable_Construct;
4807 ----------------------------------
4808 -- Transition_Body_Declarations --
4809 ----------------------------------
4811 procedure Transition_Body_Declarations
4813 Curr : in out Node_Id)
4815 Decls : constant List_Id := Declarations (Bod);
4818 -- The search must come from the declarations of the body
4821 (Is_Non_Empty_List (Decls)
4822 and then List_Containing (Start) = Decls);
4824 -- The search finished inspecting the declarations. The construct
4825 -- to inspect is the node which precedes the handled body, unless
4826 -- the body is a compilation unit. The transitions are:
4828 -- declarations -> upper level
4829 -- declarations -> corresponding package spec (Elab_Body)
4830 -- declarations -> terminate
4832 Transition_Unit (Bod, Curr);
4833 end Transition_Body_Declarations;
4835 -----------------------------------
4836 -- Transition_Handled_Statements --
4837 -----------------------------------
4839 procedure Transition_Handled_Statements
4841 Curr : in out Node_Id)
4843 Bod : constant Node_Id := Parent (HSS);
4844 Decls : constant List_Id := Declarations (Bod);
4845 Stmts : constant List_Id := Statements (HSS);
4848 -- The search must come from the statements of certain bodies or
4851 pragma Assert (Nkind_In (Bod, N_Block_Statement,
4858 -- The search must come from the statements of the handled sequence
4861 (Is_Non_Empty_List (Stmts)
4862 and then List_Containing (Start) = Stmts);
4864 -- The search finished inspecting the statements. The handled body
4865 -- has non-empty declarations. The construct to inspect is the last
4866 -- declaration. The transitions are:
4868 -- statements -> declarations
4870 if Has_Suitable_Construct (Decls) then
4871 Curr := Last (Decls);
4873 -- Otherwise the handled body lacks declarations. The construct to
4874 -- inspect is the node which precedes the handled body, unless the
4875 -- body is a compilation unit. The transitions are:
4877 -- statements -> upper level
4878 -- statements -> corresponding package spec (Elab_Body)
4879 -- statements -> terminate
4882 Transition_Unit (Bod, Curr);
4884 end Transition_Handled_Statements;
4886 ----------------------------------
4887 -- Transition_Spec_Declarations --
4888 ----------------------------------
4890 procedure Transition_Spec_Declarations
4892 Curr : in out Node_Id)
4894 Prv_Decls : constant List_Id := Private_Declarations (Spec);
4895 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
4898 pragma Assert (Present (Start) and then Is_List_Member (Start));
4900 -- The search came from the private declarations and finished their
4903 if Has_Suitable_Construct (Prv_Decls)
4904 and then List_Containing (Start) = Prv_Decls
4906 -- The context has non-empty visible declarations. The node to
4907 -- inspect is the last visible declaration. The transitions are:
4909 -- private declarations -> visible declarations
4911 if Has_Suitable_Construct (Vis_Decls) then
4912 Curr := Last (Vis_Decls);
4914 -- Otherwise the context lacks visible declarations. The construct
4915 -- to inspect is the node which precedes the context unless the
4916 -- context is a compilation unit. The transitions are:
4918 -- private declarations -> upper level
4919 -- private declarations -> terminate
4922 Transition_Unit (Parent (Spec), Curr);
4925 -- The search came from the visible declarations and finished their
4926 -- inspections. The construct to inspect is the node which precedes
4927 -- the context, unless the context is a compilaton unit. The
4930 -- visible declarations -> upper level
4931 -- visible declarations -> terminate
4933 elsif Has_Suitable_Construct (Vis_Decls)
4934 and then List_Containing (Start) = Vis_Decls
4936 Transition_Unit (Parent (Spec), Curr);
4938 -- At this point both declarative lists are empty, but the traversal
4939 -- still came from within the spec. This indicates that the invariant
4940 -- of the algorithm has been violated.
4943 pragma Assert (False);
4946 end Transition_Spec_Declarations;
4948 ---------------------
4949 -- Transition_Unit --
4950 ---------------------
4952 procedure Transition_Unit
4954 Curr : in out Node_Id)
4956 Context : constant Node_Id := Parent (Unit);
4959 -- The unit is a compilation unit. This terminates the search because
4960 -- there are no more lists to inspect and there are no more enclosing
4961 -- constructs to climb up to.
4963 if Nkind (Context) = N_Compilation_Unit then
4965 -- A package body with a corresponding spec subject to pragma
4966 -- Elaborate_Body is an exception to the above. The annotation
4967 -- allows the search to continue into the package declaration.
4968 -- The transitions are:
4970 -- statements -> corresponding package spec (Elab_Body)
4971 -- declarations -> corresponding package spec (Elab_Body)
4973 if Nkind (Unit) = N_Package_Body
4974 and then (Assume_Elab_Body
4975 or else Has_Pragma_Elaborate_Body
4976 (Corresponding_Spec (Unit)))
4978 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit));
4979 Enter_Package_Declaration (Curr);
4981 -- Otherwise terminate the search. The transitions are:
4983 -- private declarations -> terminate
4984 -- visible declarations -> terminate
4985 -- statements -> terminate
4986 -- declarations -> terminate
4992 -- The unit is a subunit. The construct to inspect is the node which
4993 -- precedes the corresponding stub. Update the early call region to
4994 -- include the unit.
4996 elsif Nkind (Context) = N_Subunit then
4998 Curr := Corresponding_Stub (Context);
5000 -- Otherwise the unit is nested. The construct to inspect is the node
5001 -- which precedes the unit. Update the early call region to include
5005 Include (Unit, Curr);
5007 end Transition_Unit;
5011 Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
5014 -- Start of processing for Find_Early_Call_Region
5017 -- The caller demands the start of the early call region without saving
5018 -- or retrieving it to/from internal data structures.
5020 if Skip_Memoization then
5021 Region := Find_ECR (Body_Decl);
5026 -- Check whether the early call region of the subprogram body is
5029 Region := Early_Call_Region (Body_Id);
5033 -- Traverse the declarations in reverse order, starting from the
5034 -- subprogram body, searching for the nearest non-preelaborable
5035 -- construct. The early call region starts after this construct
5036 -- and ends at the subprogram body.
5038 Region := Find_ECR (Body_Decl);
5040 -- Associate the early call region with the subprogram body in
5041 -- case other scenarios need it.
5043 Set_Early_Call_Region (Body_Id, Region);
5047 -- A subprogram body must always have an early call region
5049 pragma Assert (Present (Region));
5052 end Find_Early_Call_Region;
5054 ---------------------------
5055 -- Find_Elaborated_Units --
5056 ---------------------------
5058 procedure Find_Elaborated_Units is
5059 procedure Add_Pragma (Prag : Node_Id);
5060 -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma.
5061 -- If this is the case, add the related unit to the elaboration context.
5062 -- For pragma Elaborate_All, include recursively all units withed by the
5066 (Unit_Id : Entity_Id;
5068 Full_Context : Boolean);
5069 -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma
5070 -- which prompted the inclusion of the unit to the elaboration context.
5071 -- If flag Full_Context is set, examine the nonlimited clauses of unit
5072 -- Unit_Id and add each withed unit to the context.
5074 procedure Find_Elaboration_Context (Comp_Unit : Node_Id);
5075 -- Examine the context items of compilation unit Comp_Unit for suitable
5076 -- elaboration-related pragmas and add all related units to the context.
5082 procedure Add_Pragma (Prag : Node_Id) is
5083 Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag);
5084 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
5088 -- Nothing to do if the pragma is not related to elaboration
5090 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then
5093 -- Nothing to do when the pragma is illegal
5095 elsif Error_Posted (Prag) then
5099 Unit_Arg := Get_Pragma_Arg (First (Prag_Args));
5101 -- The argument of the pragma may appear in package.package form
5103 if Nkind (Unit_Arg) = N_Selected_Component then
5104 Unit_Arg := Selector_Name (Unit_Arg);
5108 (Unit_Id => Entity (Unit_Arg),
5110 Full_Context => Prag_Nam = Name_Elaborate_All);
5118 (Unit_Id : Entity_Id;
5120 Full_Context : Boolean)
5123 Elab_Attrs : Elaboration_Attributes;
5126 -- Nothing to do when some previous error left a with clause or a
5127 -- pragma in a bad state.
5129 if No (Unit_Id) then
5133 Elab_Attrs := Elaboration_Status (Unit_Id);
5135 -- The unit is already included in the context by means of pragma
5138 if Present (Elab_Attrs.Source_Pragma) then
5140 -- Upgrade an existing pragma Elaborate when the unit is subject
5141 -- to Elaborate_All because the new pragma covers a larger set of
5144 if Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate
5145 and then Pragma_Name (Prag) = Name_Elaborate_All
5147 Elab_Attrs.Source_Pragma := Prag;
5149 -- Otherwise the unit retains its existing pragma and does not
5150 -- need to be included in the context again.
5156 -- The current unit is not part of the context. Prepare a new set of
5161 Elaboration_Attributes'(Source_Pragma
=> Prag
,
5162 With_Clause
=> Empty
);
5165 -- Add or update the attributes of the unit
5167 Set_Elaboration_Status
(Unit_Id
, Elab_Attrs
);
5169 -- Includes all units withed by the current one when computing the
5172 if Full_Context
then
5174 -- Process all nonlimited with clauses found in the context of
5175 -- the current unit. Note that limited clauses do not impose an
5176 -- elaboration order.
5178 Clause
:= First
(Context_Items
(Compilation_Unit
(Unit_Id
)));
5179 while Present
(Clause
) loop
5180 if Nkind
(Clause
) = N_With_Clause
5181 and then not Error_Posted
(Clause
)
5182 and then not Limited_Present
(Clause
)
5185 (Unit_Id
=> Entity
(Name
(Clause
)),
5187 Full_Context
=> Full_Context
);
5195 ------------------------------
5196 -- Find_Elaboration_Context --
5197 ------------------------------
5199 procedure Find_Elaboration_Context
(Comp_Unit
: Node_Id
) is
5203 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
5205 -- Process all elaboration-related pragmas found in the context of
5206 -- the compilation unit.
5208 Prag
:= First
(Context_Items
(Comp_Unit
));
5209 while Present
(Prag
) loop
5210 if Nkind
(Prag
) = N_Pragma
then
5216 end Find_Elaboration_Context
;
5223 -- Start of processing for Find_Elaborated_Units
5226 -- Perform a traversal which examines the context of the main unit and
5227 -- populates the Elaboration_Context table with all units elaborated
5228 -- prior to the main unit. The traversal performs the following jumps:
5230 -- subunit -> parent subunit
5231 -- parent subunit -> body
5233 -- spec -> parent spec
5234 -- parent spec -> grandparent spec and so on
5236 -- The traversal relies on units rather than scopes because the scope of
5237 -- a subunit is some spec, while this traversal must process the body as
5238 -- well. Given that protected and task bodies can also be subunits, this
5239 -- complicates the scope approach even further.
5241 Unt
:= Unit
(Cunit
(Main_Unit
));
5243 -- Perform the following traversals when the main unit is a subunit
5245 -- subunit -> parent subunit
5246 -- parent subunit -> body
5248 while Present
(Unt
) and then Nkind
(Unt
) = N_Subunit
loop
5249 Find_Elaboration_Context
(Parent
(Unt
));
5251 -- Continue the traversal by going to the unit which contains the
5252 -- corresponding stub.
5254 if Present
(Corresponding_Stub
(Unt
)) then
5255 Unt
:= Unit
(Cunit
(Get_Source_Unit
(Corresponding_Stub
(Unt
))));
5257 -- Otherwise the subunit may be erroneous or left in a bad state
5264 -- Perform the following traversal now that subunits have been taken
5265 -- care of, or the main unit is a body.
5270 and then Nkind_In
(Unt
, N_Package_Body
, N_Subprogram_Body
)
5272 Find_Elaboration_Context
(Parent
(Unt
));
5274 -- Continue the traversal by going to the unit which contains the
5275 -- corresponding spec.
5277 if Present
(Corresponding_Spec
(Unt
)) then
5278 Unt
:= Unit
(Cunit
(Get_Source_Unit
(Corresponding_Spec
(Unt
))));
5282 -- Perform the following traversals now that the body has been taken
5283 -- care of, or the main unit is a spec.
5285 -- spec -> parent spec
5286 -- parent spec -> grandparent spec and so on
5289 and then Nkind_In
(Unt
, N_Generic_Package_Declaration
,
5290 N_Generic_Subprogram_Declaration
,
5291 N_Package_Declaration
,
5292 N_Subprogram_Declaration
)
5294 Find_Elaboration_Context
(Parent
(Unt
));
5296 -- Process a potential chain of parent units which ends with the
5297 -- main unit spec. The traversal can now safely rely on the scope
5300 Par_Id
:= Scope
(Defining_Entity
(Unt
));
5301 while Present
(Par_Id
) and then Par_Id
/= Standard_Standard
loop
5302 Find_Elaboration_Context
(Compilation_Unit
(Par_Id
));
5304 Par_Id
:= Scope
(Par_Id
);
5307 end Find_Elaborated_Units
;
5309 -----------------------------
5310 -- Find_Enclosing_Instance --
5311 -----------------------------
5313 function Find_Enclosing_Instance
(N
: Node_Id
) return Node_Id
is
5315 Spec_Id
: Entity_Id
;
5318 -- Climb the parent chain looking for an enclosing instance spec or body
5321 while Present
(Par
) loop
5323 -- Generic package or subprogram spec
5325 if Nkind_In
(Par
, N_Package_Declaration
,
5326 N_Subprogram_Declaration
)
5327 and then Is_Generic_Instance
(Defining_Entity
(Par
))
5331 -- Generic package or subprogram body
5333 elsif Nkind_In
(Par
, N_Package_Body
, N_Subprogram_Body
) then
5334 Spec_Id
:= Corresponding_Spec
(Par
);
5336 if Present
(Spec_Id
) and then Is_Generic_Instance
(Spec_Id
) then
5341 Par
:= Parent
(Par
);
5345 end Find_Enclosing_Instance
;
5347 --------------------------
5348 -- Find_Enclosing_Level --
5349 --------------------------
5351 function Find_Enclosing_Level
(N
: Node_Id
) return Enclosing_Level_Kind
is
5352 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
;
5353 -- Obtain the corresponding level of unit Unit
5359 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
is
5360 Spec_Id
: Entity_Id
;
5363 if Nkind
(Unit
) in N_Generic_Instantiation
then
5364 return Instantiation
;
5366 elsif Nkind
(Unit
) = N_Generic_Package_Declaration
then
5367 return Generic_Package_Spec
;
5369 elsif Nkind
(Unit
) = N_Package_Declaration
then
5370 return Package_Spec
;
5372 elsif Nkind
(Unit
) = N_Package_Body
then
5373 Spec_Id
:= Corresponding_Spec
(Unit
);
5375 -- The body belongs to a generic package
5377 if Present
(Spec_Id
)
5378 and then Ekind
(Spec_Id
) = E_Generic_Package
5380 return Generic_Package_Body
;
5382 -- Otherwise the body belongs to a non-generic package. This also
5383 -- treats an illegal package body without a corresponding spec as
5384 -- a non-generic package body.
5387 return Package_Body
;
5400 -- Start of processing for Find_Enclosing_Level
5403 -- Call markers and instantiations which appear at the declaration level
5404 -- but are later relocated in a different context retain their original
5405 -- declaration level.
5407 if Nkind_In
(N
, N_Call_Marker
,
5408 N_Function_Instantiation
,
5409 N_Package_Instantiation
,
5410 N_Procedure_Instantiation
)
5411 and then Is_Declaration_Level_Node
(N
)
5413 return Declaration_Level
;
5416 -- Climb the parent chain looking at the enclosing levels
5419 Curr
:= Parent
(Prev
);
5420 while Present
(Curr
) loop
5422 -- A traversal from a subunit continues via the corresponding stub
5424 if Nkind
(Curr
) = N_Subunit
then
5425 Curr
:= Corresponding_Stub
(Curr
);
5427 -- The current construct is a package. Packages are ignored because
5428 -- they are always elaborated when the enclosing context is invoked
5431 elsif Nkind_In
(Curr
, N_Package_Body
, N_Package_Declaration
) then
5434 -- The current construct is a block statement
5436 elsif Nkind
(Curr
) = N_Block_Statement
then
5438 -- Ignore internally generated blocks created by the expander for
5439 -- various purposes such as abort defer/undefer.
5441 if not Comes_From_Source
(Curr
) then
5444 -- If the traversal came from the handled sequence of statments,
5445 -- then the node appears at the level of the enclosing construct.
5446 -- This is a more reliable test because transients scopes within
5447 -- the declarative region of the encapsulator are hard to detect.
5449 elsif Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
5450 and then Handled_Statement_Sequence
(Curr
) = Prev
5452 return Find_Enclosing_Level
(Parent
(Curr
));
5454 -- Otherwise the traversal came from the declarations, the node is
5455 -- at the declaration level.
5458 return Declaration_Level
;
5461 -- The current construct is a declaration-level encapsulator
5463 elsif Nkind_In
(Curr
, N_Entry_Body
,
5467 -- If the traversal came from the handled sequence of statments,
5468 -- then the node cannot possibly appear at any level. This is
5469 -- a more reliable test because transients scopes within the
5470 -- declarative region of the encapsulator are hard to detect.
5472 if Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
5473 and then Handled_Statement_Sequence
(Curr
) = Prev
5477 -- Otherwise the traversal came from the declarations, the node is
5478 -- at the declaration level.
5481 return Declaration_Level
;
5484 -- The current construct is a non-library-level encapsulator which
5485 -- indicates that the node cannot possibly appear at any level.
5486 -- Note that this check must come after the declaration-level check
5487 -- because both predicates share certain nodes.
5489 elsif Is_Non_Library_Level_Encapsulator
(Curr
) then
5490 Context
:= Parent
(Curr
);
5492 -- The sole exception is when the encapsulator is the compilation
5493 -- utit itself because the compilation unit node requires special
5494 -- processing (see below).
5496 if Present
(Context
)
5497 and then Nkind
(Context
) = N_Compilation_Unit
5501 -- Otherwise the node is not at any level
5507 -- The current construct is a compilation unit. The node appears at
5508 -- the [generic] library level when the unit is a [generic] package.
5510 elsif Nkind
(Curr
) = N_Compilation_Unit
then
5511 return Level_Of
(Unit
(Curr
));
5515 Curr
:= Parent
(Prev
);
5519 end Find_Enclosing_Level
;
5525 function Find_Top_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
is
5527 return Find_Unit_Entity
(Unit
(Cunit
(Get_Top_Level_Code_Unit
(N
))));
5530 ----------------------
5531 -- Find_Unit_Entity --
5532 ----------------------
5534 function Find_Unit_Entity
(N
: Node_Id
) return Entity_Id
is
5535 Context
: constant Node_Id
:= Parent
(N
);
5536 Orig_N
: constant Node_Id
:= Original_Node
(N
);
5539 -- The unit denotes a package body of an instantiation which acts as
5540 -- a compilation unit. The proper entity is that of the package spec.
5542 if Nkind
(N
) = N_Package_Body
5543 and then Nkind
(Orig_N
) = N_Package_Instantiation
5544 and then Nkind
(Context
) = N_Compilation_Unit
5546 return Corresponding_Spec
(N
);
5548 -- The unit denotes an anonymous package created to wrap a subprogram
5549 -- instantiation which acts as a compilation unit. The proper entity is
5550 -- that of the "related instance".
5552 elsif Nkind
(N
) = N_Package_Declaration
5553 and then Nkind_In
(Orig_N
, N_Function_Instantiation
,
5554 N_Procedure_Instantiation
)
5555 and then Nkind
(Context
) = N_Compilation_Unit
5558 Related_Instance
(Defining_Entity
(N
, Concurrent_Subunit
=> True));
5560 -- Otherwise the proper entity is the defining entity
5563 return Defining_Entity
(N
, Concurrent_Subunit
=> True);
5565 end Find_Unit_Entity
;
5567 -----------------------
5568 -- First_Formal_Type --
5569 -----------------------
5571 function First_Formal_Type
(Subp_Id
: Entity_Id
) return Entity_Id
is
5572 Formal_Id
: constant Entity_Id
:= First_Formal
(Subp_Id
);
5576 if Present
(Formal_Id
) then
5577 Typ
:= Etype
(Formal_Id
);
5579 -- Handle various combinations of concurrent and private types
5582 if Ekind_In
(Typ
, E_Protected_Type
, E_Task_Type
)
5583 and then Present
(Anonymous_Object
(Typ
))
5585 Typ
:= Anonymous_Object
(Typ
);
5587 elsif Is_Concurrent_Record_Type
(Typ
) then
5588 Typ
:= Corresponding_Concurrent_Type
(Typ
);
5590 elsif Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
5591 Typ
:= Full_View
(Typ
);
5602 end First_Formal_Type
;
5608 function Has_Body
(Pack_Decl
: Node_Id
) return Boolean is
5609 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
;
5610 -- Try to locate the corresponding body of spec Spec_Id. If no body is
5611 -- found, return Empty.
5614 (Spec_Id
: Entity_Id
;
5615 From
: Node_Id
) return Node_Id
;
5616 -- Try to locate the corresponding body of spec Spec_Id in the node list
5617 -- which follows arbitrary node From. If no body is found, return Empty.
5619 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
;
5620 -- Attempt to load the body of unit Unit_Nam. If the load failed, return
5621 -- Empty. If the compilation will not generate code, return Empty.
5623 -----------------------------
5624 -- Find_Corresponding_Body --
5625 -----------------------------
5627 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
is
5628 Context
: constant Entity_Id
:= Scope
(Spec_Id
);
5629 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
5630 Body_Decl
: Node_Id
;
5631 Body_Id
: Entity_Id
;
5634 if Is_Compilation_Unit
(Spec_Id
) then
5635 Body_Id
:= Corresponding_Body
(Spec_Decl
);
5637 if Present
(Body_Id
) then
5638 return Unit_Declaration_Node
(Body_Id
);
5640 -- The package is at the library and requires a body. Load the
5641 -- corresponding body because the optional body may be declared
5644 elsif Unit_Requires_Body
(Spec_Id
) then
5647 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec_Decl
))));
5649 -- Otherwise there is no optional body
5655 -- The immediate context is a package. The optional body may be
5656 -- within the body of that package.
5658 -- procedure Proc is
5659 -- package Nested_1 is
5660 -- package Nested_2 is
5667 -- package body Nested_1 is
5668 -- package body Nested_2 is separate;
5671 -- separate (Proc.Nested_1.Nested_2)
5672 -- package body Nested_2 is
5673 -- package body Pack is -- optional body
5678 elsif Is_Package_Or_Generic_Package
(Context
) then
5679 Body_Decl
:= Find_Corresponding_Body
(Context
);
5681 -- The optional body is within the body of the enclosing package
5683 if Present
(Body_Decl
) then
5686 (Spec_Id
=> Spec_Id
,
5687 From
=> First
(Declarations
(Body_Decl
)));
5689 -- Otherwise the enclosing package does not have a body. This may
5690 -- be the result of an error or a genuine lack of a body.
5696 -- Otherwise the immediate context is a body. The optional body may
5697 -- be within the same list as the spec.
5699 -- procedure Proc is
5704 -- package body Pack is -- optional body
5711 (Spec_Id
=> Spec_Id
,
5712 From
=> Next
(Spec_Decl
));
5714 end Find_Corresponding_Body
;
5721 (Spec_Id
: Entity_Id
;
5722 From
: Node_Id
) return Node_Id
5724 Spec_Nam
: constant Name_Id
:= Chars
(Spec_Id
);
5730 while Present
(Item
) loop
5732 -- The current item denotes the optional body
5734 if Nkind
(Item
) = N_Package_Body
5735 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
5739 -- The current item denotes a stub, the optional body may be in
5742 elsif Nkind
(Item
) = N_Package_Body_Stub
5743 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
5745 Lib_Unit
:= Library_Unit
(Item
);
5747 -- The corresponding subunit was previously loaded
5749 if Present
(Lib_Unit
) then
5752 -- Otherwise attempt to load the corresponding subunit
5755 return Load_Package_Body
(Get_Unit_Name
(Item
));
5765 -----------------------
5766 -- Load_Package_Body --
5767 -----------------------
5769 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
is
5770 Body_Decl
: Node_Id
;
5771 Unit_Num
: Unit_Number_Type
;
5774 -- The load is performed only when the compilation will generate code
5776 if Operating_Mode
= Generate_Code
then
5779 (Load_Name
=> Unit_Nam
,
5782 Error_Node
=> Pack_Decl
);
5784 -- The load failed most likely because the physical file is
5787 if Unit_Num
= No_Unit
then
5790 -- Otherwise the load was successful, return the body of the unit
5793 Body_Decl
:= Unit
(Cunit
(Unit_Num
));
5795 -- If the unit is a subunit with an available proper body,
5796 -- return the proper body.
5798 if Nkind
(Body_Decl
) = N_Subunit
5799 and then Present
(Proper_Body
(Body_Decl
))
5801 Body_Decl
:= Proper_Body
(Body_Decl
);
5809 end Load_Package_Body
;
5813 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
5815 -- Start of processing for Has_Body
5818 -- The body is available
5820 if Present
(Corresponding_Body
(Pack_Decl
)) then
5823 -- The body is required if the package spec contains a construct which
5824 -- requires a completion in a body.
5826 elsif Unit_Requires_Body
(Pack_Id
) then
5829 -- The body may be optional
5832 return Present
(Find_Corresponding_Body
(Pack_Id
));
5836 ---------------------------
5837 -- Has_Prior_Elaboration --
5838 ---------------------------
5840 function Has_Prior_Elaboration
5841 (Unit_Id
: Entity_Id
;
5842 Context_OK
: Boolean := False;
5843 Elab_Body_OK
: Boolean := False;
5844 Same_Unit_OK
: Boolean := False) return Boolean
5846 Main_Id
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
5849 -- A preelaborated unit is always elaborated prior to the main unit
5851 if Is_Preelaborated_Unit
(Unit_Id
) then
5854 -- An internal unit is always elaborated prior to a non-internal main
5857 elsif In_Internal_Unit
(Unit_Id
)
5858 and then not In_Internal_Unit
(Main_Id
)
5862 -- A unit has prior elaboration if it appears within the context of the
5863 -- main unit. Consider this case only when requested by the caller.
5866 and then Elaboration_Status
(Unit_Id
) /= No_Elaboration_Attributes
5870 -- A unit whose body is elaborated together with its spec has prior
5871 -- elaboration except with respect to itself. Consider this case only
5872 -- when requested by the caller.
5875 and then Has_Pragma_Elaborate_Body
(Unit_Id
)
5876 and then not Is_Same_Unit
(Unit_Id
, Main_Id
)
5880 -- A unit has no prior elaboration with respect to itself, but does not
5881 -- require any means of ensuring its own elaboration either. Treat this
5882 -- case as valid prior elaboration only when requested by the caller.
5884 elsif Same_Unit_OK
and then Is_Same_Unit
(Unit_Id
, Main_Id
) then
5889 end Has_Prior_Elaboration
;
5891 --------------------------
5892 -- In_External_Instance --
5893 --------------------------
5895 function In_External_Instance
5897 Target_Decl
: Node_Id
) return Boolean
5900 Inst_Body
: Node_Id
;
5901 Inst_Decl
: Node_Id
;
5904 -- Performance note: parent traversal
5906 Inst_Decl
:= Find_Enclosing_Instance
(Target_Decl
);
5908 -- The target declaration appears within an instance spec. Visibility is
5909 -- ignored because internally generated primitives for private types may
5910 -- reside in the private declarations and still be invoked from outside.
5912 if Present
(Inst_Decl
)
5913 and then Nkind
(Inst_Decl
) = N_Package_Declaration
5915 -- The scenario comes from the main unit and the instance does not
5917 if In_Extended_Main_Code_Unit
(N
)
5918 and then not In_Extended_Main_Code_Unit
(Inst_Decl
)
5922 -- Otherwise the scenario must not appear within the instance spec or
5926 Extract_Instance_Attributes
5927 (Exp_Inst
=> Inst_Decl
,
5928 Inst_Body
=> Inst_Body
,
5929 Inst_Decl
=> Dummy
);
5931 -- Performance note: parent traversal
5933 return not In_Subtree
5936 Root2
=> Inst_Body
);
5941 end In_External_Instance
;
5943 ---------------------
5944 -- In_Main_Context --
5945 ---------------------
5947 function In_Main_Context
(N
: Node_Id
) return Boolean is
5949 -- Scenarios outside the main unit are not considered because the ALI
5950 -- information supplied to binde is for the main unit only.
5952 if not In_Extended_Main_Code_Unit
(N
) then
5955 -- Scenarios within internal units are not considered unless switch
5956 -- -gnatdE (elaboration checks on predefined units) is in effect.
5958 elsif not Debug_Flag_EE
and then In_Internal_Unit
(N
) then
5963 end In_Main_Context
;
5965 ---------------------
5966 -- In_Same_Context --
5967 ---------------------
5969 function In_Same_Context
5972 Nested_OK
: Boolean := False) return Boolean
5974 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
;
5975 -- Return the nearest enclosing non-library-level or compilation unit
5976 -- node which which encapsulates arbitrary node N. Return Empty is no
5977 -- such context is available.
5979 function In_Nested_Context
5981 Inner
: Node_Id
) return Boolean;
5982 -- Determine whether arbitrary node Outer encapsulates arbitrary node
5985 ----------------------------
5986 -- Find_Enclosing_Context --
5987 ----------------------------
5989 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
is
5995 while Present
(Par
) loop
5997 -- A traversal from a subunit continues via the corresponding stub
5999 if Nkind
(Par
) = N_Subunit
then
6000 Par
:= Corresponding_Stub
(Par
);
6002 -- Stop the traversal when the nearest enclosing non-library-level
6003 -- encapsulator has been reached.
6005 elsif Is_Non_Library_Level_Encapsulator
(Par
) then
6006 Context
:= Parent
(Par
);
6008 -- The sole exception is when the encapsulator is the unit of
6009 -- compilation because this case requires special processing
6012 if Present
(Context
)
6013 and then Nkind
(Context
) = N_Compilation_Unit
6021 -- Reaching a compilation unit node without hitting a non-library-
6022 -- level encapsulator indicates that N is at the library level in
6023 -- which case the compilation unit is the context.
6025 elsif Nkind
(Par
) = N_Compilation_Unit
then
6029 Par
:= Parent
(Par
);
6033 end Find_Enclosing_Context
;
6035 -----------------------
6036 -- In_Nested_Context --
6037 -----------------------
6039 function In_Nested_Context
6041 Inner
: Node_Id
) return Boolean
6047 while Present
(Par
) loop
6049 -- A traversal from a subunit continues via the corresponding stub
6051 if Nkind
(Par
) = N_Subunit
then
6052 Par
:= Corresponding_Stub
(Par
);
6054 elsif Par
= Outer
then
6058 Par
:= Parent
(Par
);
6062 end In_Nested_Context
;
6066 Context_1
: constant Node_Id
:= Find_Enclosing_Context
(N1
);
6067 Context_2
: constant Node_Id
:= Find_Enclosing_Context
(N2
);
6069 -- Start of processing for In_Same_Context
6072 -- Both nodes appear within the same context
6074 if Context_1
= Context_2
then
6077 -- Both nodes appear in compilation units. Determine whether one unit
6078 -- is the body of the other.
6080 elsif Nkind
(Context_1
) = N_Compilation_Unit
6081 and then Nkind
(Context_2
) = N_Compilation_Unit
6085 (Unit_1
=> Defining_Entity
(Unit
(Context_1
)),
6086 Unit_2
=> Defining_Entity
(Unit
(Context_2
)));
6088 -- The context of N1 encloses the context of N2
6090 elsif Nested_OK
and then In_Nested_Context
(Context_1
, Context_2
) then
6095 end In_Same_Context
;
6101 procedure Initialize
is
6103 -- Set the soft link which enables Atree.Rewrite to update a top-level
6104 -- scenario each time it is transformed into another node.
6106 Set_Rewriting_Proc
(Update_Elaboration_Scenario
'Access);
6115 Target_Id
: Entity_Id
;
6119 procedure Info_Accept_Alternative
;
6120 pragma Inline
(Info_Accept_Alternative
);
6121 -- Output information concerning an accept alternative
6123 procedure Info_Simple_Call
;
6124 pragma Inline
(Info_Simple_Call
);
6125 -- Output information concerning the call
6127 procedure Info_Type_Actions
(Action
: String);
6128 pragma Inline
(Info_Type_Actions
);
6129 -- Output information concerning action Action of a type
6131 procedure Info_Verification_Call
6135 pragma Inline
(Info_Verification_Call
);
6136 -- Output information concerning the verification of predicate Pred
6137 -- applied to related entity Id with kind Id_Kind.
6139 -----------------------------
6140 -- Info_Accept_Alternative --
6141 -----------------------------
6143 procedure Info_Accept_Alternative
is
6144 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Target_Id
);
6147 pragma Assert
(Present
(Entry_Id
));
6150 (Msg
=> "accept for entry & during elaboration",
6153 Info_Msg
=> Info_Msg
,
6154 In_SPARK
=> In_SPARK
);
6155 end Info_Accept_Alternative
;
6157 ----------------------
6158 -- Info_Simple_Call --
6159 ----------------------
6161 procedure Info_Simple_Call
is
6164 (Msg
=> "call to & during elaboration",
6167 Info_Msg
=> Info_Msg
,
6168 In_SPARK
=> In_SPARK
);
6169 end Info_Simple_Call
;
6171 -----------------------
6172 -- Info_Type_Actions --
6173 -----------------------
6175 procedure Info_Type_Actions
(Action
: String) is
6176 Typ
: constant Entity_Id
:= First_Formal_Type
(Target_Id
);
6179 pragma Assert
(Present
(Typ
));
6182 (Msg
=> Action
& " actions for type & during elaboration",
6185 Info_Msg
=> Info_Msg
,
6186 In_SPARK
=> In_SPARK
);
6187 end Info_Type_Actions
;
6189 ----------------------------
6190 -- Info_Verification_Call --
6191 ----------------------------
6193 procedure Info_Verification_Call
6199 pragma Assert
(Present
(Id
));
6203 "verification of " & Pred
& " of " & Id_Kind
& " & during "
6207 Info_Msg
=> Info_Msg
,
6208 In_SPARK
=> In_SPARK
);
6209 end Info_Verification_Call
;
6211 -- Start of processing for Info_Call
6214 -- Do not output anything for targets defined in internal units because
6215 -- this creates noise.
6217 if not In_Internal_Unit
(Target_Id
) then
6219 -- Accept alternative
6221 if Is_Accept_Alternative_Proc
(Target_Id
) then
6222 Info_Accept_Alternative
;
6226 elsif Is_TSS
(Target_Id
, TSS_Deep_Adjust
) then
6227 Info_Type_Actions
("adjustment");
6229 -- Default_Initial_Condition
6231 elsif Is_Default_Initial_Condition_Proc
(Target_Id
) then
6232 Info_Verification_Call
6233 (Pred
=> "Default_Initial_Condition",
6234 Id
=> First_Formal_Type
(Target_Id
),
6239 elsif Is_Protected_Entry
(Target_Id
) then
6242 -- Task entry calls are never processed because the entry being
6243 -- invoked does not have a corresponding "body", it has a select.
6245 elsif Is_Task_Entry
(Target_Id
) then
6250 elsif Is_TSS
(Target_Id
, TSS_Deep_Finalize
) then
6251 Info_Type_Actions
("finalization");
6253 -- Calls to _Finalizer procedures must not appear in the output
6254 -- because this creates confusing noise.
6256 elsif Is_Finalizer_Proc
(Target_Id
) then
6259 -- Initial_Condition
6261 elsif Is_Initial_Condition_Proc
(Target_Id
) then
6262 Info_Verification_Call
6263 (Pred
=> "Initial_Condition",
6264 Id
=> Find_Enclosing_Scope
(Call
),
6265 Id_Kind
=> "package");
6269 elsif Is_Init_Proc
(Target_Id
)
6270 or else Is_TSS
(Target_Id
, TSS_Deep_Initialize
)
6272 Info_Type_Actions
("initialization");
6276 elsif Is_Invariant_Proc
(Target_Id
) then
6277 Info_Verification_Call
6278 (Pred
=> "invariants",
6279 Id
=> First_Formal_Type
(Target_Id
),
6282 -- Partial invariant calls must not appear in the output because this
6283 -- creates confusing noise.
6285 elsif Is_Partial_Invariant_Proc
(Target_Id
) then
6290 elsif Is_Postconditions_Proc
(Target_Id
) then
6291 Info_Verification_Call
6292 (Pred
=> "postconditions",
6293 Id
=> Find_Enclosing_Scope
(Call
),
6294 Id_Kind
=> "subprogram");
6296 -- Subprograms must come last because some of the previous cases fall
6297 -- under this category.
6299 elsif Ekind
(Target_Id
) = E_Function
then
6302 elsif Ekind
(Target_Id
) = E_Procedure
then
6306 pragma Assert
(False);
6312 ------------------------
6313 -- Info_Instantiation --
6314 ------------------------
6316 procedure Info_Instantiation
6324 (Msg
=> "instantiation of & during elaboration",
6327 Info_Msg
=> Info_Msg
,
6328 In_SPARK
=> In_SPARK
);
6329 end Info_Instantiation
;
6331 -----------------------------
6332 -- Info_Variable_Reference --
6333 -----------------------------
6335 procedure Info_Variable_Reference
6342 if Is_Read
(Ref
) then
6344 (Msg
=> "read of variable & during elaboration",
6347 Info_Msg
=> Info_Msg
,
6348 In_SPARK
=> In_SPARK
);
6350 end Info_Variable_Reference
;
6352 --------------------
6353 -- Insertion_Node --
6354 --------------------
6356 function Insertion_Node
(N
: Node_Id
; Ins_Nod
: Node_Id
) return Node_Id
is
6358 -- When the scenario denotes an instantiation, the proper insertion node
6359 -- is the instance spec. This ensures that the generic actuals will not
6360 -- be evaluated prior to a potential ABE.
6362 if Nkind
(N
) in N_Generic_Instantiation
6363 and then Present
(Instance_Spec
(N
))
6365 return Instance_Spec
(N
);
6367 -- Otherwise the proper insertion node is the candidate insertion node
6374 -----------------------
6375 -- Install_ABE_Check --
6376 -----------------------
6378 procedure Install_ABE_Check
6383 Check_Ins_Nod
: constant Node_Id
:= Insertion_Node
(N
, Ins_Nod
);
6384 -- Insert the check prior to this node
6386 Loc
: constant Source_Ptr
:= Sloc
(N
);
6387 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Id
);
6388 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Id
);
6389 Scop_Id
: Entity_Id
;
6392 -- Nothing to do when compiling for GNATprove because raise statements
6393 -- are not supported.
6395 if GNATprove_Mode
then
6398 -- Nothing to do when the compilation will not produce an executable
6400 elsif Serious_Errors_Detected
> 0 then
6403 -- Nothing to do for a compilation unit because there is no executable
6404 -- environment at that level.
6406 elsif Nkind
(Parent
(Check_Ins_Nod
)) = N_Compilation_Unit
then
6409 -- Nothing to do when the unit is elaborated prior to the main unit.
6410 -- This check must also consider the following cases:
6412 -- * Id's unit appears in the context of the main unit
6414 -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST
6415 -- NOT be generated because Id's unit is always elaborated prior to
6418 -- * Id's unit is the main unit. An ABE check MUST be generated in this
6419 -- case because a conditional ABE may be raised depending on the flow
6420 -- of execution within the main unit (flag Same_Unit_OK is False).
6422 elsif Has_Prior_Elaboration
6423 (Unit_Id
=> Unit_Id
,
6425 Elab_Body_OK
=> True)
6430 -- Prevent multiple scenarios from installing the same ABE check
6432 Set_Is_Elaboration_Checks_OK_Node
(N
, False);
6434 -- Install the nearest enclosing scope of the scenario as there must be
6435 -- something on the scope stack.
6437 -- Performance note: parent traversal
6439 Scop_Id
:= Find_Enclosing_Scope
(Check_Ins_Nod
);
6440 pragma Assert
(Present
(Scop_Id
));
6442 Push_Scope
(Scop_Id
);
6445 -- if not Spec_Id'Elaborated then
6446 -- raise Program_Error with "access before elaboration";
6449 Insert_Action
(Check_Ins_Nod
,
6450 Make_Raise_Program_Error
(Loc
,
6454 Make_Attribute_Reference
(Loc
,
6455 Prefix
=> New_Occurrence_Of
(Spec_Id
, Loc
),
6456 Attribute_Name
=> Name_Elaborated
)),
6457 Reason
=> PE_Access_Before_Elaboration
));
6460 end Install_ABE_Check
;
6462 -----------------------
6463 -- Install_ABE_Check --
6464 -----------------------
6466 procedure Install_ABE_Check
6468 Target_Id
: Entity_Id
;
6469 Target_Decl
: Node_Id
;
6470 Target_Body
: Node_Id
;
6473 procedure Build_Elaboration_Entity
;
6474 pragma Inline
(Build_Elaboration_Entity
);
6475 -- Create a new elaboration flag for Target_Id, insert it prior to
6476 -- Target_Decl, and set it after Body_Decl.
6478 ------------------------------
6479 -- Build_Elaboration_Entity --
6480 ------------------------------
6482 procedure Build_Elaboration_Entity
is
6483 Loc
: constant Source_Ptr
:= Sloc
(Target_Id
);
6484 Flag_Id
: Entity_Id
;
6487 -- Create the declaration of the elaboration flag. The name carries a
6488 -- unique counter in case of name overloading.
6491 Make_Defining_Identifier
(Loc
,
6492 Chars
=> New_External_Name
(Chars
(Target_Id
), 'E', -1));
6494 Set_Elaboration_Entity
(Target_Id
, Flag_Id
);
6495 Set_Elaboration_Entity_Required
(Target_Id
);
6497 Push_Scope
(Scope
(Target_Id
));
6500 -- Enn : Short_Integer := 0;
6502 Insert_Action
(Target_Decl
,
6503 Make_Object_Declaration
(Loc
,
6504 Defining_Identifier
=> Flag_Id
,
6505 Object_Definition
=>
6506 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
6507 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
)));
6512 Set_Elaboration_Flag
(Target_Body
, Target_Id
);
6515 end Build_Elaboration_Entity
;
6519 Target_Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Target_Id
);
6521 -- Start for processing for Install_ABE_Check
6524 -- Nothing to do when compiling for GNATprove because raise statements
6525 -- are not supported.
6527 if GNATprove_Mode
then
6530 -- Nothing to do when the compilation will not produce an executable
6532 elsif Serious_Errors_Detected
> 0 then
6535 -- Nothing to do when the target is a protected subprogram because the
6536 -- check is associated with the protected body subprogram.
6538 elsif Is_Protected_Subp
(Target_Id
) then
6541 -- Nothing to do when the target is elaborated prior to the main unit.
6542 -- This check must also consider the following cases:
6544 -- * The unit of the target appears in the context of the main unit
6546 -- * The unit of the target is subject to pragma Elaborate_Body. An ABE
6547 -- check MUST NOT be generated because the unit is always elaborated
6548 -- prior to the main unit.
6550 -- * The unit of the target is the main unit. An ABE check MUST be added
6551 -- in this case because a conditional ABE may be raised depending on
6552 -- the flow of execution within the main unit (flag Same_Unit_OK is
6555 elsif Has_Prior_Elaboration
6556 (Unit_Id
=> Target_Unit_Id
,
6558 Elab_Body_OK
=> True)
6562 -- Create an elaboration flag for the target when it does not have one
6564 elsif No
(Elaboration_Entity
(Target_Id
)) then
6565 Build_Elaboration_Entity
;
6572 end Install_ABE_Check
;
6574 -------------------------
6575 -- Install_ABE_Failure --
6576 -------------------------
6578 procedure Install_ABE_Failure
(N
: Node_Id
; Ins_Nod
: Node_Id
) is
6579 Fail_Ins_Nod
: constant Node_Id
:= Insertion_Node
(N
, Ins_Nod
);
6580 -- Insert the failure prior to this node
6582 Loc
: constant Source_Ptr
:= Sloc
(N
);
6583 Scop_Id
: Entity_Id
;
6586 -- Nothing to do when compiling for GNATprove because raise statements
6587 -- are not supported.
6589 if GNATprove_Mode
then
6592 -- Nothing to do when the compilation will not produce an executable
6594 elsif Serious_Errors_Detected
> 0 then
6597 -- Do not install an ABE check for a compilation unit because there is
6598 -- no executable environment at that level.
6600 elsif Nkind
(Parent
(Fail_Ins_Nod
)) = N_Compilation_Unit
then
6604 -- Prevent multiple scenarios from installing the same ABE failure
6606 Set_Is_Elaboration_Checks_OK_Node
(N
, False);
6608 -- Install the nearest enclosing scope of the scenario as there must be
6609 -- something on the scope stack.
6611 -- Performance note: parent traversal
6613 Scop_Id
:= Find_Enclosing_Scope
(Fail_Ins_Nod
);
6614 pragma Assert
(Present
(Scop_Id
));
6616 Push_Scope
(Scop_Id
);
6619 -- raise Program_Error with "access before elaboration";
6621 Insert_Action
(Fail_Ins_Nod
,
6622 Make_Raise_Program_Error
(Loc
,
6623 Reason
=> PE_Access_Before_Elaboration
));
6626 end Install_ABE_Failure
;
6628 --------------------------------
6629 -- Is_Accept_Alternative_Proc --
6630 --------------------------------
6632 function Is_Accept_Alternative_Proc
(Id
: Entity_Id
) return Boolean is
6634 -- To qualify, the entity must denote a procedure with a receiving entry
6636 return Ekind
(Id
) = E_Procedure
and then Present
(Receiving_Entry
(Id
));
6637 end Is_Accept_Alternative_Proc
;
6639 ------------------------
6640 -- Is_Activation_Proc --
6641 ------------------------
6643 function Is_Activation_Proc
(Id
: Entity_Id
) return Boolean is
6645 -- To qualify, the entity must denote one of the runtime procedures in
6646 -- charge of task activation.
6648 if Ekind
(Id
) = E_Procedure
then
6649 if Restricted_Profile
then
6650 return Is_RTE
(Id
, RE_Activate_Restricted_Tasks
);
6652 return Is_RTE
(Id
, RE_Activate_Tasks
);
6657 end Is_Activation_Proc
;
6659 ----------------------------
6660 -- Is_Ada_Semantic_Target --
6661 ----------------------------
6663 function Is_Ada_Semantic_Target
(Id
: Entity_Id
) return Boolean is
6666 Is_Activation_Proc
(Id
)
6667 or else Is_Controlled_Proc
(Id
, Name_Adjust
)
6668 or else Is_Controlled_Proc
(Id
, Name_Finalize
)
6669 or else Is_Controlled_Proc
(Id
, Name_Initialize
)
6670 or else Is_Init_Proc
(Id
)
6671 or else Is_Invariant_Proc
(Id
)
6672 or else Is_Protected_Entry
(Id
)
6673 or else Is_Protected_Subp
(Id
)
6674 or else Is_Protected_Body_Subp
(Id
)
6675 or else Is_Task_Entry
(Id
);
6676 end Is_Ada_Semantic_Target
;
6678 --------------------------------
6679 -- Is_Assertion_Pragma_Target --
6680 --------------------------------
6682 function Is_Assertion_Pragma_Target
(Id
: Entity_Id
) return Boolean is
6685 Is_Default_Initial_Condition_Proc
(Id
)
6686 or else Is_Initial_Condition_Proc
(Id
)
6687 or else Is_Invariant_Proc
(Id
)
6688 or else Is_Partial_Invariant_Proc
(Id
)
6689 or else Is_Postconditions_Proc
(Id
);
6690 end Is_Assertion_Pragma_Target
;
6692 ----------------------------
6693 -- Is_Bodiless_Subprogram --
6694 ----------------------------
6696 function Is_Bodiless_Subprogram
(Subp_Id
: Entity_Id
) return Boolean is
6698 -- An abstract subprogram does not have a body
6700 if Ekind_In
(Subp_Id
, E_Function
,
6703 and then Is_Abstract_Subprogram
(Subp_Id
)
6707 -- A formal subprogram does not have a body
6709 elsif Is_Formal_Subprogram
(Subp_Id
) then
6712 -- An imported subprogram may have a body, however it is not known at
6713 -- compile or bind time where the body resides and whether it will be
6714 -- elaborated on time.
6716 elsif Is_Imported
(Subp_Id
) then
6721 end Is_Bodiless_Subprogram
;
6723 ------------------------
6724 -- Is_Controlled_Proc --
6725 ------------------------
6727 function Is_Controlled_Proc
6728 (Subp_Id
: Entity_Id
;
6729 Subp_Nam
: Name_Id
) return Boolean
6731 Formal_Id
: Entity_Id
;
6734 pragma Assert
(Nam_In
(Subp_Nam
, Name_Adjust
,
6738 -- To qualify, the subprogram must denote a source procedure with name
6739 -- Adjust, Finalize, or Initialize where the sole formal is controlled.
6741 if Comes_From_Source
(Subp_Id
)
6742 and then Ekind
(Subp_Id
) = E_Procedure
6743 and then Chars
(Subp_Id
) = Subp_Nam
6745 Formal_Id
:= First_Formal
(Subp_Id
);
6749 and then Is_Controlled
(Etype
(Formal_Id
))
6750 and then No
(Next_Formal
(Formal_Id
));
6754 end Is_Controlled_Proc
;
6756 ---------------------------------------
6757 -- Is_Default_Initial_Condition_Proc --
6758 ---------------------------------------
6760 function Is_Default_Initial_Condition_Proc
6761 (Id
: Entity_Id
) return Boolean
6764 -- To qualify, the entity must denote a Default_Initial_Condition
6767 return Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
);
6768 end Is_Default_Initial_Condition_Proc
;
6770 -----------------------
6771 -- Is_Finalizer_Proc --
6772 -----------------------
6774 function Is_Finalizer_Proc
(Id
: Entity_Id
) return Boolean is
6776 -- To qualify, the entity must denote a _Finalizer procedure
6778 return Ekind
(Id
) = E_Procedure
and then Chars
(Id
) = Name_uFinalizer
;
6779 end Is_Finalizer_Proc
;
6781 -----------------------
6782 -- Is_Guaranteed_ABE --
6783 -----------------------
6785 function Is_Guaranteed_ABE
6787 Target_Decl
: Node_Id
;
6788 Target_Body
: Node_Id
) return Boolean
6791 -- Avoid cascaded errors if there were previous serious infractions.
6792 -- As a result the scenario will not be treated as a guaranteed ABE.
6793 -- This behaviour parallels that of the old ABE mechanism.
6795 if Serious_Errors_Detected
> 0 then
6798 -- The scenario and the target appear within the same context ignoring
6799 -- enclosing library levels.
6801 -- Performance note: parent traversal
6803 elsif In_Same_Context
(N
, Target_Decl
) then
6805 -- The target body has already been encountered. The scenario results
6806 -- in a guaranteed ABE if it appears prior to the body.
6808 if Present
(Target_Body
) then
6809 return Earlier_In_Extended_Unit
(N
, Target_Body
);
6811 -- Otherwise the body has not been encountered yet. The scenario is
6812 -- a guaranteed ABE since the body will appear later. It is assumed
6813 -- that the caller has already checked whether the scenario is ABE-
6814 -- safe as optional bodies are not considered here.
6822 end Is_Guaranteed_ABE
;
6824 -------------------------------
6825 -- Is_Initial_Condition_Proc --
6826 -------------------------------
6828 function Is_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean is
6830 -- To qualify, the entity must denote an Initial_Condition procedure
6833 Ekind
(Id
) = E_Procedure
and then Is_Initial_Condition_Procedure
(Id
);
6834 end Is_Initial_Condition_Proc
;
6836 --------------------
6837 -- Is_Initialized --
6838 --------------------
6840 function Is_Initialized
(Obj_Decl
: Node_Id
) return Boolean is
6842 -- To qualify, the object declaration must have an expression
6845 Present
(Expression
(Obj_Decl
)) or else Has_Init_Expression
(Obj_Decl
);
6848 -----------------------
6849 -- Is_Invariant_Proc --
6850 -----------------------
6852 function Is_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
6854 -- To qualify, the entity must denote the "full" invariant procedure
6856 return Ekind
(Id
) = E_Procedure
and then Is_Invariant_Procedure
(Id
);
6857 end Is_Invariant_Proc
;
6859 ---------------------------------------
6860 -- Is_Non_Library_Level_Encapsulator --
6861 ---------------------------------------
6863 function Is_Non_Library_Level_Encapsulator
(N
: Node_Id
) return Boolean is
6866 when N_Abstract_Subprogram_Declaration
6867 | N_Aspect_Specification
6868 | N_Component_Declaration
6870 | N_Entry_Declaration
6871 | N_Expression_Function
6872 | N_Formal_Abstract_Subprogram_Declaration
6873 | N_Formal_Concrete_Subprogram_Declaration
6874 | N_Formal_Object_Declaration
6875 | N_Formal_Package_Declaration
6876 | N_Formal_Type_Declaration
6877 | N_Generic_Association
6878 | N_Implicit_Label_Declaration
6879 | N_Incomplete_Type_Declaration
6880 | N_Private_Extension_Declaration
6881 | N_Private_Type_Declaration
6883 | N_Protected_Type_Declaration
6884 | N_Single_Protected_Declaration
6885 | N_Single_Task_Declaration
6887 | N_Subprogram_Declaration
6889 | N_Task_Type_Declaration
6894 return Is_Generic_Declaration_Or_Body
(N
);
6896 end Is_Non_Library_Level_Encapsulator
;
6898 -------------------------------
6899 -- Is_Partial_Invariant_Proc --
6900 -------------------------------
6902 function Is_Partial_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
6904 -- To qualify, the entity must denote the "partial" invariant procedure
6907 Ekind
(Id
) = E_Procedure
and then Is_Partial_Invariant_Procedure
(Id
);
6908 end Is_Partial_Invariant_Proc
;
6910 ----------------------------
6911 -- Is_Postconditions_Proc --
6912 ----------------------------
6914 function Is_Postconditions_Proc
(Id
: Entity_Id
) return Boolean is
6916 -- To qualify, the entity must denote a _Postconditions procedure
6919 Ekind
(Id
) = E_Procedure
and then Chars
(Id
) = Name_uPostconditions
;
6920 end Is_Postconditions_Proc
;
6922 ---------------------------
6923 -- Is_Preelaborated_Unit --
6924 ---------------------------
6926 function Is_Preelaborated_Unit
(Id
: Entity_Id
) return Boolean is
6929 Is_Preelaborated
(Id
)
6930 or else Is_Pure
(Id
)
6931 or else Is_Remote_Call_Interface
(Id
)
6932 or else Is_Remote_Types
(Id
)
6933 or else Is_Shared_Passive
(Id
);
6934 end Is_Preelaborated_Unit
;
6936 ------------------------
6937 -- Is_Protected_Entry --
6938 ------------------------
6940 function Is_Protected_Entry
(Id
: Entity_Id
) return Boolean is
6942 -- To qualify, the entity must denote an entry defined in a protected
6947 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
6948 end Is_Protected_Entry
;
6950 -----------------------
6951 -- Is_Protected_Subp --
6952 -----------------------
6954 function Is_Protected_Subp
(Id
: Entity_Id
) return Boolean is
6956 -- To qualify, the entity must denote a subprogram defined within a
6960 Ekind_In
(Id
, E_Function
, E_Procedure
)
6961 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
6962 end Is_Protected_Subp
;
6964 ----------------------------
6965 -- Is_Protected_Body_Subp --
6966 ----------------------------
6968 function Is_Protected_Body_Subp
(Id
: Entity_Id
) return Boolean is
6970 -- To qualify, the entity must denote a subprogram with attribute
6971 -- Protected_Subprogram set.
6974 Ekind_In
(Id
, E_Function
, E_Procedure
)
6975 and then Present
(Protected_Subprogram
(Id
));
6976 end Is_Protected_Body_Subp
;
6978 --------------------------------
6979 -- Is_Recorded_SPARK_Scenario --
6980 --------------------------------
6982 function Is_Recorded_SPARK_Scenario
(N
: Node_Id
) return Boolean is
6984 if Recorded_SPARK_Scenarios_In_Use
then
6985 return Recorded_SPARK_Scenarios
.Get
(N
);
6988 return Recorded_SPARK_Scenarios_No_Element
;
6989 end Is_Recorded_SPARK_Scenario
;
6991 ------------------------------------
6992 -- Is_Recorded_Top_Level_Scenario --
6993 ------------------------------------
6995 function Is_Recorded_Top_Level_Scenario
(N
: Node_Id
) return Boolean is
6997 if Recorded_Top_Level_Scenarios_In_Use
then
6998 return Recorded_Top_Level_Scenarios
.Get
(N
);
7001 return Recorded_Top_Level_Scenarios_No_Element
;
7002 end Is_Recorded_Top_Level_Scenario
;
7004 ------------------------
7005 -- Is_Safe_Activation --
7006 ------------------------
7008 function Is_Safe_Activation
7010 Task_Decl
: Node_Id
) return Boolean
7013 -- The activation of a task coming from an external instance cannot
7014 -- cause an ABE because the generic was already instantiated. Note
7015 -- that the instantiation itself may lead to an ABE.
7018 In_External_Instance
7020 Target_Decl
=> Task_Decl
);
7021 end Is_Safe_Activation
;
7027 function Is_Safe_Call
7029 Target_Attrs
: Target_Attributes
) return Boolean
7032 -- The target is either an abstract subprogram, formal subprogram, or
7033 -- imported, in which case it does not have a body at compile or bind
7034 -- time. Assume that the call is ABE-safe.
7036 if Is_Bodiless_Subprogram
(Target_Attrs
.Spec_Id
) then
7039 -- The target is an instantiation of a generic subprogram. The call
7040 -- cannot cause an ABE because the generic was already instantiated.
7041 -- Note that the instantiation itself may lead to an ABE.
7043 elsif Is_Generic_Instance
(Target_Attrs
.Spec_Id
) then
7046 -- The invocation of a target coming from an external instance cannot
7047 -- cause an ABE because the generic was already instantiated. Note that
7048 -- the instantiation itself may lead to an ABE.
7050 elsif In_External_Instance
7052 Target_Decl
=> Target_Attrs
.Spec_Decl
)
7056 -- The target is a subprogram body without a previous declaration. The
7057 -- call cannot cause an ABE because the body has already been seen.
7059 elsif Nkind
(Target_Attrs
.Spec_Decl
) = N_Subprogram_Body
7060 and then No
(Corresponding_Spec
(Target_Attrs
.Spec_Decl
))
7064 -- The target is a subprogram body stub without a prior declaration.
7065 -- The call cannot cause an ABE because the proper body substitutes
7068 elsif Nkind
(Target_Attrs
.Spec_Decl
) = N_Subprogram_Body_Stub
7069 and then No
(Corresponding_Spec_Of_Stub
(Target_Attrs
.Spec_Decl
))
7073 -- Subprogram bodies which wrap attribute references used as actuals
7074 -- in instantiations are always ABE-safe. These bodies are artifacts
7077 elsif Present
(Target_Attrs
.Body_Decl
)
7078 and then Nkind
(Target_Attrs
.Body_Decl
) = N_Subprogram_Body
7079 and then Was_Attribute_Reference
(Target_Attrs
.Body_Decl
)
7087 ---------------------------
7088 -- Is_Safe_Instantiation --
7089 ---------------------------
7091 function Is_Safe_Instantiation
7093 Gen_Attrs
: Target_Attributes
) return Boolean
7096 -- The generic is an intrinsic subprogram in which case it does not
7097 -- have a body at compile or bind time. Assume that the instantiation
7100 if Is_Bodiless_Subprogram
(Gen_Attrs
.Spec_Id
) then
7103 -- The instantiation of an external nested generic cannot cause an ABE
7104 -- if the outer generic was already instantiated. Note that the instance
7105 -- of the outer generic may lead to an ABE.
7107 elsif In_External_Instance
7109 Target_Decl
=> Gen_Attrs
.Spec_Decl
)
7113 -- The generic is a package. The instantiation cannot cause an ABE when
7114 -- the package has no body.
7116 elsif Ekind
(Gen_Attrs
.Spec_Id
) = E_Generic_Package
7117 and then not Has_Body
(Gen_Attrs
.Spec_Decl
)
7123 end Is_Safe_Instantiation
;
7129 function Is_Same_Unit
7130 (Unit_1
: Entity_Id
;
7131 Unit_2
: Entity_Id
) return Boolean
7133 function Is_Subunit
(Unit_Id
: Entity_Id
) return Boolean;
7134 pragma Inline
(Is_Subunit
);
7135 -- Determine whether unit Unit_Id is a subunit
7137 function Normalize_Unit
(Unit_Id
: Entity_Id
) return Entity_Id
;
7138 -- Strip a potential subunit chain ending with unit Unit_Id and return
7139 -- the corresponding spec.
7145 function Is_Subunit
(Unit_Id
: Entity_Id
) return Boolean is
7147 return Nkind
(Parent
(Unit_Declaration_Node
(Unit_Id
))) = N_Subunit
;
7150 --------------------
7151 -- Normalize_Unit --
7152 --------------------
7154 function Normalize_Unit
(Unit_Id
: Entity_Id
) return Entity_Id
is
7158 -- Eliminate a potential chain of subunits to reach to proper body
7161 while Present
(Result
)
7162 and then Result
/= Standard_Standard
7163 and then Is_Subunit
(Result
)
7165 Result
:= Scope
(Result
);
7168 -- Obtain the entity of the corresponding spec (if any)
7170 return Unique_Entity
(Result
);
7173 -- Start of processing for Is_Same_Unit
7176 return Normalize_Unit
(Unit_1
) = Normalize_Unit
(Unit_2
);
7183 function Is_Scenario
(N
: Node_Id
) return Boolean is
7186 when N_Assignment_Statement
7187 | N_Attribute_Reference
7189 | N_Entry_Call_Statement
7192 | N_Function_Instantiation
7194 | N_Package_Instantiation
7195 | N_Procedure_Call_Statement
7196 | N_Procedure_Instantiation
7197 | N_Requeue_Statement
7206 ------------------------------
7207 -- Is_SPARK_Semantic_Target --
7208 ------------------------------
7210 function Is_SPARK_Semantic_Target
(Id
: Entity_Id
) return Boolean is
7213 Is_Default_Initial_Condition_Proc
(Id
)
7214 or else Is_Initial_Condition_Proc
(Id
);
7215 end Is_SPARK_Semantic_Target
;
7217 ------------------------
7218 -- Is_Suitable_Access --
7219 ------------------------
7221 function Is_Suitable_Access
(N
: Node_Id
) return Boolean is
7224 Subp_Id
: Entity_Id
;
7227 -- This scenario is relevant only when the static model is in effect
7228 -- because it is graph-dependent and does not involve any run-time
7229 -- checks. Allowing it in the dynamic model would create confusing
7232 if not Static_Elaboration_Checks
then
7235 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
7237 elsif Debug_Flag_Dot_UU
then
7240 -- Nothing to do when the scenario is not an attribute reference
7242 elsif Nkind
(N
) /= N_Attribute_Reference
then
7245 -- Nothing to do for internally-generated attributes because they are
7246 -- assumed to be ABE safe.
7248 elsif not Comes_From_Source
(N
) then
7252 Nam
:= Attribute_Name
(N
);
7255 -- Sanitize the prefix of the attribute
7257 if not Is_Entity_Name
(Pref
) then
7260 elsif No
(Entity
(Pref
)) then
7264 Subp_Id
:= Entity
(Pref
);
7266 if not Is_Subprogram_Or_Entry
(Subp_Id
) then
7270 -- Traverse a possible chain of renamings to obtain the original entry
7271 -- or subprogram which the prefix may rename.
7273 Subp_Id
:= Get_Renamed_Entity
(Subp_Id
);
7275 -- To qualify, the attribute must meet the following prerequisites:
7279 -- The prefix must denote a source entry, operator, or subprogram
7280 -- which is not imported.
7282 Comes_From_Source
(Subp_Id
)
7283 and then Is_Subprogram_Or_Entry
(Subp_Id
)
7284 and then not Is_Bodiless_Subprogram
(Subp_Id
)
7286 -- The attribute name must be one of the 'Access forms. Note that
7287 -- 'Unchecked_Access cannot apply to a subprogram.
7289 and then Nam_In
(Nam
, Name_Access
, Name_Unrestricted_Access
);
7290 end Is_Suitable_Access
;
7292 ----------------------
7293 -- Is_Suitable_Call --
7294 ----------------------
7296 function Is_Suitable_Call
(N
: Node_Id
) return Boolean is
7298 -- Entry and subprogram calls are intentionally ignored because they
7299 -- may undergo expansion depending on the compilation mode, previous
7300 -- errors, generic context, etc. Call markers play the role of calls
7301 -- and provide a uniform foundation for ABE processing.
7303 return Nkind
(N
) = N_Call_Marker
;
7304 end Is_Suitable_Call
;
7306 -------------------------------
7307 -- Is_Suitable_Instantiation --
7308 -------------------------------
7310 function Is_Suitable_Instantiation
(N
: Node_Id
) return Boolean is
7311 Orig_N
: constant Node_Id
:= Original_Node
(N
);
7312 -- Use the original node in case an instantiation library unit is
7313 -- rewritten as a package or subprogram.
7316 -- To qualify, the instantiation must come from source
7319 Comes_From_Source
(Orig_N
)
7320 and then Nkind
(Orig_N
) in N_Generic_Instantiation
;
7321 end Is_Suitable_Instantiation
;
7323 --------------------------
7324 -- Is_Suitable_Scenario --
7325 --------------------------
7327 function Is_Suitable_Scenario
(N
: Node_Id
) return Boolean is
7329 -- NOTE: Derived types and pragma Refined_State are intentionally left
7330 -- out because they are not executable during elaboration.
7333 Is_Suitable_Access
(N
)
7334 or else Is_Suitable_Call
(N
)
7335 or else Is_Suitable_Instantiation
(N
)
7336 or else Is_Suitable_Variable_Assignment
(N
)
7337 or else Is_Suitable_Variable_Reference
(N
);
7338 end Is_Suitable_Scenario
;
7340 ------------------------------------
7341 -- Is_Suitable_SPARK_Derived_Type --
7342 ------------------------------------
7344 function Is_Suitable_SPARK_Derived_Type
(N
: Node_Id
) return Boolean is
7349 -- To qualify, the type declaration must denote a derived tagged type
7350 -- with primitive operations, subject to pragma SPARK_Mode On.
7352 if Nkind
(N
) = N_Full_Type_Declaration
7353 and then Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
7355 Typ
:= Defining_Entity
(N
);
7356 Prag
:= SPARK_Pragma
(Typ
);
7359 Is_Tagged_Type
(Typ
)
7360 and then Has_Primitive_Operations
(Typ
)
7361 and then Present
(Prag
)
7362 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
;
7366 end Is_Suitable_SPARK_Derived_Type
;
7368 -------------------------------------
7369 -- Is_Suitable_SPARK_Instantiation --
7370 -------------------------------------
7372 function Is_Suitable_SPARK_Instantiation
(N
: Node_Id
) return Boolean is
7373 Gen_Attrs
: Target_Attributes
;
7376 Inst_Attrs
: Instantiation_Attributes
;
7377 Inst_Id
: Entity_Id
;
7380 -- To qualify, both the instantiation and the generic must be subject to
7383 if Is_Suitable_Instantiation
(N
) then
7384 Extract_Instantiation_Attributes
7389 Attrs
=> Inst_Attrs
);
7391 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
7393 return Inst_Attrs
.SPARK_Mode_On
and Gen_Attrs
.SPARK_Mode_On
;
7397 end Is_Suitable_SPARK_Instantiation
;
7399 --------------------------------------------
7400 -- Is_Suitable_SPARK_Refined_State_Pragma --
7401 --------------------------------------------
7403 function Is_Suitable_SPARK_Refined_State_Pragma
7404 (N
: Node_Id
) return Boolean
7407 -- To qualfy, the pragma must denote Refined_State
7410 Nkind
(N
) = N_Pragma
7411 and then Pragma_Name
(N
) = Name_Refined_State
;
7412 end Is_Suitable_SPARK_Refined_State_Pragma
;
7414 -------------------------------------
7415 -- Is_Suitable_Variable_Assignment --
7416 -------------------------------------
7418 function Is_Suitable_Variable_Assignment
(N
: Node_Id
) return Boolean is
7420 N_Unit_Id
: Entity_Id
;
7425 Var_Unit_Id
: Entity_Id
;
7428 -- This scenario is relevant only when the static model is in effect
7429 -- because it is graph-dependent and does not involve any run-time
7430 -- checks. Allowing it in the dynamic model would create confusing
7433 if not Static_Elaboration_Checks
then
7436 -- Nothing to do when the scenario is not an assignment
7438 elsif Nkind
(N
) /= N_Assignment_Statement
then
7441 -- Nothing to do for internally-generated assignments because they are
7442 -- assumed to be ABE safe.
7444 elsif not Comes_From_Source
(N
) then
7447 -- Assignments are ignored in GNAT mode on the assumption that they are
7448 -- ABE-safe. This behaviour parallels that of the old ABE mechanism.
7450 elsif GNAT_Mode
then
7454 Nam
:= Extract_Assignment_Name
(N
);
7456 -- Sanitize the left hand side of the assignment
7458 if not Is_Entity_Name
(Nam
) then
7461 elsif No
(Entity
(Nam
)) then
7465 Var_Id
:= Entity
(Nam
);
7467 -- Sanitize the variable
7469 if Var_Id
= Any_Id
then
7472 elsif Ekind
(Var_Id
) /= E_Variable
then
7476 Var_Decl
:= Declaration_Node
(Var_Id
);
7478 if Nkind
(Var_Decl
) /= N_Object_Declaration
then
7482 N_Unit_Id
:= Find_Top_Unit
(N
);
7483 N_Unit
:= Unit_Declaration_Node
(N_Unit_Id
);
7485 Var_Unit_Id
:= Find_Top_Unit
(Var_Decl
);
7486 Var_Unit
:= Unit_Declaration_Node
(Var_Unit_Id
);
7488 -- To qualify, the assignment must meet the following prerequisites:
7491 Comes_From_Source
(Var_Id
)
7493 -- The variable must be declared in the spec of compilation unit U
7495 and then Nkind
(Var_Unit
) = N_Package_Declaration
7497 -- Performance note: parent traversal
7499 and then Find_Enclosing_Level
(Var_Decl
) = Package_Spec
7501 -- The assignment must occur in the body of compilation unit U
7503 and then Nkind
(N_Unit
) = N_Package_Body
7504 and then Present
(Corresponding_Body
(Var_Unit
))
7505 and then Corresponding_Body
(Var_Unit
) = N_Unit_Id
;
7506 end Is_Suitable_Variable_Assignment
;
7508 ------------------------------------
7509 -- Is_Suitable_Variable_Reference --
7510 ------------------------------------
7512 function Is_Suitable_Variable_Reference
(N
: Node_Id
) return Boolean is
7514 -- Expanded names and identifiers are intentionally ignored because they
7515 -- be folded, optimized away, etc. Variable references markers play the
7516 -- role of variable references and provide a uniform foundation for ABE
7519 return Nkind
(N
) = N_Variable_Reference_Marker
;
7520 end Is_Suitable_Variable_Reference
;
7526 function Is_Task_Entry
(Id
: Entity_Id
) return Boolean is
7528 -- To qualify, the entity must denote an entry defined in a task type
7531 Is_Entry
(Id
) and then Is_Task_Type
(Non_Private_View
(Scope
(Id
)));
7534 ------------------------
7535 -- Is_Up_Level_Target --
7536 ------------------------
7538 function Is_Up_Level_Target
(Target_Decl
: Node_Id
) return Boolean is
7539 Root
: constant Node_Id
:= Root_Scenario
;
7542 -- The root appears within the declaratons of a block statement, entry
7543 -- body, subprogram body, or task body ignoring enclosing packages. The
7544 -- root is always within the main unit. An up-level target is a notion
7545 -- applicable only to the static model because scenarios are reached by
7546 -- means of graph traversal started from a fixed declarative or library
7549 -- Performance note: parent traversal
7551 if Static_Elaboration_Checks
7552 and then Find_Enclosing_Level
(Root
) = Declaration_Level
7554 -- The target is within the main unit. It acts as an up-level target
7555 -- when it appears within a context which encloses the root.
7557 -- package body Main_Unit is
7558 -- function Func ...; -- target
7560 -- procedure Proc is
7561 -- X : ... := Func; -- root scenario
7563 if In_Extended_Main_Code_Unit
(Target_Decl
) then
7565 -- Performance note: parent traversal
7567 return not In_Same_Context
(Root
, Target_Decl
, Nested_OK
=> True);
7569 -- Otherwise the target is external to the main unit which makes it
7570 -- an up-level target.
7578 end Is_Up_Level_Target
;
7580 ---------------------
7581 -- Is_Visited_Body --
7582 ---------------------
7584 function Is_Visited_Body
(Body_Decl
: Node_Id
) return Boolean is
7586 if Visited_Bodies_In_Use
then
7587 return Visited_Bodies
.Get
(Body_Decl
);
7590 return Visited_Bodies_No_Element
;
7591 end Is_Visited_Body
;
7593 -------------------------------
7594 -- Kill_Elaboration_Scenario --
7595 -------------------------------
7597 procedure Kill_Elaboration_Scenario
(N
: Node_Id
) is
7598 procedure Kill_SPARK_Scenario
;
7599 pragma Inline
(Kill_SPARK_Scenario
);
7600 -- Eliminate scenario N from table SPARK_Scenarios if it is recorded
7603 procedure Kill_Top_Level_Scenario
;
7604 pragma Inline
(Kill_Top_Level_Scenario
);
7605 -- Eliminate scenario N from table Top_Level_Scenarios if it is recorded
7608 -------------------------
7609 -- Kill_SPARK_Scenario --
7610 -------------------------
7612 procedure Kill_SPARK_Scenario
is
7613 package Scenarios
renames SPARK_Scenarios
;
7616 if Is_Recorded_SPARK_Scenario
(N
) then
7618 -- Performance note: list traversal
7620 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
7621 if Scenarios
.Table
(Index
) = N
then
7622 Scenarios
.Table
(Index
) := Empty
;
7624 -- The SPARK scenario is no longer recorded
7626 Set_Is_Recorded_SPARK_Scenario
(N
, False);
7631 -- A recorded SPARK scenario must be in the table of recorded
7634 pragma Assert
(False);
7636 end Kill_SPARK_Scenario
;
7638 -----------------------------
7639 -- Kill_Top_Level_Scenario --
7640 -----------------------------
7642 procedure Kill_Top_Level_Scenario
is
7643 package Scenarios
renames Top_Level_Scenarios
;
7646 if Is_Recorded_Top_Level_Scenario
(N
) then
7648 -- Performance node: list traversal
7650 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
7651 if Scenarios
.Table
(Index
) = N
then
7652 Scenarios
.Table
(Index
) := Empty
;
7654 -- The top-level scenario is no longer recorded
7656 Set_Is_Recorded_Top_Level_Scenario
(N
, False);
7661 -- A recorded top-level scenario must be in the table of recorded
7662 -- top-level scenarios.
7664 pragma Assert
(False);
7666 end Kill_Top_Level_Scenario
;
7668 -- Start of processing for Kill_Elaboration_Scenario
7671 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
7672 -- enabled) is in effect because the legacy ABE lechanism does not need
7673 -- to carry out this action.
7675 if Legacy_Elaboration_Checks
then
7679 -- Eliminate a recorded scenario when it appears within dead code
7680 -- because it will not be executed at elaboration time.
7682 if Is_Scenario
(N
) then
7683 Kill_SPARK_Scenario
;
7684 Kill_Top_Level_Scenario
;
7686 end Kill_Elaboration_Scenario
;
7688 ----------------------------------
7689 -- Meet_Elaboration_Requirement --
7690 ----------------------------------
7692 procedure Meet_Elaboration_Requirement
7694 Target_Id
: Entity_Id
;
7697 Main_Id
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
7698 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Target_Id
);
7700 function Find_Preelaboration_Pragma
7701 (Prag_Nam
: Name_Id
) return Node_Id
;
7702 pragma Inline
(Find_Preelaboration_Pragma
);
7703 -- Traverse the visible declarations of unit Unit_Id and locate a source
7704 -- preelaboration-related pragma with name Prag_Nam.
7706 procedure Info_Requirement_Met
(Prag
: Node_Id
);
7707 pragma Inline
(Info_Requirement_Met
);
7708 -- Output information concerning pragma Prag which meets requirement
7711 procedure Info_Scenario
;
7712 pragma Inline
(Info_Scenario
);
7713 -- Output information concerning scenario N
7715 --------------------------------
7716 -- Find_Preelaboration_Pragma --
7717 --------------------------------
7719 function Find_Preelaboration_Pragma
7720 (Prag_Nam
: Name_Id
) return Node_Id
7722 Spec
: constant Node_Id
:= Parent
(Unit_Id
);
7726 -- A preelaboration-related pragma comes from source and appears at
7727 -- the top of the visible declarations of a package.
7729 if Nkind
(Spec
) = N_Package_Specification
then
7730 Decl
:= First
(Visible_Declarations
(Spec
));
7731 while Present
(Decl
) loop
7732 if Comes_From_Source
(Decl
) then
7733 if Nkind
(Decl
) = N_Pragma
7734 and then Pragma_Name
(Decl
) = Prag_Nam
7738 -- Otherwise the construct terminates the region where the
7739 -- preelabortion-related pragma may appear.
7751 end Find_Preelaboration_Pragma
;
7753 --------------------------
7754 -- Info_Requirement_Met --
7755 --------------------------
7757 procedure Info_Requirement_Met
(Prag
: Node_Id
) is
7759 pragma Assert
(Present
(Prag
));
7761 Error_Msg_Name_1
:= Req_Nam
;
7762 Error_Msg_Sloc
:= Sloc
(Prag
);
7764 ("\\% requirement for unit & met by pragma #", N
, Unit_Id
);
7765 end Info_Requirement_Met
;
7771 procedure Info_Scenario
is
7773 if Is_Suitable_Call
(N
) then
7776 Target_Id
=> Target_Id
,
7780 elsif Is_Suitable_Instantiation
(N
) then
7783 Gen_Id
=> Target_Id
,
7787 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
7789 ("read of refinement constituents during elaboration in SPARK",
7792 elsif Is_Suitable_Variable_Reference
(N
) then
7793 Info_Variable_Reference
7795 Var_Id
=> Target_Id
,
7799 -- No other scenario may impose a requirement on the context of the
7803 pragma Assert
(False);
7810 Elab_Attrs
: Elaboration_Attributes
;
7814 -- Start of processing for Meet_Elaboration_Requirement
7817 pragma Assert
(Nam_In
(Req_Nam
, Name_Elaborate
, Name_Elaborate_All
));
7819 -- Assume that the requirement has not been met
7823 -- Elaboration requirements are verified only when the static model is
7824 -- in effect because this diagnostic is graph-dependent.
7826 if not Static_Elaboration_Checks
then
7829 -- If the target is within the main unit, either at the source level or
7830 -- through an instantiation, then there is no real requirement to meet
7831 -- because the main unit cannot force its own elaboration by means of an
7832 -- Elaborate[_All] pragma. Treat this case as valid coverage.
7834 elsif In_Extended_Main_Code_Unit
(Target_Id
) then
7837 -- Otherwise the target resides in an external unit
7839 -- The requirement is met when the target comes from an internal unit
7840 -- because such a unit is elaborated prior to a non-internal unit.
7842 elsif In_Internal_Unit
(Unit_Id
)
7843 and then not In_Internal_Unit
(Main_Id
)
7847 -- The requirement is met when the target comes from a preelaborated
7848 -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
7850 elsif Is_Preelaborated_Unit
(Unit_Id
) then
7853 -- Output extra information when switch -gnatel (info messages on
7854 -- implicit Elaborate[_All] pragmas.
7856 if Elab_Info_Messages
then
7857 if Is_Preelaborated
(Unit_Id
) then
7858 Elab_Nam
:= Name_Preelaborate
;
7860 elsif Is_Pure
(Unit_Id
) then
7861 Elab_Nam
:= Name_Pure
;
7863 elsif Is_Remote_Call_Interface
(Unit_Id
) then
7864 Elab_Nam
:= Name_Remote_Call_Interface
;
7866 elsif Is_Remote_Types
(Unit_Id
) then
7867 Elab_Nam
:= Name_Remote_Types
;
7870 pragma Assert
(Is_Shared_Passive
(Unit_Id
));
7871 Elab_Nam
:= Name_Shared_Passive
;
7874 Info_Requirement_Met
(Find_Preelaboration_Pragma
(Elab_Nam
));
7877 -- Determine whether the context of the main unit has a pragma strong
7878 -- enough to meet the requirement.
7881 Elab_Attrs
:= Elaboration_Status
(Unit_Id
);
7883 -- The pragma must be either Elaborate_All or be as strong as the
7886 if Present
(Elab_Attrs
.Source_Pragma
)
7887 and then Nam_In
(Pragma_Name
(Elab_Attrs
.Source_Pragma
),
7893 -- Output extra information when switch -gnatel (info messages on
7894 -- implicit Elaborate[_All] pragmas.
7896 if Elab_Info_Messages
then
7897 Info_Requirement_Met
(Elab_Attrs
.Source_Pragma
);
7902 -- The requirement was not met by the context of the main unit, issue an
7908 Error_Msg_Name_1
:= Req_Nam
;
7909 Error_Msg_Node_2
:= Unit_Id
;
7910 Error_Msg_NE
("\\unit & requires pragma % for &", N
, Main_Id
);
7912 Output_Active_Scenarios
(N
);
7914 end Meet_Elaboration_Requirement
;
7916 ----------------------
7917 -- Non_Private_View --
7918 ----------------------
7920 function Non_Private_View
(Typ
: Entity_Id
) return Entity_Id
is
7926 if Is_Private_Type
(Result
) and then Present
(Full_View
(Result
)) then
7927 Result
:= Full_View
(Result
);
7931 end Non_Private_View
;
7933 -----------------------------
7934 -- Output_Active_Scenarios --
7935 -----------------------------
7937 procedure Output_Active_Scenarios
(Error_Nod
: Node_Id
) is
7938 procedure Output_Access
(N
: Node_Id
);
7939 -- Emit a specific diagnostic message for 'Access denote by N
7941 procedure Output_Activation_Call
(N
: Node_Id
);
7942 -- Emit a specific diagnostic message for task activation N
7944 procedure Output_Call
(N
: Node_Id
; Target_Id
: Entity_Id
);
7945 -- Emit a specific diagnostic message for call N which invokes target
7948 procedure Output_Header
;
7949 -- Emit a specific diagnostic message for the unit of the root scenario
7951 procedure Output_Instantiation
(N
: Node_Id
);
7952 -- Emit a specific diagnostic message for instantiation N
7954 procedure Output_SPARK_Refined_State_Pragma
(N
: Node_Id
);
7955 -- Emit a specific diagnostic message for Refined_State pragma N
7957 procedure Output_Variable_Assignment
(N
: Node_Id
);
7958 -- Emit a specific diagnostic message for assignment statement N
7960 procedure Output_Variable_Reference
(N
: Node_Id
);
7961 -- Emit a specific diagnostic message for reference N which mentions a
7968 procedure Output_Access
(N
: Node_Id
) is
7969 Subp_Id
: constant Entity_Id
:= Entity
(Prefix
(N
));
7972 Error_Msg_Name_1
:= Attribute_Name
(N
);
7973 Error_Msg_Sloc
:= Sloc
(N
);
7974 Error_Msg_NE
("\\ % of & taken #", Error_Nod
, Subp_Id
);
7977 ----------------------------
7978 -- Output_Activation_Call --
7979 ----------------------------
7981 procedure Output_Activation_Call
(N
: Node_Id
) is
7982 function Find_Activator
(Call
: Node_Id
) return Entity_Id
;
7983 -- Find the nearest enclosing construct which houses call Call
7985 --------------------
7986 -- Find_Activator --
7987 --------------------
7989 function Find_Activator
(Call
: Node_Id
) return Entity_Id
is
7993 -- Climb the parent chain looking for a package [body] or a
7994 -- construct with a statement sequence.
7996 Par
:= Parent
(Call
);
7997 while Present
(Par
) loop
7998 if Nkind_In
(Par
, N_Package_Body
, N_Package_Declaration
) then
7999 return Defining_Entity
(Par
);
8001 elsif Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
8002 return Defining_Entity
(Parent
(Par
));
8005 Par
:= Parent
(Par
);
8013 Activator
: constant Entity_Id
:= Find_Activator
(N
);
8015 -- Start of processing for Output_Activation_Call
8018 pragma Assert
(Present
(Activator
));
8020 Error_Msg_NE
("\\ local tasks of & activated", Error_Nod
, Activator
);
8021 end Output_Activation_Call
;
8027 procedure Output_Call
(N
: Node_Id
; Target_Id
: Entity_Id
) is
8028 procedure Output_Accept_Alternative
;
8029 pragma Inline
(Output_Accept_Alternative
);
8030 -- Emit a specific diagnostic message concerning an accept
8033 procedure Output_Call
(Kind
: String);
8034 pragma Inline
(Output_Call
);
8035 -- Emit a specific diagnostic message concerning a call of kind Kind
8037 procedure Output_Type_Actions
(Action
: String);
8038 pragma Inline
(Output_Type_Actions
);
8039 -- Emit a specific diagnostic message concerning action Action of a
8042 procedure Output_Verification_Call
8046 pragma Inline
(Output_Verification_Call
);
8047 -- Emit a specific diagnostic message concerning the verification of
8048 -- predicate Pred applied to related entity Id with kind Id_Kind.
8050 -------------------------------
8051 -- Output_Accept_Alternative --
8052 -------------------------------
8054 procedure Output_Accept_Alternative
is
8055 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Target_Id
);
8058 pragma Assert
(Present
(Entry_Id
));
8060 Error_Msg_NE
("\\ entry & selected #", Error_Nod
, Entry_Id
);
8061 end Output_Accept_Alternative
;
8067 procedure Output_Call
(Kind
: String) is
8069 Error_Msg_NE
("\\ " & Kind
& " & called #", Error_Nod
, Target_Id
);
8072 -------------------------
8073 -- Output_Type_Actions --
8074 -------------------------
8076 procedure Output_Type_Actions
(Action
: String) is
8077 Typ
: constant Entity_Id
:= First_Formal_Type
(Target_Id
);
8080 pragma Assert
(Present
(Typ
));
8083 ("\\ " & Action
& " actions for type & #", Error_Nod
, Typ
);
8084 end Output_Type_Actions
;
8086 ------------------------------
8087 -- Output_Verification_Call --
8088 ------------------------------
8090 procedure Output_Verification_Call
8096 pragma Assert
(Present
(Id
));
8099 ("\\ " & Pred
& " of " & Id_Kind
& " & verified #",
8101 end Output_Verification_Call
;
8103 -- Start of processing for Output_Call
8106 Error_Msg_Sloc
:= Sloc
(N
);
8108 -- Accept alternative
8110 if Is_Accept_Alternative_Proc
(Target_Id
) then
8111 Output_Accept_Alternative
;
8115 elsif Is_TSS
(Target_Id
, TSS_Deep_Adjust
) then
8116 Output_Type_Actions
("adjustment");
8118 -- Default_Initial_Condition
8120 elsif Is_Default_Initial_Condition_Proc
(Target_Id
) then
8121 Output_Verification_Call
8122 (Pred
=> "Default_Initial_Condition",
8123 Id
=> First_Formal_Type
(Target_Id
),
8128 elsif Is_Protected_Entry
(Target_Id
) then
8129 Output_Call
("entry");
8131 -- Task entry calls are never processed because the entry being
8132 -- invoked does not have a corresponding "body", it has a select. A
8133 -- task entry call appears in the stack of active scenarios for the
8134 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
8137 elsif Is_Task_Entry
(Target_Id
) then
8142 elsif Is_TSS
(Target_Id
, TSS_Deep_Finalize
) then
8143 Output_Type_Actions
("finalization");
8145 -- Calls to _Finalizer procedures must not appear in the output
8146 -- because this creates confusing noise.
8148 elsif Is_Finalizer_Proc
(Target_Id
) then
8151 -- Initial_Condition
8153 elsif Is_Initial_Condition_Proc
(Target_Id
) then
8154 Output_Verification_Call
8155 (Pred
=> "Initial_Condition",
8156 Id
=> Find_Enclosing_Scope
(N
),
8157 Id_Kind
=> "package");
8161 elsif Is_Init_Proc
(Target_Id
)
8162 or else Is_TSS
(Target_Id
, TSS_Deep_Initialize
)
8164 Output_Type_Actions
("initialization");
8168 elsif Is_Invariant_Proc
(Target_Id
) then
8169 Output_Verification_Call
8170 (Pred
=> "invariants",
8171 Id
=> First_Formal_Type
(Target_Id
),
8174 -- Partial invariant calls must not appear in the output because this
8175 -- creates confusing noise. Note that a partial invariant is always
8176 -- invoked by the "full" invariant which is already placed on the
8179 elsif Is_Partial_Invariant_Proc
(Target_Id
) then
8184 elsif Is_Postconditions_Proc
(Target_Id
) then
8185 Output_Verification_Call
8186 (Pred
=> "postconditions",
8187 Id
=> Find_Enclosing_Scope
(N
),
8188 Id_Kind
=> "subprogram");
8190 -- Subprograms must come last because some of the previous cases fall
8191 -- under this category.
8193 elsif Ekind
(Target_Id
) = E_Function
then
8194 Output_Call
("function");
8196 elsif Ekind
(Target_Id
) = E_Procedure
then
8197 Output_Call
("procedure");
8200 pragma Assert
(False);
8209 procedure Output_Header
is
8210 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Root_Scenario
);
8213 if Ekind
(Unit_Id
) = E_Package
then
8214 Error_Msg_NE
("\\ spec of unit & elaborated", Error_Nod
, Unit_Id
);
8216 elsif Ekind
(Unit_Id
) = E_Package_Body
then
8217 Error_Msg_NE
("\\ body of unit & elaborated", Error_Nod
, Unit_Id
);
8220 Error_Msg_NE
("\\ in body of unit &", Error_Nod
, Unit_Id
);
8224 --------------------------
8225 -- Output_Instantiation --
8226 --------------------------
8228 procedure Output_Instantiation
(N
: Node_Id
) is
8229 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String);
8230 pragma Inline
(Output_Instantiation
);
8231 -- Emit a specific diagnostic message concerning an instantiation of
8232 -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
8234 --------------------------
8235 -- Output_Instantiation --
8236 --------------------------
8238 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String) is
8241 ("\\ " & Kind
& " & instantiated as & #", Error_Nod
, Gen_Id
);
8242 end Output_Instantiation
;
8247 Inst_Attrs
: Instantiation_Attributes
;
8248 Inst_Id
: Entity_Id
;
8251 -- Start of processing for Output_Instantiation
8254 Extract_Instantiation_Attributes
8259 Attrs
=> Inst_Attrs
);
8261 Error_Msg_Node_2
:= Inst_Id
;
8262 Error_Msg_Sloc
:= Sloc
(Inst
);
8264 if Nkind
(Inst
) = N_Function_Instantiation
then
8265 Output_Instantiation
(Gen_Id
, "function");
8267 elsif Nkind
(Inst
) = N_Package_Instantiation
then
8268 Output_Instantiation
(Gen_Id
, "package");
8270 elsif Nkind
(Inst
) = N_Procedure_Instantiation
then
8271 Output_Instantiation
(Gen_Id
, "procedure");
8274 pragma Assert
(False);
8277 end Output_Instantiation
;
8279 ---------------------------------------
8280 -- Output_SPARK_Refined_State_Pragma --
8281 ---------------------------------------
8283 procedure Output_SPARK_Refined_State_Pragma
(N
: Node_Id
) is
8285 Error_Msg_Sloc
:= Sloc
(N
);
8286 Error_Msg_N
("\\ refinement constituents read #", Error_Nod
);
8287 end Output_SPARK_Refined_State_Pragma
;
8289 --------------------------------
8290 -- Output_Variable_Assignment --
8291 --------------------------------
8293 procedure Output_Variable_Assignment
(N
: Node_Id
) is
8294 Var_Id
: constant Entity_Id
:= Entity
(Extract_Assignment_Name
(N
));
8297 Error_Msg_Sloc
:= Sloc
(N
);
8298 Error_Msg_NE
("\\ variable & assigned #", Error_Nod
, Var_Id
);
8299 end Output_Variable_Assignment
;
8301 -------------------------------
8302 -- Output_Variable_Reference --
8303 -------------------------------
8305 procedure Output_Variable_Reference
(N
: Node_Id
) is
8306 Dummy
: Variable_Attributes
;
8310 Extract_Variable_Reference_Attributes
8315 Error_Msg_Sloc
:= Sloc
(N
);
8318 Error_Msg_NE
("\\ variable & read #", Error_Nod
, Var_Id
);
8321 pragma Assert
(False);
8324 end Output_Variable_Reference
;
8328 package Stack
renames Scenario_Stack
;
8330 Dummy
: Call_Attributes
;
8333 Target_Id
: Entity_Id
;
8335 -- Start of processing for Output_Active_Scenarios
8338 -- Active scenarios are emitted only when the static model is in effect
8339 -- because there is an inherent order by which all these scenarios were
8340 -- reached from the declaration or library level.
8342 if not Static_Elaboration_Checks
then
8348 for Index
in Stack
.First
.. Stack
.Last
loop
8349 N
:= Stack
.Table
(Index
);
8358 if Nkind
(N
) = N_Attribute_Reference
then
8363 elsif Is_Suitable_Call
(N
) then
8364 Extract_Call_Attributes
8366 Target_Id
=> Target_Id
,
8369 if Is_Activation_Proc
(Target_Id
) then
8370 Output_Activation_Call
(N
);
8372 Output_Call
(N
, Target_Id
);
8377 elsif Is_Suitable_Instantiation
(N
) then
8378 Output_Instantiation
(N
);
8380 -- Pragma Refined_State
8382 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
8383 Output_SPARK_Refined_State_Pragma
(N
);
8385 -- Variable assignments
8387 elsif Nkind
(N
) = N_Assignment_Statement
then
8388 Output_Variable_Assignment
(N
);
8390 -- Variable references
8392 elsif Is_Suitable_Variable_Reference
(N
) then
8393 Output_Variable_Reference
(N
);
8396 pragma Assert
(False);
8400 end Output_Active_Scenarios
;
8402 -------------------------
8403 -- Pop_Active_Scenario --
8404 -------------------------
8406 procedure Pop_Active_Scenario
(N
: Node_Id
) is
8407 Top
: Node_Id
renames Scenario_Stack
.Table
(Scenario_Stack
.Last
);
8410 pragma Assert
(Top
= N
);
8411 Scenario_Stack
.Decrement_Last
;
8412 end Pop_Active_Scenario
;
8414 --------------------------------
8415 -- Process_Activation_Generic --
8416 --------------------------------
8418 procedure Process_Activation_Generic
8420 Call_Attrs
: Call_Attributes
;
8421 State
: Processing_Attributes
)
8423 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
);
8424 -- Perform ABE checks and diagnostics for object Obj_Id with type Typ.
8425 -- Typ may be a task type or a composite type with at least one task
8428 procedure Process_Task_Objects
(List
: List_Id
);
8429 -- Perform ABE checks and diagnostics for all task objects found in
8432 -------------------------
8433 -- Process_Task_Object --
8434 -------------------------
8436 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
) is
8437 Base_Typ
: constant Entity_Id
:= Base_Type
(Typ
);
8439 Comp_Id
: Entity_Id
;
8440 Task_Attrs
: Task_Attributes
;
8443 if Is_Task_Type
(Typ
) then
8444 Extract_Task_Attributes
8446 Attrs
=> Task_Attrs
);
8448 Process_Single_Activation
8450 Call_Attrs
=> Call_Attrs
,
8452 Task_Attrs
=> Task_Attrs
,
8455 -- Examine the component type when the object is an array
8457 elsif Is_Array_Type
(Typ
) and then Has_Task
(Base_Typ
) then
8458 Process_Task_Object
(Obj_Id
, Component_Type
(Typ
));
8460 -- Examine individual component types when the object is a record
8462 elsif Is_Record_Type
(Typ
) and then Has_Task
(Base_Typ
) then
8463 Comp_Id
:= First_Component
(Typ
);
8464 while Present
(Comp_Id
) loop
8465 Process_Task_Object
(Obj_Id
, Etype
(Comp_Id
));
8466 Next_Component
(Comp_Id
);
8469 end Process_Task_Object
;
8471 --------------------------
8472 -- Process_Task_Objects --
8473 --------------------------
8475 procedure Process_Task_Objects
(List
: List_Id
) is
8477 Item_Id
: Entity_Id
;
8478 Item_Typ
: Entity_Id
;
8481 -- Examine the contents of the list looking for an object declaration
8482 -- of a task type or one that contains a task within.
8484 Item
:= First
(List
);
8485 while Present
(Item
) loop
8486 if Nkind
(Item
) = N_Object_Declaration
then
8487 Item_Id
:= Defining_Entity
(Item
);
8488 Item_Typ
:= Etype
(Item_Id
);
8490 if Has_Task
(Item_Typ
) then
8491 Process_Task_Object
(Item_Id
, Item_Typ
);
8497 end Process_Task_Objects
;
8504 -- Start of processing for Process_Activation_Generic
8507 -- Nothing to do when the activation is a guaranteed ABE
8509 if Is_Known_Guaranteed_ABE
(Call
) then
8513 -- Find the proper context of the activation call where all task objects
8514 -- being activated are declared. This is usually the immediate parent of
8517 Context
:= Parent
(Call
);
8519 -- In the case of package bodies, the activation call is in the handled
8520 -- sequence of statements, but the task objects are in the declaration
8521 -- list of the body.
8523 if Nkind
(Context
) = N_Handled_Sequence_Of_Statements
8524 and then Nkind
(Parent
(Context
)) = N_Package_Body
8526 Context
:= Parent
(Context
);
8529 -- Process all task objects defined in both the spec and body when the
8530 -- activation call precedes the "begin" of a package body.
8532 if Nkind
(Context
) = N_Package_Body
then
8535 (Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
8537 Process_Task_Objects
(Visible_Declarations
(Spec
));
8538 Process_Task_Objects
(Private_Declarations
(Spec
));
8539 Process_Task_Objects
(Declarations
(Context
));
8541 -- Process all task objects defined in the spec when the activation call
8542 -- appears at the end of a package spec.
8544 elsif Nkind
(Context
) = N_Package_Specification
then
8545 Process_Task_Objects
(Visible_Declarations
(Context
));
8546 Process_Task_Objects
(Private_Declarations
(Context
));
8548 -- Otherwise the context of the activation is some construct with a
8549 -- declarative part. Note that the corresponding record type of a task
8550 -- type is controlled. Because of this, the finalization machinery must
8551 -- relocate the task object to the handled statements of the construct
8552 -- to perform proper finalization in case of an exception. Examine the
8553 -- statements of the construct rather than the declarations.
8556 pragma Assert
(Nkind
(Context
) = N_Handled_Sequence_Of_Statements
);
8558 Process_Task_Objects
(Statements
(Context
));
8560 end Process_Activation_Generic
;
8562 ------------------------------------
8563 -- Process_Conditional_ABE_Access --
8564 ------------------------------------
8566 procedure Process_Conditional_ABE_Access
8568 State
: Processing_Attributes
)
8570 function Build_Access_Marker
(Target_Id
: Entity_Id
) return Node_Id
;
8571 pragma Inline
(Build_Access_Marker
);
8572 -- Create a suitable call marker which invokes target Target_Id
8574 -------------------------
8575 -- Build_Access_Marker --
8576 -------------------------
8578 function Build_Access_Marker
(Target_Id
: Entity_Id
) return Node_Id
is
8582 Marker
:= Make_Call_Marker
(Sloc
(Attr
));
8584 -- Inherit relevant attributes from the attribute
8586 -- Performance note: parent traversal
8588 Set_Target
(Marker
, Target_Id
);
8589 Set_Is_Declaration_Level_Node
8590 (Marker
, Find_Enclosing_Level
(Attr
) = Declaration_Level
);
8591 Set_Is_Dispatching_Call
8593 Set_Is_Elaboration_Checks_OK_Node
8594 (Marker
, Is_Elaboration_Checks_OK_Node
(Attr
));
8596 (Marker
, Comes_From_Source
(Attr
));
8597 Set_Is_SPARK_Mode_On_Node
8598 (Marker
, Is_SPARK_Mode_On_Node
(Attr
));
8600 -- Partially insert the call marker into the tree by setting its
8603 Set_Parent
(Marker
, Attr
);
8606 end Build_Access_Marker
;
8610 Root
: constant Node_Id
:= Root_Scenario
;
8611 Target_Id
: constant Entity_Id
:= Entity
(Prefix
(Attr
));
8613 Target_Attrs
: Target_Attributes
;
8615 -- Start of processing for Process_Conditional_ABE_Access
8618 -- Output relevant information when switch -gnatel (info messages on
8619 -- implicit Elaborate[_All] pragmas) is in effect.
8621 if Elab_Info_Messages
then
8623 ("info: access to & during elaboration", Attr
, Target_Id
);
8626 Extract_Target_Attributes
8627 (Target_Id
=> Target_Id
,
8628 Attrs
=> Target_Attrs
);
8630 -- Both the attribute and the corresponding body are in the same unit.
8631 -- The corresponding body must appear prior to the root scenario which
8632 -- started the recursive search. If this is not the case, then there is
8633 -- a potential ABE if the access value is used to call the subprogram.
8634 -- Emit a warning only when switch -gnatw.f (warnings on suspucious
8635 -- 'Access) is in effect.
8637 if Warn_On_Elab_Access
8638 and then Present
(Target_Attrs
.Body_Decl
)
8639 and then In_Extended_Main_Code_Unit
(Target_Attrs
.Body_Decl
)
8640 and then Earlier_In_Extended_Unit
(Root
, Target_Attrs
.Body_Decl
)
8642 Error_Msg_Name_1
:= Attribute_Name
(Attr
);
8643 Error_Msg_NE
("??% attribute of & before body seen", Attr
, Target_Id
);
8644 Error_Msg_N
("\possible Program_Error on later references", Attr
);
8646 Output_Active_Scenarios
(Attr
);
8649 -- Treat the attribute as an immediate invocation of the target when
8650 -- switch -gnatd.o (conservative elaboration order for indirect calls)
8651 -- is in effect. Note that the prior elaboration of the unit containing
8652 -- the target is ensured processing the corresponding call marker.
8654 if Debug_Flag_Dot_O
then
8655 Process_Conditional_ABE
8656 (N
=> Build_Access_Marker
(Target_Id
),
8659 -- Otherwise ensure that the unit with the corresponding body is
8660 -- elaborated prior to the main unit.
8663 Ensure_Prior_Elaboration
8665 Unit_Id
=> Target_Attrs
.Unit_Id
,
8666 Prag_Nam
=> Name_Elaborate_All
,
8669 end Process_Conditional_ABE_Access
;
8671 ---------------------------------------------
8672 -- Process_Conditional_ABE_Activation_Impl --
8673 ---------------------------------------------
8675 procedure Process_Conditional_ABE_Activation_Impl
8677 Call_Attrs
: Call_Attributes
;
8679 Task_Attrs
: Task_Attributes
;
8680 State
: Processing_Attributes
)
8682 Check_OK
: constant Boolean :=
8683 not Is_Ignored_Ghost_Entity
(Obj_Id
)
8684 and then not Task_Attrs
.Ghost_Mode_Ignore
8685 and then Is_Elaboration_Checks_OK_Id
(Obj_Id
)
8686 and then Task_Attrs
.Elab_Checks_OK
;
8687 -- A run-time ABE check may be installed only when the object and the
8688 -- task type have active elaboration checks, and both are not ignored
8689 -- Ghost constructs.
8691 Root
: constant Node_Id
:= Root_Scenario
;
8693 New_State
: Processing_Attributes
:= State
;
8694 -- Each step of the Processing phase constitutes a new state
8697 -- Output relevant information when switch -gnatel (info messages on
8698 -- implicit Elaborate[_All] pragmas) is in effect.
8700 if Elab_Info_Messages
then
8702 ("info: activation of & during elaboration", Call
, Obj_Id
);
8705 -- Nothing to do when the call activates a task whose type is defined
8706 -- within an instance and switch -gnatd_i (ignore activations and calls
8707 -- to instances for elaboration) is in effect.
8709 if Debug_Flag_Underscore_I
8710 and then In_External_Instance
8712 Target_Decl
=> Task_Attrs
.Task_Decl
)
8716 -- Nothing to do when the activation is a guaranteed ABE
8718 elsif Is_Known_Guaranteed_ABE
(Call
) then
8721 -- Nothing to do when the root scenario appears at the declaration
8722 -- level and the task is in the same unit, but outside this context.
8724 -- task type Task_Typ; -- task declaration
8726 -- procedure Proc is
8727 -- function A ... is
8729 -- if Some_Condition then
8733 -- <activation call> -- activation site
8738 -- X : ... := A; -- root scenario
8741 -- task body Task_Typ is
8745 -- In the example above, the context of X is the declarative list of
8746 -- Proc. The "elaboration" of X may reach the activation of T whose body
8747 -- is defined outside of X's context. The task body is relevant only
8748 -- when Proc is invoked, but this happens only in "normal" elaboration,
8749 -- therefore the task body must not be considered if this is not the
8752 -- Performance note: parent traversal
8754 elsif Is_Up_Level_Target
(Task_Attrs
.Task_Decl
) then
8757 -- Nothing to do when the activation is ABE-safe
8761 -- task type Task_Typ;
8764 -- package body Gen is
8765 -- task body Task_Typ is
8772 -- procedure Main is
8773 -- package Nested is
8774 -- package Inst is new Gen;
8775 -- T : Inst.Task_Typ;
8776 -- <activation call> -- safe activation
8780 elsif Is_Safe_Activation
(Call
, Task_Attrs
.Task_Decl
) then
8782 -- Note that the task body must still be examined for any nested
8787 -- The activation call and the task body are both in the main unit
8789 elsif Present
(Task_Attrs
.Body_Decl
)
8790 and then In_Extended_Main_Code_Unit
(Task_Attrs
.Body_Decl
)
8792 -- If the root scenario appears prior to the task body, then this is
8793 -- a possible ABE with respect to the root scenario.
8795 -- task type Task_Typ;
8797 -- function A ... is
8799 -- if Some_Condition then
8803 -- end Pack; -- activation of T
8807 -- X : ... := A; -- root scenario
8809 -- task body Task_Typ is -- task body
8813 -- Y : ... := A; -- root scenario
8815 -- IMPORTANT: The activation of T is a possible ABE for X, but
8816 -- not for Y. Intalling an unconditional ABE raise prior to the
8817 -- activation call would be wrong as it will fail for Y as well
8818 -- but in Y's case the activation of T is never an ABE.
8820 if Earlier_In_Extended_Unit
(Root
, Task_Attrs
.Body_Decl
) then
8822 -- Do not emit any ABE diagnostics when the activation occurs in
8823 -- a partial finalization context because this leads to confusing
8826 if State
.Within_Partial_Finalization
then
8829 -- ABE diagnostics are emitted only in the static model because
8830 -- there is a well-defined order to visiting scenarios. Without
8831 -- this order diagnostics appear jumbled and result in unwanted
8834 elsif Static_Elaboration_Checks
8835 and then Call_Attrs
.Elab_Warnings_OK
8837 Error_Msg_Sloc
:= Sloc
(Call
);
8839 ("??task & will be activated # before elaboration of its "
8842 ("\Program_Error may be raised at run time", Obj_Id
);
8844 Output_Active_Scenarios
(Obj_Id
);
8847 -- Install a conditional run-time ABE check to verify that the
8848 -- task body has been elaborated prior to the activation call.
8854 Target_Id
=> Task_Attrs
.Spec_Id
,
8855 Target_Decl
=> Task_Attrs
.Task_Decl
,
8856 Target_Body
=> Task_Attrs
.Body_Decl
);
8858 -- Update the state of the Processing phase to indicate that
8859 -- no implicit Elaborate[_All] pragmas must be generated from
8862 -- task type Task_Typ;
8864 -- function A ... is
8866 -- if Some_Condition then
8871 -- end Pack; -- activation of T
8877 -- task body Task_Typ is
8879 -- External.Subp; -- imparts Elaborate_All
8882 -- If Some_Condition is True, then the ABE check will fail at
8883 -- runtime and the call to External.Subp will never take place,
8884 -- rendering the implicit Elaborate_All useless.
8886 -- If Some_Condition is False, then the call to External.Subp
8887 -- will never take place, rendering the implicit Elaborate_All
8890 New_State
.Suppress_Implicit_Pragmas
:= True;
8894 -- Otherwise the task body is not available in this compilation or it
8895 -- resides in an external unit. Install a run-time ABE check to verify
8896 -- that the task body has been elaborated prior to the activation call
8897 -- when the dynamic model is in effect.
8899 elsif Dynamic_Elaboration_Checks
and then Check_OK
then
8903 Id
=> Task_Attrs
.Unit_Id
);
8906 -- Update the state of the Processing phase to indicate that any further
8907 -- traversal is now within a task body.
8909 New_State
.Within_Task_Body
:= True;
8911 -- Both the activation call and task type are subject to SPARK_Mode
8912 -- On, this triggers the SPARK rules for task activation. Compared to
8913 -- calls and instantiations, task activation in SPARK does not require
8914 -- the presence of Elaborate[_All] pragmas in case the task type is
8915 -- defined outside the main unit. This is because SPARK utilizes a
8916 -- special policy which activates all tasks after the main unit has
8917 -- finished its elaboration.
8919 if Call_Attrs
.SPARK_Mode_On
and Task_Attrs
.SPARK_Mode_On
then
8922 -- Otherwise the Ada rules are in effect. Ensure that the unit with the
8923 -- task body is elaborated prior to the main unit.
8926 Ensure_Prior_Elaboration
8928 Unit_Id
=> Task_Attrs
.Unit_Id
,
8929 Prag_Nam
=> Name_Elaborate_All
,
8930 State
=> New_State
);
8934 (N
=> Task_Attrs
.Body_Decl
,
8935 State
=> New_State
);
8936 end Process_Conditional_ABE_Activation_Impl
;
8938 procedure Process_Conditional_ABE_Activation
is
8939 new Process_Activation_Generic
(Process_Conditional_ABE_Activation_Impl
);
8941 ----------------------------------
8942 -- Process_Conditional_ABE_Call --
8943 ----------------------------------
8945 procedure Process_Conditional_ABE_Call
8947 Call_Attrs
: Call_Attributes
;
8948 Target_Id
: Entity_Id
;
8949 State
: Processing_Attributes
)
8951 function In_Initialization_Context
(N
: Node_Id
) return Boolean;
8952 -- Determine whether arbitrary node N appears within a type init proc,
8953 -- primitive [Deep_]Initialize, or a block created for initialization
8956 function Is_Partial_Finalization_Proc
return Boolean;
8957 pragma Inline
(Is_Partial_Finalization_Proc
);
8958 -- Determine whether call Call with target Target_Id invokes a partial
8959 -- finalization procedure.
8961 -------------------------------
8962 -- In_Initialization_Context --
8963 -------------------------------
8965 function In_Initialization_Context
(N
: Node_Id
) return Boolean is
8967 Spec_Id
: Entity_Id
;
8970 -- Climb the parent chain looking for initialization actions
8973 while Present
(Par
) loop
8975 -- A block may be part of the initialization actions of a default
8976 -- initialized object.
8978 if Nkind
(Par
) = N_Block_Statement
8979 and then Is_Initialization_Block
(Par
)
8983 -- A subprogram body may denote an initialization routine
8985 elsif Nkind
(Par
) = N_Subprogram_Body
then
8986 Spec_Id
:= Unique_Defining_Entity
(Par
);
8988 -- The current subprogram body denotes a type init proc or
8989 -- primitive [Deep_]Initialize.
8991 if Is_Init_Proc
(Spec_Id
)
8992 or else Is_Controlled_Proc
(Spec_Id
, Name_Initialize
)
8993 or else Is_TSS
(Spec_Id
, TSS_Deep_Initialize
)
8998 -- Prevent the search from going too far
9000 elsif Is_Body_Or_Package_Declaration
(Par
) then
9004 Par
:= Parent
(Par
);
9008 end In_Initialization_Context
;
9010 ----------------------------------
9011 -- Is_Partial_Finalization_Proc --
9012 ----------------------------------
9014 function Is_Partial_Finalization_Proc
return Boolean is
9016 -- To qualify, the target must denote primitive [Deep_]Finalize or a
9017 -- finalizer procedure, and the call must appear in an initialization
9021 (Is_Controlled_Proc
(Target_Id
, Name_Finalize
)
9022 or else Is_Finalizer_Proc
(Target_Id
)
9023 or else Is_TSS
(Target_Id
, TSS_Deep_Finalize
))
9024 and then In_Initialization_Context
(Call
);
9025 end Is_Partial_Finalization_Proc
;
9029 SPARK_Rules_On
: Boolean;
9030 Target_Attrs
: Target_Attributes
;
9032 New_State
: Processing_Attributes
:= State
;
9033 -- Each step of the Processing phase constitutes a new state
9035 -- Start of processing for Process_Conditional_ABE_Call
9038 Extract_Target_Attributes
9039 (Target_Id
=> Target_Id
,
9040 Attrs
=> Target_Attrs
);
9042 -- The SPARK rules are in effect when both the call and target are
9043 -- subject to SPARK_Mode On.
9046 Call_Attrs
.SPARK_Mode_On
and Target_Attrs
.SPARK_Mode_On
;
9048 -- Output relevant information when switch -gnatel (info messages on
9049 -- implicit Elaborate[_All] pragmas) is in effect.
9051 if Elab_Info_Messages
then
9054 Target_Id
=> Target_Id
,
9056 In_SPARK
=> SPARK_Rules_On
);
9059 -- Check whether the invocation of an entry clashes with an existing
9062 if Is_Protected_Entry
(Target_Id
) then
9063 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
9065 elsif Is_Task_Entry
(Target_Id
) then
9066 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
9068 -- Task entry calls are never processed because the entry being
9069 -- invoked does not have a corresponding "body", it has a select.
9074 -- Nothing to do when the call invokes a target defined within an
9075 -- instance and switch -gnatd_i (ignore activations and calls to
9076 -- instances for elaboration) is in effect.
9078 if Debug_Flag_Underscore_I
9079 and then In_External_Instance
9081 Target_Decl
=> Target_Attrs
.Spec_Decl
)
9085 -- Nothing to do when the call is a guaranteed ABE
9087 elsif Is_Known_Guaranteed_ABE
(Call
) then
9090 -- Nothing to do when the root scenario appears at the declaration level
9091 -- and the target is in the same unit, but outside this context.
9093 -- function B ...; -- target declaration
9095 -- procedure Proc is
9096 -- function A ... is
9098 -- if Some_Condition then
9099 -- return B; -- call site
9103 -- X : ... := A; -- root scenario
9106 -- function B ... is
9110 -- In the example above, the context of X is the declarative region of
9111 -- Proc. The "elaboration" of X may eventually reach B which is defined
9112 -- outside of X's context. B is relevant only when Proc is invoked, but
9113 -- this happens only by means of "normal" elaboration, therefore B must
9114 -- not be considered if this is not the case.
9116 -- Performance note: parent traversal
9118 elsif Is_Up_Level_Target
(Target_Attrs
.Spec_Decl
) then
9122 -- The call occurs in an initial condition context when a prior scenario
9123 -- is already in that mode, or when the target is an Initial_Condition
9124 -- procedure. Update the state of the Processing phase to reflect this.
9126 New_State
.Within_Initial_Condition
:=
9127 New_State
.Within_Initial_Condition
9128 or else Is_Initial_Condition_Proc
(Target_Id
);
9130 -- The call occurs in a partial finalization context when a prior
9131 -- scenario is already in that mode, or when the target denotes a
9132 -- [Deep_]Finalize primitive or a finalizer within an initialization
9133 -- context. Update the state of the Processing phase to reflect this.
9135 New_State
.Within_Partial_Finalization
:=
9136 New_State
.Within_Partial_Finalization
9137 or else Is_Partial_Finalization_Proc
;
9139 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK
9140 -- elaboration rules in SPARK code) is intentionally not taken into
9141 -- account here because Process_Conditional_ABE_Call_SPARK has two
9142 -- separate modes of operation.
9144 if SPARK_Rules_On
then
9145 Process_Conditional_ABE_Call_SPARK
9147 Target_Id
=> Target_Id
,
9148 Target_Attrs
=> Target_Attrs
,
9149 State
=> New_State
);
9151 -- Otherwise the Ada rules are in effect
9154 Process_Conditional_ABE_Call_Ada
9156 Call_Attrs
=> Call_Attrs
,
9157 Target_Id
=> Target_Id
,
9158 Target_Attrs
=> Target_Attrs
,
9159 State
=> New_State
);
9162 -- Inspect the target body (and barried function) for other suitable
9163 -- elaboration scenarios.
9166 (N
=> Target_Attrs
.Body_Barf
,
9167 State
=> New_State
);
9170 (N
=> Target_Attrs
.Body_Decl
,
9171 State
=> New_State
);
9172 end Process_Conditional_ABE_Call
;
9174 --------------------------------------
9175 -- Process_Conditional_ABE_Call_Ada --
9176 --------------------------------------
9178 procedure Process_Conditional_ABE_Call_Ada
9180 Call_Attrs
: Call_Attributes
;
9181 Target_Id
: Entity_Id
;
9182 Target_Attrs
: Target_Attributes
;
9183 State
: Processing_Attributes
)
9185 Check_OK
: constant Boolean :=
9186 not Call_Attrs
.Ghost_Mode_Ignore
9187 and then not Target_Attrs
.Ghost_Mode_Ignore
9188 and then Call_Attrs
.Elab_Checks_OK
9189 and then Target_Attrs
.Elab_Checks_OK
;
9190 -- A run-time ABE check may be installed only when both the call and the
9191 -- target have active elaboration checks, and both are not ignored Ghost
9194 Root
: constant Node_Id
:= Root_Scenario
;
9196 New_State
: Processing_Attributes
:= State
;
9197 -- Each step of the Processing phase constitutes a new state
9200 -- Nothing to do for an Ada dispatching call because there are no ABE
9201 -- diagnostics for either models. ABE checks for the dynamic model are
9202 -- handled by Install_Primitive_Elaboration_Check.
9204 if Call_Attrs
.Is_Dispatching
then
9207 -- Nothing to do when the call is ABE-safe
9210 -- function Gen ...;
9212 -- function Gen ... is
9218 -- procedure Main is
9219 -- function Inst is new Gen;
9220 -- X : ... := Inst; -- safe call
9223 elsif Is_Safe_Call
(Call
, Target_Attrs
) then
9226 -- The call and the target body are both in the main unit
9228 elsif Present
(Target_Attrs
.Body_Decl
)
9229 and then In_Extended_Main_Code_Unit
(Target_Attrs
.Body_Decl
)
9231 -- If the root scenario appears prior to the target body, then this
9232 -- is a possible ABE with respect to the root scenario.
9236 -- function A ... is
9238 -- if Some_Condition then
9239 -- return B; -- call site
9243 -- X : ... := A; -- root scenario
9245 -- function B ... is -- target body
9249 -- Y : ... := A; -- root scenario
9251 -- IMPORTANT: The call to B from A is a possible ABE for X, but not
9252 -- for Y. Installing an unconditional ABE raise prior to the call to
9253 -- B would be wrong as it will fail for Y as well, but in Y's case
9254 -- the call to B is never an ABE.
9256 if Earlier_In_Extended_Unit
(Root
, Target_Attrs
.Body_Decl
) then
9258 -- Do not emit any ABE diagnostics when the call occurs in a
9259 -- partial finalization context because this leads to confusing
9262 if State
.Within_Partial_Finalization
then
9265 -- ABE diagnostics are emitted only in the static model because
9266 -- there is a well-defined order to visiting scenarios. Without
9267 -- this order diagnostics appear jumbled and result in unwanted
9270 elsif Static_Elaboration_Checks
9271 and then Call_Attrs
.Elab_Warnings_OK
9274 ("??cannot call & before body seen", Call
, Target_Id
);
9275 Error_Msg_N
("\Program_Error may be raised at run time", Call
);
9277 Output_Active_Scenarios
(Call
);
9280 -- Install a conditional run-time ABE check to verify that the
9281 -- target body has been elaborated prior to the call.
9287 Target_Id
=> Target_Attrs
.Spec_Id
,
9288 Target_Decl
=> Target_Attrs
.Spec_Decl
,
9289 Target_Body
=> Target_Attrs
.Body_Decl
);
9291 -- Update the state of the Processing phase to indicate that
9292 -- no implicit Elaborate[_All] pragmas must be generated from
9297 -- function A ... is
9299 -- if Some_Condition then
9307 -- function B ... is
9308 -- External.Subp; -- imparts Elaborate_All
9311 -- If Some_Condition is True, then the ABE check will fail at
9312 -- runtime and the call to External.Subp will never take place,
9313 -- rendering the implicit Elaborate_All useless.
9315 -- If Some_Condition is False, then the call to External.Subp
9316 -- will never take place, rendering the implicit Elaborate_All
9319 New_State
.Suppress_Implicit_Pragmas
:= True;
9323 -- Otherwise the target body is not available in this compilation or it
9324 -- resides in an external unit. Install a run-time ABE check to verify
9325 -- that the target body has been elaborated prior to the call site when
9326 -- the dynamic model is in effect.
9328 elsif Dynamic_Elaboration_Checks
and then Check_OK
then
9332 Id
=> Target_Attrs
.Unit_Id
);
9335 -- Ensure that the unit with the target body is elaborated prior to the
9336 -- main unit. The implicit Elaborate[_All] is generated only when the
9337 -- call has elaboration checks enabled. This behaviour parallels that of
9338 -- the old ABE mechanism.
9340 if Call_Attrs
.Elab_Checks_OK
then
9341 Ensure_Prior_Elaboration
9343 Unit_Id
=> Target_Attrs
.Unit_Id
,
9344 Prag_Nam
=> Name_Elaborate_All
,
9345 State
=> New_State
);
9347 end Process_Conditional_ABE_Call_Ada
;
9349 ----------------------------------------
9350 -- Process_Conditional_ABE_Call_SPARK --
9351 ----------------------------------------
9353 procedure Process_Conditional_ABE_Call_SPARK
9355 Target_Id
: Entity_Id
;
9356 Target_Attrs
: Target_Attributes
;
9357 State
: Processing_Attributes
)
9362 -- Ensure that a suitable elaboration model is in effect for SPARK rule
9365 Check_SPARK_Model_In_Effect
(Call
);
9367 -- The call and the target body are both in the main unit
9369 if Present
(Target_Attrs
.Body_Decl
)
9370 and then In_Extended_Main_Code_Unit
(Target_Attrs
.Body_Decl
)
9372 -- If the call appears prior to the target body, then the call must
9373 -- appear within the early call region of the target body.
9377 -- X : ... := B; -- call site
9379 -- <preelaborable construct 1> --+
9380 -- ... | early call region
9381 -- <preelaborable construct N> --+
9383 -- function B ... is -- target body
9387 -- When the call to B is not nested within some other scenario, the
9388 -- call is automatically illegal because it can never appear in the
9389 -- early call region of B's body. This is equivalent to a guaranteed
9392 -- <preelaborable construct 1> --+
9394 -- function B ...; |
9396 -- function A ... is |
9397 -- begin | early call region
9398 -- if Some_Condition then
9399 -- return B; -- call site
9403 -- <preelaborable construct N> --+
9405 -- function B ... is -- target body
9409 -- When the call to B is nested within some other scenario, the call
9410 -- is always ABE-safe. It is not immediately obvious why this is the
9411 -- case. The elaboration safety follows from the early call region
9412 -- rule being applied to ALL calls preceding their associated bodies.
9414 -- In the example above, the call to B is safe as long as the call to
9415 -- A is safe. There are several cases to consider:
9421 -- function A ... is
9423 -- if Some_Condition then
9429 -- function B ... is
9433 -- * Call 1 - This call is either nested within some scenario or not,
9434 -- which falls under the two general cases outlined above.
9436 -- * Call 2 - This is the same case as Call 1.
9438 -- * Call 3 - The placement of this call limits the range of B's
9439 -- early call region unto call 3, therefore the call to B is no
9440 -- longer within the early call region of B's body, making it ABE-
9441 -- unsafe and therefore illegal.
9443 if Earlier_In_Extended_Unit
(Call
, Target_Attrs
.Body_Decl
) then
9445 -- Do not emit any ABE diagnostics when the call occurs in an
9446 -- initial condition context because this leads to incorrect
9449 if State
.Within_Initial_Condition
then
9452 -- Do not emit any ABE diagnostics when the call occurs in a
9453 -- partial finalization context because this leads to confusing
9456 elsif State
.Within_Partial_Finalization
then
9459 -- ABE diagnostics are emitted only in the static model because
9460 -- there is a well-defined order to visiting scenarios. Without
9461 -- this order diagnostics appear jumbled and result in unwanted
9464 elsif Static_Elaboration_Checks
then
9466 -- Ensure that a call which textually precedes the subprogram
9467 -- body it invokes appears within the early call region of the
9470 -- IMPORTANT: This check must always be performed even when
9471 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is
9472 -- not specified because the static model cannot guarantee the
9473 -- absence of elaboration issues in the presence of dispatching
9476 Region
:= Find_Early_Call_Region
(Target_Attrs
.Body_Decl
);
9478 if Earlier_In_Extended_Unit
(Call
, Region
) then
9480 ("call must appear within early call region of subprogram "
9481 & "body & (SPARK RM 7.7(3))", Call
, Target_Id
);
9483 Error_Msg_Sloc
:= Sloc
(Region
);
9484 Error_Msg_N
("\region starts #", Call
);
9486 Error_Msg_Sloc
:= Sloc
(Target_Attrs
.Body_Decl
);
9487 Error_Msg_N
("\region ends #", Call
);
9489 Output_Active_Scenarios
(Call
);
9493 -- Otherwise the call appears after the target body. The call is
9494 -- ABE-safe as a consequence of applying the early call region rule
9495 -- to ALL calls preceding their associated bodies.
9502 -- A call to a source target or to a target which emulates Ada or SPARK
9503 -- semantics imposes an Elaborate_All requirement on the context of the
9504 -- main unit. Determine whether the context has a pragma strong enough
9505 -- to meet the requirement.
9507 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce
9508 -- SPARK elaboration rules in SPARK code) is active because the static
9509 -- model can ensure the prior elaboration of the unit which contains a
9510 -- body by installing an implicit Elaborate[_All] pragma.
9512 if Debug_Flag_Dot_V
then
9513 if Target_Attrs
.From_Source
9514 or else Is_Ada_Semantic_Target
(Target_Id
)
9515 or else Is_SPARK_Semantic_Target
(Target_Id
)
9517 Meet_Elaboration_Requirement
9519 Target_Id
=> Target_Id
,
9520 Req_Nam
=> Name_Elaborate_All
);
9523 -- Otherwise ensure that the unit with the target body is elaborated
9524 -- prior to the main unit.
9527 Ensure_Prior_Elaboration
9529 Unit_Id
=> Target_Attrs
.Unit_Id
,
9530 Prag_Nam
=> Name_Elaborate_All
,
9533 end Process_Conditional_ABE_Call_SPARK
;
9535 -------------------------------------------
9536 -- Process_Conditional_ABE_Instantiation --
9537 -------------------------------------------
9539 procedure Process_Conditional_ABE_Instantiation
9540 (Exp_Inst
: Node_Id
;
9541 State
: Processing_Attributes
)
9543 Gen_Attrs
: Target_Attributes
;
9546 Inst_Attrs
: Instantiation_Attributes
;
9547 Inst_Id
: Entity_Id
;
9549 SPARK_Rules_On
: Boolean;
9550 -- This flag is set when the SPARK rules are in effect
9553 Extract_Instantiation_Attributes
9554 (Exp_Inst
=> Exp_Inst
,
9558 Attrs
=> Inst_Attrs
);
9560 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
9562 -- The SPARK rules are in effect when both the instantiation and generic
9563 -- are subject to SPARK_Mode On.
9565 SPARK_Rules_On
:= Inst_Attrs
.SPARK_Mode_On
and Gen_Attrs
.SPARK_Mode_On
;
9567 -- Output relevant information when switch -gnatel (info messages on
9568 -- implicit Elaborate[_All] pragmas) is in effect.
9570 if Elab_Info_Messages
then
9575 In_SPARK
=> SPARK_Rules_On
);
9578 -- Nothing to do when the instantiation is a guaranteed ABE
9580 if Is_Known_Guaranteed_ABE
(Inst
) then
9583 -- Nothing to do when the root scenario appears at the declaration level
9584 -- and the generic is in the same unit, but outside this context.
9587 -- procedure Gen is ...; -- generic declaration
9589 -- procedure Proc is
9590 -- function A ... is
9592 -- if Some_Condition then
9594 -- procedure I is new Gen; -- instantiation site
9599 -- X : ... := A; -- root scenario
9606 -- In the example above, the context of X is the declarative region of
9607 -- Proc. The "elaboration" of X may eventually reach Gen which appears
9608 -- outside of X's context. Gen is relevant only when Proc is invoked,
9609 -- but this happens only by means of "normal" elaboration, therefore
9610 -- Gen must not be considered if this is not the case.
9612 -- Performance note: parent traversal
9614 elsif Is_Up_Level_Target
(Gen_Attrs
.Spec_Decl
) then
9617 -- The SPARK rules are in effect
9619 elsif SPARK_Rules_On
then
9620 Process_Conditional_ABE_Instantiation_SPARK
9623 Gen_Attrs
=> Gen_Attrs
,
9626 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
9627 -- violate the SPARK rules.
9630 Process_Conditional_ABE_Instantiation_Ada
9631 (Exp_Inst
=> Exp_Inst
,
9633 Inst_Attrs
=> Inst_Attrs
,
9635 Gen_Attrs
=> Gen_Attrs
,
9638 end Process_Conditional_ABE_Instantiation
;
9640 -----------------------------------------------
9641 -- Process_Conditional_ABE_Instantiation_Ada --
9642 -----------------------------------------------
9644 procedure Process_Conditional_ABE_Instantiation_Ada
9645 (Exp_Inst
: Node_Id
;
9647 Inst_Attrs
: Instantiation_Attributes
;
9649 Gen_Attrs
: Target_Attributes
;
9650 State
: Processing_Attributes
)
9652 Check_OK
: constant Boolean :=
9653 not Inst_Attrs
.Ghost_Mode_Ignore
9654 and then not Gen_Attrs
.Ghost_Mode_Ignore
9655 and then Inst_Attrs
.Elab_Checks_OK
9656 and then Gen_Attrs
.Elab_Checks_OK
;
9657 -- A run-time ABE check may be installed only when both the instance and
9658 -- the generic have active elaboration checks and both are not ignored
9659 -- Ghost constructs.
9661 New_State
: Processing_Attributes
:= State
;
9662 -- Each step of the Processing phase constitutes a new state
9664 Root
: constant Node_Id
:= Root_Scenario
;
9667 -- Nothing to do when the instantiation is ABE-safe
9674 -- package body Gen is
9679 -- procedure Main is
9680 -- package Inst is new Gen (ABE); -- safe instantiation
9683 if Is_Safe_Instantiation
(Inst
, Gen_Attrs
) then
9686 -- The instantiation and the generic body are both in the main unit
9688 elsif Present
(Gen_Attrs
.Body_Decl
)
9689 and then In_Extended_Main_Code_Unit
(Gen_Attrs
.Body_Decl
)
9691 -- If the root scenario appears prior to the generic body, then this
9692 -- is a possible ABE with respect to the root scenario.
9699 -- function A ... is
9701 -- if Some_Condition then
9703 -- package Inst is new Gen; -- instantiation site
9707 -- X : ... := A; -- root scenario
9709 -- package body Gen is -- generic body
9713 -- Y : ... := A; -- root scenario
9715 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but
9716 -- not for Y. Installing an unconditional ABE raise prior to the
9717 -- instance site would be wrong as it will fail for Y as well, but in
9718 -- Y's case the instantiation of Gen is never an ABE.
9720 if Earlier_In_Extended_Unit
(Root
, Gen_Attrs
.Body_Decl
) then
9722 -- Do not emit any ABE diagnostics when the instantiation occurs
9723 -- in partial finalization context because this leads to unwanted
9726 if State
.Within_Partial_Finalization
then
9729 -- ABE diagnostics are emitted only in the static model because
9730 -- there is a well-defined order to visiting scenarios. Without
9731 -- this order diagnostics appear jumbled and result in unwanted
9734 elsif Static_Elaboration_Checks
9735 and then Inst_Attrs
.Elab_Warnings_OK
9738 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
9739 Error_Msg_N
("\Program_Error may be raised at run time", Inst
);
9741 Output_Active_Scenarios
(Inst
);
9744 -- Install a conditional run-time ABE check to verify that the
9745 -- generic body has been elaborated prior to the instantiation.
9750 Ins_Nod
=> Exp_Inst
,
9751 Target_Id
=> Gen_Attrs
.Spec_Id
,
9752 Target_Decl
=> Gen_Attrs
.Spec_Decl
,
9753 Target_Body
=> Gen_Attrs
.Body_Decl
);
9755 -- Update the state of the Processing phase to indicate that
9756 -- no implicit Elaborate[_All] pragmas must be generated from
9764 -- function A ... is
9766 -- if Some_Condition then
9768 -- declare Inst is new Gen;
9774 -- package body Gen is
9776 -- External.Subp; -- imparts Elaborate_All
9779 -- If Some_Condition is True, then the ABE check will fail at
9780 -- runtime and the call to External.Subp will never take place,
9781 -- rendering the implicit Elaborate_All useless.
9783 -- If Some_Condition is False, then the call to External.Subp
9784 -- will never take place, rendering the implicit Elaborate_All
9787 New_State
.Suppress_Implicit_Pragmas
:= True;
9791 -- Otherwise the generic body is not available in this compilation or it
9792 -- resides in an external unit. Install a run-time ABE check to verify
9793 -- that the generic body has been elaborated prior to the instantiation
9794 -- when the dynamic model is in effect.
9796 elsif Dynamic_Elaboration_Checks
and then Check_OK
then
9799 Ins_Nod
=> Exp_Inst
,
9800 Id
=> Gen_Attrs
.Unit_Id
);
9803 -- Ensure that the unit with the generic body is elaborated prior to
9804 -- the main unit. No implicit pragma is generated if the instantiation
9805 -- has elaboration checks suppressed. This behaviour parallels that of
9806 -- the old ABE mechanism.
9808 if Inst_Attrs
.Elab_Checks_OK
then
9809 Ensure_Prior_Elaboration
9811 Unit_Id
=> Gen_Attrs
.Unit_Id
,
9812 Prag_Nam
=> Name_Elaborate
,
9813 State
=> New_State
);
9815 end Process_Conditional_ABE_Instantiation_Ada
;
9817 -------------------------------------------------
9818 -- Process_Conditional_ABE_Instantiation_SPARK --
9819 -------------------------------------------------
9821 procedure Process_Conditional_ABE_Instantiation_SPARK
9824 Gen_Attrs
: Target_Attributes
;
9825 State
: Processing_Attributes
)
9830 -- Ensure that a suitable elaboration model is in effect for SPARK rule
9833 Check_SPARK_Model_In_Effect
(Inst
);
9835 -- A source instantiation imposes an Elaborate[_All] requirement on the
9836 -- context of the main unit. Determine whether the context has a pragma
9837 -- strong enough to meet the requirement. The check is orthogonal to the
9838 -- ABE ramifications of the instantiation.
9840 -- IMPORTANT: This check must be performed only when -gnatd.v (enforce
9841 -- SPARK elaboration rules in SPARK code) is active because the static
9842 -- model can ensure the prior elaboration of the unit which contains a
9843 -- body by installing an implicit Elaborate[_All] pragma.
9845 if Debug_Flag_Dot_V
then
9846 if Nkind
(Inst
) = N_Package_Instantiation
then
9847 Req_Nam
:= Name_Elaborate_All
;
9849 Req_Nam
:= Name_Elaborate
;
9852 Meet_Elaboration_Requirement
9854 Target_Id
=> Gen_Id
,
9855 Req_Nam
=> Req_Nam
);
9857 -- Otherwise ensure that the unit with the target body is elaborated
9858 -- prior to the main unit.
9861 Ensure_Prior_Elaboration
9863 Unit_Id
=> Gen_Attrs
.Unit_Id
,
9864 Prag_Nam
=> Name_Elaborate
,
9867 end Process_Conditional_ABE_Instantiation_SPARK
;
9869 -------------------------------------------------
9870 -- Process_Conditional_ABE_Variable_Assignment --
9871 -------------------------------------------------
9873 procedure Process_Conditional_ABE_Variable_Assignment
(Asmt
: Node_Id
) is
9874 Var_Id
: constant Entity_Id
:= Entity
(Extract_Assignment_Name
(Asmt
));
9875 Prag
: constant Node_Id
:= SPARK_Pragma
(Var_Id
);
9877 SPARK_Rules_On
: Boolean;
9878 -- This flag is set when the SPARK rules are in effect
9881 -- The SPARK rules are in effect when both the assignment and the
9882 -- variable are subject to SPARK_Mode On.
9886 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
9887 and then Is_SPARK_Mode_On_Node
(Asmt
);
9889 -- Output relevant information when switch -gnatel (info messages on
9890 -- implicit Elaborate[_All] pragmas) is in effect.
9892 if Elab_Info_Messages
then
9894 (Msg
=> "assignment to & during elaboration",
9898 In_SPARK
=> SPARK_Rules_On
);
9901 -- The SPARK rules are in effect. These rules are applied regardless of
9902 -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is
9903 -- in effect because the static model cannot ensure safe assignment of
9906 if SPARK_Rules_On
then
9907 Process_Conditional_ABE_Variable_Assignment_SPARK
9911 -- Otherwise the Ada rules are in effect
9914 Process_Conditional_ABE_Variable_Assignment_Ada
9918 end Process_Conditional_ABE_Variable_Assignment
;
9920 -----------------------------------------------------
9921 -- Process_Conditional_ABE_Variable_Assignment_Ada --
9922 -----------------------------------------------------
9924 procedure Process_Conditional_ABE_Variable_Assignment_Ada
9928 Var_Decl
: constant Node_Id
:= Declaration_Node
(Var_Id
);
9929 Spec_Id
: constant Entity_Id
:= Find_Top_Unit
(Var_Decl
);
9932 -- Emit a warning when an uninitialized variable declared in a package
9933 -- spec without a pragma Elaborate_Body is initialized by elaboration
9934 -- code within the corresponding body.
9936 if not Warnings_Off
(Var_Id
)
9937 and then not Is_Initialized
(Var_Decl
)
9938 and then not Has_Pragma_Elaborate_Body
(Spec_Id
)
9941 ("??variable & can be accessed by clients before this "
9942 & "initialization", Asmt
, Var_Id
);
9945 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
9946 & "initialization", Asmt
, Spec_Id
);
9948 Output_Active_Scenarios
(Asmt
);
9950 -- Generate an implicit Elaborate_Body in the spec
9952 Set_Elaborate_Body_Desirable
(Spec_Id
);
9954 end Process_Conditional_ABE_Variable_Assignment_Ada
;
9956 -------------------------------------------------------
9957 -- Process_Conditional_ABE_Variable_Assignment_SPARK --
9958 -------------------------------------------------------
9960 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
9964 Var_Decl
: constant Node_Id
:= Declaration_Node
(Var_Id
);
9965 Spec_Id
: constant Entity_Id
:= Find_Top_Unit
(Var_Decl
);
9968 -- Ensure that a suitable elaboration model is in effect for SPARK rule
9971 Check_SPARK_Model_In_Effect
(Asmt
);
9973 -- Emit an error when an initialized variable declared in a package spec
9974 -- without pragma Elaborate_Body is further modified by elaboration code
9975 -- within the corresponding body.
9977 if Is_Initialized
(Var_Decl
)
9978 and then not Has_Pragma_Elaborate_Body
(Spec_Id
)
9981 ("variable & modified by elaboration code in package body",
9985 ("\add pragma ""Elaborate_Body"" to spec & to ensure full "
9986 & "initialization", Asmt
, Spec_Id
);
9988 Output_Active_Scenarios
(Asmt
);
9990 end Process_Conditional_ABE_Variable_Assignment_SPARK
;
9992 ------------------------------------------------
9993 -- Process_Conditional_ABE_Variable_Reference --
9994 ------------------------------------------------
9996 procedure Process_Conditional_ABE_Variable_Reference
(Ref
: Node_Id
) is
9997 Var_Attrs
: Variable_Attributes
;
10001 Extract_Variable_Reference_Attributes
10004 Attrs
=> Var_Attrs
);
10006 if Is_Read
(Ref
) then
10007 Process_Conditional_ABE_Variable_Reference_Read
10010 Attrs
=> Var_Attrs
);
10012 end Process_Conditional_ABE_Variable_Reference
;
10014 -----------------------------------------------------
10015 -- Process_Conditional_ABE_Variable_Reference_Read --
10016 -----------------------------------------------------
10018 procedure Process_Conditional_ABE_Variable_Reference_Read
10020 Var_Id
: Entity_Id
;
10021 Attrs
: Variable_Attributes
)
10024 -- Output relevant information when switch -gnatel (info messages on
10025 -- implicit Elaborate[_All] pragmas) is in effect.
10027 if Elab_Info_Messages
then
10029 (Msg
=> "read of variable & during elaboration",
10036 -- Nothing to do when the variable appears within the main unit because
10037 -- diagnostics on reads are relevant only for external variables.
10039 if Is_Same_Unit
(Attrs
.Unit_Id
, Cunit_Entity
(Main_Unit
)) then
10042 -- Nothing to do when the variable is already initialized. Note that the
10043 -- variable may be further modified by the external unit.
10045 elsif Is_Initialized
(Declaration_Node
(Var_Id
)) then
10048 -- Nothing to do when the external unit guarantees the initialization of
10049 -- the variable by means of pragma Elaborate_Body.
10051 elsif Has_Pragma_Elaborate_Body
(Attrs
.Unit_Id
) then
10054 -- A variable read imposes an Elaborate requirement on the context of
10055 -- the main unit. Determine whether the context has a pragma strong
10056 -- enough to meet the requirement.
10059 Meet_Elaboration_Requirement
10061 Target_Id
=> Var_Id
,
10062 Req_Nam
=> Name_Elaborate
);
10064 end Process_Conditional_ABE_Variable_Reference_Read
;
10066 -----------------------------
10067 -- Process_Conditional_ABE --
10068 -----------------------------
10070 -- NOTE: The body of this routine is intentionally out of order because it
10071 -- invokes an instantiated subprogram (Process_Conditional_ABE_Activation).
10072 -- Placing the body in alphabetical order will result in a guaranteed ABE.
10074 procedure Process_Conditional_ABE
10076 State
: Processing_Attributes
:= Initial_State
)
10078 Call_Attrs
: Call_Attributes
;
10079 Target_Id
: Entity_Id
;
10082 -- Add the current scenario to the stack of active scenarios
10084 Push_Active_Scenario
(N
);
10088 if Is_Suitable_Access
(N
) then
10089 Process_Conditional_ABE_Access
10093 -- Activations and calls
10095 elsif Is_Suitable_Call
(N
) then
10097 -- In general, only calls found within the main unit are processed
10098 -- because the ALI information supplied to binde is for the main
10099 -- unit only. However, to preserve the consistency of the tree and
10100 -- ensure proper serialization of internal names, external calls
10101 -- also receive corresponding call markers (see Build_Call_Marker).
10102 -- Regardless of the reason, external calls must not be processed.
10104 if In_Main_Context
(N
) then
10105 Extract_Call_Attributes
10107 Target_Id
=> Target_Id
,
10108 Attrs
=> Call_Attrs
);
10110 if Is_Activation_Proc
(Target_Id
) then
10111 Process_Conditional_ABE_Activation
10113 Call_Attrs
=> Call_Attrs
,
10117 Process_Conditional_ABE_Call
10119 Call_Attrs
=> Call_Attrs
,
10120 Target_Id
=> Target_Id
,
10127 elsif Is_Suitable_Instantiation
(N
) then
10128 Process_Conditional_ABE_Instantiation
10132 -- Variable assignments
10134 elsif Is_Suitable_Variable_Assignment
(N
) then
10135 Process_Conditional_ABE_Variable_Assignment
(N
);
10137 -- Variable references
10139 elsif Is_Suitable_Variable_Reference
(N
) then
10141 -- In general, only variable references found within the main unit
10142 -- are processed because the ALI information supplied to binde is for
10143 -- the main unit only. However, to preserve the consistency of the
10144 -- tree and ensure proper serialization of internal names, external
10145 -- variable references also receive corresponding variable reference
10146 -- markers (see Build_Varaible_Reference_Marker). Regardless of the
10147 -- reason, external variable references must not be processed.
10149 if In_Main_Context
(N
) then
10150 Process_Conditional_ABE_Variable_Reference
(N
);
10154 -- Remove the current scenario from the stack of active scenarios once
10155 -- all ABE diagnostics and checks have been performed.
10157 Pop_Active_Scenario
(N
);
10158 end Process_Conditional_ABE
;
10160 --------------------------------------------
10161 -- Process_Guaranteed_ABE_Activation_Impl --
10162 --------------------------------------------
10164 procedure Process_Guaranteed_ABE_Activation_Impl
10166 Call_Attrs
: Call_Attributes
;
10167 Obj_Id
: Entity_Id
;
10168 Task_Attrs
: Task_Attributes
;
10169 State
: Processing_Attributes
)
10171 pragma Unreferenced
(State
);
10173 Check_OK
: constant Boolean :=
10174 not Is_Ignored_Ghost_Entity
(Obj_Id
)
10175 and then not Task_Attrs
.Ghost_Mode_Ignore
10176 and then Is_Elaboration_Checks_OK_Id
(Obj_Id
)
10177 and then Task_Attrs
.Elab_Checks_OK
;
10178 -- A run-time ABE check may be installed only when the object and the
10179 -- task type have active elaboration checks, and both are not ignored
10180 -- Ghost constructs.
10183 -- Nothing to do when the root scenario appears at the declaration
10184 -- level and the task is in the same unit, but outside this context.
10186 -- task type Task_Typ; -- task declaration
10188 -- procedure Proc is
10189 -- function A ... is
10191 -- if Some_Condition then
10195 -- <activation call> -- activation site
10200 -- X : ... := A; -- root scenario
10203 -- task body Task_Typ is
10207 -- In the example above, the context of X is the declarative list of
10208 -- Proc. The "elaboration" of X may reach the activation of T whose body
10209 -- is defined outside of X's context. The task body is relevant only
10210 -- when Proc is invoked, but this happens only in "normal" elaboration,
10211 -- therefore the task body must not be considered if this is not the
10214 -- Performance note: parent traversal
10216 if Is_Up_Level_Target
(Task_Attrs
.Task_Decl
) then
10219 -- Nothing to do when the activation is ABE-safe
10223 -- task type Task_Typ;
10226 -- package body Gen is
10227 -- task body Task_Typ is
10234 -- procedure Main is
10235 -- package Nested is
10236 -- package Inst is new Gen;
10237 -- T : Inst.Task_Typ;
10238 -- end Nested; -- safe activation
10241 elsif Is_Safe_Activation
(Call
, Task_Attrs
.Task_Decl
) then
10244 -- An activation call leads to a guaranteed ABE when the activation
10245 -- call and the task appear within the same context ignoring library
10246 -- levels, and the body of the task has not been seen yet or appears
10247 -- after the activation call.
10249 -- procedure Guaranteed_ABE is
10250 -- task type Task_Typ;
10252 -- package Nested is
10254 -- <activation call> -- guaranteed ABE
10257 -- task body Task_Typ is
10262 -- Performance note: parent traversal
10264 elsif Is_Guaranteed_ABE
10266 Target_Decl
=> Task_Attrs
.Task_Decl
,
10267 Target_Body
=> Task_Attrs
.Body_Decl
)
10269 if Call_Attrs
.Elab_Warnings_OK
then
10270 Error_Msg_Sloc
:= Sloc
(Call
);
10272 ("??task & will be activated # before elaboration of its body",
10274 Error_Msg_N
("\Program_Error will be raised at run time", Obj_Id
);
10277 -- Mark the activation call as a guaranteed ABE
10279 Set_Is_Known_Guaranteed_ABE
(Call
);
10281 -- Install a run-time ABE failue because this activation call will
10282 -- always result in an ABE.
10285 Install_ABE_Failure
10290 end Process_Guaranteed_ABE_Activation_Impl
;
10292 procedure Process_Guaranteed_ABE_Activation
is
10293 new Process_Activation_Generic
(Process_Guaranteed_ABE_Activation_Impl
);
10295 ---------------------------------
10296 -- Process_Guaranteed_ABE_Call --
10297 ---------------------------------
10299 procedure Process_Guaranteed_ABE_Call
10301 Call_Attrs
: Call_Attributes
;
10302 Target_Id
: Entity_Id
)
10304 Target_Attrs
: Target_Attributes
;
10307 Extract_Target_Attributes
10308 (Target_Id
=> Target_Id
,
10309 Attrs
=> Target_Attrs
);
10311 -- Nothing to do when the root scenario appears at the declaration level
10312 -- and the target is in the same unit, but outside this context.
10314 -- function B ...; -- target declaration
10316 -- procedure Proc is
10317 -- function A ... is
10319 -- if Some_Condition then
10320 -- return B; -- call site
10324 -- X : ... := A; -- root scenario
10327 -- function B ... is
10331 -- In the example above, the context of X is the declarative region of
10332 -- Proc. The "elaboration" of X may eventually reach B which is defined
10333 -- outside of X's context. B is relevant only when Proc is invoked, but
10334 -- this happens only by means of "normal" elaboration, therefore B must
10335 -- not be considered if this is not the case.
10337 -- Performance note: parent traversal
10339 if Is_Up_Level_Target
(Target_Attrs
.Spec_Decl
) then
10342 -- Nothing to do when the call is ABE-safe
10345 -- function Gen ...;
10347 -- function Gen ... is
10353 -- procedure Main is
10354 -- function Inst is new Gen;
10355 -- X : ... := Inst; -- safe call
10358 elsif Is_Safe_Call
(Call
, Target_Attrs
) then
10361 -- A call leads to a guaranteed ABE when the call and the target appear
10362 -- within the same context ignoring library levels, and the body of the
10363 -- target has not been seen yet or appears after the call.
10365 -- procedure Guaranteed_ABE is
10366 -- function Func ...;
10368 -- package Nested is
10369 -- Obj : ... := Func; -- guaranteed ABE
10372 -- function Func ... is
10377 -- Performance note: parent traversal
10379 elsif Is_Guaranteed_ABE
10381 Target_Decl
=> Target_Attrs
.Spec_Decl
,
10382 Target_Body
=> Target_Attrs
.Body_Decl
)
10384 if Call_Attrs
.Elab_Warnings_OK
then
10385 Error_Msg_NE
("??cannot call & before body seen", Call
, Target_Id
);
10386 Error_Msg_N
("\Program_Error will be raised at run time", Call
);
10389 -- Mark the call as a guarnateed ABE
10391 Set_Is_Known_Guaranteed_ABE
(Call
);
10393 -- Install a run-time ABE failure because the call will always result
10394 -- in an ABE. The failure is installed when both the call and target
10395 -- have enabled elaboration checks, and both are not ignored Ghost
10398 if Call_Attrs
.Elab_Checks_OK
10399 and then Target_Attrs
.Elab_Checks_OK
10400 and then not Call_Attrs
.Ghost_Mode_Ignore
10401 and then not Target_Attrs
.Ghost_Mode_Ignore
10403 Install_ABE_Failure
10408 end Process_Guaranteed_ABE_Call
;
10410 ------------------------------------------
10411 -- Process_Guaranteed_ABE_Instantiation --
10412 ------------------------------------------
10414 procedure Process_Guaranteed_ABE_Instantiation
(Exp_Inst
: Node_Id
) is
10415 Gen_Attrs
: Target_Attributes
;
10416 Gen_Id
: Entity_Id
;
10418 Inst_Attrs
: Instantiation_Attributes
;
10419 Inst_Id
: Entity_Id
;
10422 Extract_Instantiation_Attributes
10423 (Exp_Inst
=> Exp_Inst
,
10425 Inst_Id
=> Inst_Id
,
10427 Attrs
=> Inst_Attrs
);
10429 Extract_Target_Attributes
(Gen_Id
, Gen_Attrs
);
10431 -- Nothing to do when the root scenario appears at the declaration level
10432 -- and the generic is in the same unit, but outside this context.
10435 -- procedure Gen is ...; -- generic declaration
10437 -- procedure Proc is
10438 -- function A ... is
10440 -- if Some_Condition then
10442 -- procedure I is new Gen; -- instantiation site
10447 -- X : ... := A; -- root scenario
10450 -- procedure Gen is
10454 -- In the example above, the context of X is the declarative region of
10455 -- Proc. The "elaboration" of X may eventually reach Gen which appears
10456 -- outside of X's context. Gen is relevant only when Proc is invoked,
10457 -- but this happens only by means of "normal" elaboration, therefore
10458 -- Gen must not be considered if this is not the case.
10460 -- Performance note: parent traversal
10462 if Is_Up_Level_Target
(Gen_Attrs
.Spec_Decl
) then
10465 -- Nothing to do when the instantiation is ABE-safe
10472 -- package body Gen is
10477 -- procedure Main is
10478 -- package Inst is new Gen (ABE); -- safe instantiation
10481 elsif Is_Safe_Instantiation
(Inst
, Gen_Attrs
) then
10484 -- An instantiation leads to a guaranteed ABE when the instantiation and
10485 -- the generic appear within the same context ignoring library levels,
10486 -- and the body of the generic has not been seen yet or appears after
10487 -- the instantiation.
10489 -- procedure Guaranteed_ABE is
10493 -- package Nested is
10494 -- procedure Inst is new Gen; -- guaranteed ABE
10497 -- procedure Gen is
10502 -- Performance note: parent traversal
10504 elsif Is_Guaranteed_ABE
10506 Target_Decl
=> Gen_Attrs
.Spec_Decl
,
10507 Target_Body
=> Gen_Attrs
.Body_Decl
)
10509 if Inst_Attrs
.Elab_Warnings_OK
then
10511 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
10512 Error_Msg_N
("\Program_Error will be raised at run time", Inst
);
10515 -- Mark the instantiation as a guarantee ABE. This automatically
10516 -- suppresses the instantiation of the generic body.
10518 Set_Is_Known_Guaranteed_ABE
(Inst
);
10520 -- Install a run-time ABE failure because the instantiation will
10521 -- always result in an ABE. The failure is installed when both the
10522 -- instance and the generic have enabled elaboration checks, and both
10523 -- are not ignored Ghost constructs.
10525 if Inst_Attrs
.Elab_Checks_OK
10526 and then Gen_Attrs
.Elab_Checks_OK
10527 and then not Inst_Attrs
.Ghost_Mode_Ignore
10528 and then not Gen_Attrs
.Ghost_Mode_Ignore
10530 Install_ABE_Failure
10532 Ins_Nod
=> Exp_Inst
);
10535 end Process_Guaranteed_ABE_Instantiation
;
10537 ----------------------------
10538 -- Process_Guaranteed_ABE --
10539 ----------------------------
10541 -- NOTE: The body of this routine is intentionally out of order because it
10542 -- invokes an instantiated subprogram (Process_Guaranteed_ABE_Activation).
10543 -- Placing the body in alphabetical order will result in a guaranteed ABE.
10545 procedure Process_Guaranteed_ABE
(N
: Node_Id
) is
10546 Call_Attrs
: Call_Attributes
;
10547 Target_Id
: Entity_Id
;
10550 -- Add the current scenario to the stack of active scenarios
10552 Push_Active_Scenario
(N
);
10554 -- Only calls, instantiations, and task activations may result in a
10557 if Is_Suitable_Call
(N
) then
10558 Extract_Call_Attributes
10560 Target_Id
=> Target_Id
,
10561 Attrs
=> Call_Attrs
);
10563 if Is_Activation_Proc
(Target_Id
) then
10564 Process_Guaranteed_ABE_Activation
10566 Call_Attrs
=> Call_Attrs
,
10567 State
=> Initial_State
);
10570 Process_Guaranteed_ABE_Call
10572 Call_Attrs
=> Call_Attrs
,
10573 Target_Id
=> Target_Id
);
10576 elsif Is_Suitable_Instantiation
(N
) then
10577 Process_Guaranteed_ABE_Instantiation
(N
);
10580 -- Remove the current scenario from the stack of active scenarios once
10581 -- all ABE diagnostics and checks have been performed.
10583 Pop_Active_Scenario
(N
);
10584 end Process_Guaranteed_ABE
;
10586 --------------------------
10587 -- Push_Active_Scenario --
10588 --------------------------
10590 procedure Push_Active_Scenario
(N
: Node_Id
) is
10592 Scenario_Stack
.Append
(N
);
10593 end Push_Active_Scenario
;
10595 ---------------------------------
10596 -- Record_Elaboration_Scenario --
10597 ---------------------------------
10599 procedure Record_Elaboration_Scenario
(N
: Node_Id
) is
10600 Level
: Enclosing_Level_Kind
;
10602 Any_Level_OK
: Boolean;
10603 -- This flag is set when a particular scenario is allowed to appear at
10606 Declaration_Level_OK
: Boolean;
10607 -- This flag is set when a particular scenario is allowed to appear at
10608 -- the declaration level.
10610 Library_Level_OK
: Boolean;
10611 -- This flag is set when a particular scenario is allowed to appear at
10612 -- the library level.
10615 -- Assume that the scenario cannot appear on any level
10617 Any_Level_OK
:= False;
10618 Declaration_Level_OK
:= False;
10619 Library_Level_OK
:= False;
10621 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
10622 -- enabled) is in effect because the legacy ABE mechanism does not need
10623 -- to carry out this action.
10625 if Legacy_Elaboration_Checks
then
10628 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics
10629 -- are performed in this mode.
10631 elsif ASIS_Mode
then
10634 -- Nothing to do when the scenario is being preanalyzed
10636 elsif Preanalysis_Active
then
10640 -- Ensure that a library-level call does not appear in a preelaborated
10641 -- unit. The check must come before ignoring scenarios within external
10642 -- units or inside generics because calls in those context must also be
10645 if Is_Suitable_Call
(N
) then
10646 Check_Preelaborated_Call
(N
);
10649 -- Nothing to do when the scenario does not appear within the main unit
10651 if not In_Main_Context
(N
) then
10654 -- Scenarios within a generic unit are never considered because generics
10655 -- cannot be elaborated.
10657 elsif Inside_A_Generic
then
10660 -- Scenarios which do not fall in one of the elaboration categories
10661 -- listed below are not considered. The categories are:
10663 -- 'Access for entries, operators, and subprograms
10664 -- Assignments to variables
10665 -- Calls (includes task activation)
10668 -- Pragma Refined_State
10669 -- Reads of variables
10671 elsif Is_Suitable_Access
(N
) then
10672 Library_Level_OK
:= True;
10674 -- Signal any enclosing local exception handlers that the 'Access may
10675 -- raise Program_Error due to a failed ABE check when switch -gnatd.o
10676 -- (conservative elaboration order for indirect calls) is in effect.
10677 -- Marking the exception handlers ensures proper expansion by both
10678 -- the front and back end restriction when No_Exception_Propagation
10681 if Debug_Flag_Dot_O
then
10682 Possible_Local_Raise
(N
, Standard_Program_Error
);
10685 elsif Is_Suitable_Call
(N
) or else Is_Suitable_Instantiation
(N
) then
10686 Declaration_Level_OK
:= True;
10687 Library_Level_OK
:= True;
10689 -- Signal any enclosing local exception handlers that the call or
10690 -- instantiation may raise Program_Error due to a failed ABE check.
10691 -- Marking the exception handlers ensures proper expansion by both
10692 -- the front and back end restriction when No_Exception_Propagation
10695 Possible_Local_Raise
(N
, Standard_Program_Error
);
10697 elsif Is_Suitable_SPARK_Derived_Type
(N
) then
10698 Any_Level_OK
:= True;
10700 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
10701 Library_Level_OK
:= True;
10703 elsif Is_Suitable_Variable_Assignment
(N
)
10704 or else Is_Suitable_Variable_Reference
(N
)
10706 Library_Level_OK
:= True;
10708 -- Otherwise the input does not denote a suitable scenario
10714 -- The static model imposes additional restrictions on the placement of
10715 -- scenarios. In contrast, the dynamic model assumes that every scenario
10716 -- will be elaborated or invoked at some point.
10718 if Static_Elaboration_Checks
then
10720 -- Certain scenarios are allowed to appear at any level. This check
10721 -- is performed here in order to save on a parent traversal.
10723 if Any_Level_OK
then
10726 -- Otherwise the scenario must appear at a specific level
10729 -- Performance note: parent traversal
10731 Level
:= Find_Enclosing_Level
(N
);
10733 -- Declaration-level scenario
10735 if Declaration_Level_OK
and then Level
= Declaration_Level
then
10738 -- Library-level or instantiation scenario
10740 elsif Library_Level_OK
10741 and then Level
in Library_Or_Instantiation_Level
10745 -- Otherwise the scenario does not appear at the proper level and
10746 -- cannot possibly act as a top-level scenario.
10754 -- Derived types subject to SPARK_Mode On require elaboration-related
10755 -- checks even though the type may not be declared within elaboration
10756 -- code. The types are recorded in a separate table which is examined
10757 -- during the Processing phase. Note that the checks must be delayed
10758 -- because the bodies of overriding primitives are not available yet.
10760 if Is_Suitable_SPARK_Derived_Type
(N
) then
10761 Record_SPARK_Elaboration_Scenario
(N
);
10763 -- Nothing left to do for derived types
10767 -- Instantiations of generics both subject to SPARK_Mode On require
10768 -- elaboration-related checks even though the instantiations may not
10769 -- appear within elaboration code. The instantiations are recored in
10770 -- a separate table which is examined during the Procesing phase. Note
10771 -- that the checks must be delayed because it is not known yet whether
10772 -- the generic unit has a body or not.
10774 -- IMPORTANT: A SPARK instantiation is also a normal instantiation which
10775 -- is subject to common conditional and guaranteed ABE checks.
10777 elsif Is_Suitable_SPARK_Instantiation
(N
) then
10778 Record_SPARK_Elaboration_Scenario
(N
);
10780 -- External constituents that refine abstract states which appear in
10781 -- pragma Initializes require elaboration-related checks even though
10782 -- a Refined_State pragma lacks any elaboration semantic.
10784 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
10785 Record_SPARK_Elaboration_Scenario
(N
);
10787 -- Nothing left to do for pragma Refined_State
10792 -- Perform early detection of guaranteed ABEs in order to suppress the
10793 -- instantiation of generic bodies as gigi cannot handle certain types
10794 -- of premature instantiations.
10796 Process_Guaranteed_ABE
(N
);
10798 -- At this point all checks have been performed. Record the scenario for
10799 -- later processing by the ABE phase.
10801 Top_Level_Scenarios
.Append
(N
);
10802 Set_Is_Recorded_Top_Level_Scenario
(N
);
10803 end Record_Elaboration_Scenario
;
10805 ---------------------------------------
10806 -- Record_SPARK_Elaboration_Scenario --
10807 ---------------------------------------
10809 procedure Record_SPARK_Elaboration_Scenario
(N
: Node_Id
) is
10811 SPARK_Scenarios
.Append
(N
);
10812 Set_Is_Recorded_SPARK_Scenario
(N
);
10813 end Record_SPARK_Elaboration_Scenario
;
10815 -----------------------------------
10816 -- Recorded_SPARK_Scenarios_Hash --
10817 -----------------------------------
10819 function Recorded_SPARK_Scenarios_Hash
10820 (Key
: Node_Id
) return Recorded_SPARK_Scenarios_Index
10824 Recorded_SPARK_Scenarios_Index
(Key
mod Recorded_SPARK_Scenarios_Max
);
10825 end Recorded_SPARK_Scenarios_Hash
;
10827 ---------------------------------------
10828 -- Recorded_Top_Level_Scenarios_Hash --
10829 ---------------------------------------
10831 function Recorded_Top_Level_Scenarios_Hash
10832 (Key
: Node_Id
) return Recorded_Top_Level_Scenarios_Index
10836 Recorded_Top_Level_Scenarios_Index
10837 (Key
mod Recorded_Top_Level_Scenarios_Max
);
10838 end Recorded_Top_Level_Scenarios_Hash
;
10840 --------------------------
10841 -- Reset_Visited_Bodies --
10842 --------------------------
10844 procedure Reset_Visited_Bodies
is
10846 if Visited_Bodies_In_Use
then
10847 Visited_Bodies_In_Use
:= False;
10848 Visited_Bodies
.Reset
;
10850 end Reset_Visited_Bodies
;
10852 -------------------
10853 -- Root_Scenario --
10854 -------------------
10856 function Root_Scenario
return Node_Id
is
10857 package Stack
renames Scenario_Stack
;
10860 -- Ensure that the scenario stack has at least one active scenario in
10861 -- it. The one at the bottom (index First) is the root scenario.
10863 pragma Assert
(Stack
.Last
>= Stack
.First
);
10864 return Stack
.Table
(Stack
.First
);
10867 ---------------------------
10868 -- Set_Early_Call_Region --
10869 ---------------------------
10871 procedure Set_Early_Call_Region
(Body_Id
: Entity_Id
; Start
: Node_Id
) is
10873 pragma Assert
(Ekind_In
(Body_Id
, E_Entry
,
10877 E_Subprogram_Body
));
10879 Early_Call_Regions_In_Use
:= True;
10880 Early_Call_Regions
.Set
(Body_Id
, Start
);
10881 end Set_Early_Call_Region
;
10883 ----------------------------
10884 -- Set_Elaboration_Status --
10885 ----------------------------
10887 procedure Set_Elaboration_Status
10888 (Unit_Id
: Entity_Id
;
10889 Val
: Elaboration_Attributes
)
10892 Elaboration_Statuses_In_Use
:= True;
10893 Elaboration_Statuses
.Set
(Unit_Id
, Val
);
10894 end Set_Elaboration_Status
;
10896 ------------------------------------
10897 -- Set_Is_Recorded_SPARK_Scenario --
10898 ------------------------------------
10900 procedure Set_Is_Recorded_SPARK_Scenario
10902 Val
: Boolean := True)
10905 Recorded_SPARK_Scenarios_In_Use
:= True;
10906 Recorded_SPARK_Scenarios
.Set
(N
, Val
);
10907 end Set_Is_Recorded_SPARK_Scenario
;
10909 ----------------------------------------
10910 -- Set_Is_Recorded_Top_Level_Scenario --
10911 ----------------------------------------
10913 procedure Set_Is_Recorded_Top_Level_Scenario
10915 Val
: Boolean := True)
10918 Recorded_Top_Level_Scenarios_In_Use
:= True;
10919 Recorded_Top_Level_Scenarios
.Set
(N
, Val
);
10920 end Set_Is_Recorded_Top_Level_Scenario
;
10922 -------------------------
10923 -- Set_Is_Visited_Body --
10924 -------------------------
10926 procedure Set_Is_Visited_Body
(Subp_Body
: Node_Id
) is
10928 Visited_Bodies_In_Use
:= True;
10929 Visited_Bodies
.Set
(Subp_Body
, True);
10930 end Set_Is_Visited_Body
;
10932 -------------------------------
10933 -- Static_Elaboration_Checks --
10934 -------------------------------
10936 function Static_Elaboration_Checks
return Boolean is
10938 return not Dynamic_Elaboration_Checks
;
10939 end Static_Elaboration_Checks
;
10941 -------------------
10942 -- Traverse_Body --
10943 -------------------
10945 procedure Traverse_Body
(N
: Node_Id
; State
: Processing_Attributes
) is
10946 procedure Find_And_Process_Nested_Scenarios
;
10947 pragma Inline
(Find_And_Process_Nested_Scenarios
);
10948 -- Examine the declarations and statements of subprogram body N for
10949 -- suitable scenarios. Save each discovered scenario and process it
10952 procedure Process_Nested_Scenarios
(Nested
: Elist_Id
);
10953 pragma Inline
(Process_Nested_Scenarios
);
10954 -- Invoke Process_Conditional_ABE on each individual scenario found in
10957 ---------------------------------------
10958 -- Find_And_Process_Nested_Scenarios --
10959 ---------------------------------------
10961 procedure Find_And_Process_Nested_Scenarios
is
10962 Body_Id
: constant Entity_Id
:= Defining_Entity
(N
);
10964 function Is_Potential_Scenario
10965 (Nod
: Node_Id
) return Traverse_Result
;
10966 -- Determine whether arbitrary node Nod denotes a suitable scenario.
10967 -- If it does, save it in the Nested_Scenarios list of the subprogram
10968 -- body, and process it.
10970 procedure Save_Scenario
(Nod
: Node_Id
);
10971 pragma Inline
(Save_Scenario
);
10972 -- Save scenario Nod in the Nested_Scenarios list of the subprogram
10975 procedure Traverse_List
(List
: List_Id
);
10976 pragma Inline
(Traverse_List
);
10977 -- Invoke Traverse_Potential_Scenarios on each node in list List
10979 procedure Traverse_Potential_Scenarios
is
10980 new Traverse_Proc
(Is_Potential_Scenario
);
10982 ---------------------------
10983 -- Is_Potential_Scenario --
10984 ---------------------------
10986 function Is_Potential_Scenario
10987 (Nod
: Node_Id
) return Traverse_Result
10992 -- Skip constructs which do not have elaboration of their own and
10993 -- need to be elaborated by other means such as invocation, task
10994 -- activation, etc.
10996 if Is_Non_Library_Level_Encapsulator
(Nod
) then
10999 -- Terminate the traversal of a task body with an accept statement
11000 -- when no entry calls in elaboration are allowed because the task
11001 -- will block at run-time and the remaining statements will not be
11004 elsif Nkind_In
(Original_Node
(Nod
), N_Accept_Statement
,
11005 N_Selective_Accept
)
11007 if Restriction_Active
(No_Entry_Calls_In_Elaboration_Code
) then
11010 -- The same behavior is achieved when switch -gnatd_a (stop
11011 -- elabortion checks on accept or select statement) is in
11014 elsif Debug_Flag_Underscore_A
then
11018 -- Certain nodes carry semantic lists which act as repositories
11019 -- until expansion transforms the node and relocates the contents.
11020 -- Examine these lists in case expansion is disabled.
11022 elsif Nkind_In
(Nod
, N_And_Then
, N_Or_Else
) then
11023 Traverse_List
(Actions
(Nod
));
11025 elsif Nkind_In
(Nod
, N_Elsif_Part
, N_Iteration_Scheme
) then
11026 Traverse_List
(Condition_Actions
(Nod
));
11028 elsif Nkind
(Nod
) = N_If_Expression
then
11029 Traverse_List
(Then_Actions
(Nod
));
11030 Traverse_List
(Else_Actions
(Nod
));
11032 elsif Nkind_In
(Nod
, N_Component_Association
,
11033 N_Iterated_Component_Association
)
11035 Traverse_List
(Loop_Actions
(Nod
));
11039 -- Save a suitable scenario in the Nested_Scenarios list of the
11040 -- subprogram body. As a result any subsequent traversals of the
11041 -- subprogram body started from a different top-level scenario no
11042 -- longer need to reexamine the tree.
11044 elsif Is_Suitable_Scenario
(Nod
) then
11045 Save_Scenario
(Nod
);
11047 Process_Conditional_ABE
11053 end Is_Potential_Scenario
;
11055 -------------------
11056 -- Save_Scenario --
11057 -------------------
11059 procedure Save_Scenario
(Nod
: Node_Id
) is
11063 Nested
:= Nested_Scenarios
(Body_Id
);
11065 if No
(Nested
) then
11066 Nested
:= New_Elmt_List
;
11067 Set_Nested_Scenarios
(Body_Id
, Nested
);
11070 Append_Elmt
(Nod
, Nested
);
11073 -------------------
11074 -- Traverse_List --
11075 -------------------
11077 procedure Traverse_List
(List
: List_Id
) is
11081 Item
:= First
(List
);
11082 while Present
(Item
) loop
11083 Traverse_Potential_Scenarios
(Item
);
11088 -- Start of processing for Find_And_Process_Nested_Scenarios
11091 -- Examine the declarations for suitable scenarios
11093 Traverse_List
(Declarations
(N
));
11095 -- Examine the handled sequence of statements. This also includes any
11096 -- exceptions handlers.
11098 Traverse_Potential_Scenarios
(Handled_Statement_Sequence
(N
));
11099 end Find_And_Process_Nested_Scenarios
;
11101 ------------------------------
11102 -- Process_Nested_Scenarios --
11103 ------------------------------
11105 procedure Process_Nested_Scenarios
(Nested
: Elist_Id
) is
11106 Nested_Elmt
: Elmt_Id
;
11109 Nested_Elmt
:= First_Elmt
(Nested
);
11110 while Present
(Nested_Elmt
) loop
11111 Process_Conditional_ABE
11112 (N
=> Node
(Nested_Elmt
),
11115 Next_Elmt
(Nested_Elmt
);
11117 end Process_Nested_Scenarios
;
11123 -- Start of processing for Traverse_Body
11126 -- Nothing to do when there is no body
11131 elsif Nkind
(N
) /= N_Subprogram_Body
then
11135 -- Nothing to do if the body was already traversed during the processing
11136 -- of the same top-level scenario.
11138 if Is_Visited_Body
(N
) then
11141 -- Otherwise mark the body as traversed
11144 Set_Is_Visited_Body
(N
);
11147 Nested
:= Nested_Scenarios
(Defining_Entity
(N
));
11149 -- The subprogram body was already examined as part of the elaboration
11150 -- graph starting from a different top-level scenario. There is no need
11151 -- to traverse the declarations and statements again because this will
11152 -- yield the exact same scenarios. Use the nested scenarios collected
11153 -- during the first inspection of the body.
11155 if Present
(Nested
) then
11156 Process_Nested_Scenarios
(Nested
);
11158 -- Otherwise examine the declarations and statements of the subprogram
11159 -- body for suitable scenarios, save and process them accordingly.
11162 Find_And_Process_Nested_Scenarios
;
11166 ---------------------------------
11167 -- Update_Elaboration_Scenario --
11168 ---------------------------------
11170 procedure Update_Elaboration_Scenario
(New_N
: Node_Id
; Old_N
: Node_Id
) is
11171 procedure Update_SPARK_Scenario
;
11172 pragma Inline
(Update_SPARK_Scenario
);
11173 -- Update the contents of table SPARK_Scenarios if Old_N is recorded
11176 procedure Update_Top_Level_Scenario
;
11177 pragma Inline
(Update_Top_Level_Scenario
);
11178 -- Update the contexts of table Top_Level_Scenarios if Old_N is recorded
11181 ---------------------------
11182 -- Update_SPARK_Scenario --
11183 ---------------------------
11185 procedure Update_SPARK_Scenario
is
11186 package Scenarios
renames SPARK_Scenarios
;
11189 if Is_Recorded_SPARK_Scenario
(Old_N
) then
11191 -- Performance note: list traversal
11193 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
11194 if Scenarios
.Table
(Index
) = Old_N
then
11195 Scenarios
.Table
(Index
) := New_N
;
11197 -- The old SPARK scenario is no longer recorded, but the new
11200 Set_Is_Recorded_Top_Level_Scenario
(Old_N
, False);
11201 Set_Is_Recorded_Top_Level_Scenario
(New_N
);
11206 -- A recorded SPARK scenario must be in the table of recorded
11207 -- SPARK scenarios.
11209 pragma Assert
(False);
11211 end Update_SPARK_Scenario
;
11213 -------------------------------
11214 -- Update_Top_Level_Scenario --
11215 -------------------------------
11217 procedure Update_Top_Level_Scenario
is
11218 package Scenarios
renames Top_Level_Scenarios
;
11221 if Is_Recorded_Top_Level_Scenario
(Old_N
) then
11223 -- Performance note: list traversal
11225 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
11226 if Scenarios
.Table
(Index
) = Old_N
then
11227 Scenarios
.Table
(Index
) := New_N
;
11229 -- The old top-level scenario is no longer recorded, but the
11232 Set_Is_Recorded_Top_Level_Scenario
(Old_N
, False);
11233 Set_Is_Recorded_Top_Level_Scenario
(New_N
);
11238 -- A recorded top-level scenario must be in the table of recorded
11239 -- top-level scenarios.
11241 pragma Assert
(False);
11243 end Update_Top_Level_Scenario
;
11245 -- Start of processing for Update_Elaboration_Requirement
11248 -- Nothing to do when the old and new scenarios are one and the same
11250 if Old_N
= New_N
then
11253 -- A scenario is being transformed by Atree.Rewrite. Update all relevant
11254 -- internal data structures to reflect this change. This ensures that a
11255 -- potential run-time conditional ABE check or a guaranteed ABE failure
11256 -- is inserted at the proper place in the tree.
11258 elsif Is_Scenario
(Old_N
) then
11259 Update_SPARK_Scenario
;
11260 Update_Top_Level_Scenario
;
11262 end Update_Elaboration_Scenario
;
11264 -------------------------
11265 -- Visited_Bodies_Hash --
11266 -------------------------
11268 function Visited_Bodies_Hash
(Key
: Node_Id
) return Visited_Bodies_Index
is
11270 return Visited_Bodies_Index
(Key
mod Visited_Bodies_Max
);
11271 end Visited_Bodies_Hash
;
11273 ---------------------------------------------------------------------------
11275 -- 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 --
11277 -- M E C H A N I S M --
11279 ---------------------------------------------------------------------------
11281 -- This section contains the implementation of the pre-18.x legacy ABE
11282 -- mechanism. The mechanism can be activated using switch -gnatH (legacy
11283 -- elaboration checking mode enabled).
11285 -----------------------------
11286 -- Description of Approach --
11287 -----------------------------
11289 -- Every non-static call that is encountered by Sem_Res results in a call
11290 -- to Check_Elab_Call, with N being the call node, and Outer set to its
11291 -- default value of True. In addition X'Access is treated like a call
11292 -- for the access-to-procedure case, and in SPARK mode only we also
11293 -- check variable references.
11295 -- The goal of Check_Elab_Call is to determine whether or not the reference
11296 -- in question can generate an access before elaboration error (raising
11297 -- Program_Error) either by directly calling a subprogram whose body
11298 -- has not yet been elaborated, or indirectly, by calling a subprogram
11299 -- whose body has been elaborated, but which contains a call to such a
11302 -- In addition, in SPARK mode, we are checking for a variable reference in
11303 -- another package, which requires an explicit Elaborate_All pragma.
11305 -- The only references that we need to look at the outer level are
11306 -- references that occur in elaboration code. There are two cases. The
11307 -- reference can be at the outer level of elaboration code, or it can
11308 -- be within another unit, e.g. the elaboration code of a subprogram.
11310 -- In the case of an elaboration call at the outer level, we must trace
11311 -- all calls to outer level routines either within the current unit or to
11312 -- other units that are with'ed. For calls within the current unit, we can
11313 -- determine if the body has been elaborated or not, and if it has not,
11314 -- then a warning is generated.
11316 -- Note that there are two subcases. If the original call directly calls a
11317 -- subprogram whose body has not been elaborated, then we know that an ABE
11318 -- will take place, and we replace the call by a raise of Program_Error.
11319 -- If the call is indirect, then we don't know that the PE will be raised,
11320 -- since the call might be guarded by a conditional. In this case we set
11321 -- Do_Elab_Check on the call so that a dynamic check is generated, and
11322 -- output a warning.
11324 -- For calls to a subprogram in a with'ed unit or a 'Access or variable
11325 -- reference (SPARK mode case), we require that a pragma Elaborate_All
11326 -- or pragma Elaborate be present, or that the referenced unit have a
11327 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
11328 -- of these conditions is met, then a warning is generated that a pragma
11329 -- Elaborate_All may be needed (error in the SPARK case), or an implicit
11330 -- pragma is generated.
11332 -- For the case of an elaboration call at some inner level, we are
11333 -- interested in tracing only calls to subprograms at the same level, i.e.
11334 -- those that can be called during elaboration. Any calls to outer level
11335 -- routines cannot cause ABE's as a result of the original call (there
11336 -- might be an outer level call to the subprogram from outside that causes
11337 -- the ABE, but that gets analyzed separately).
11339 -- Note that we never trace calls to inner level subprograms, since these
11340 -- cannot result in ABE's unless there is an elaboration problem at a lower
11341 -- level, which will be separately detected.
11343 -- Note on pragma Elaborate. The checking here assumes that a pragma
11344 -- Elaborate on a with'ed unit guarantees that subprograms within the unit
11345 -- can be called without causing an ABE. This is not in fact the case since
11346 -- pragma Elaborate does not guarantee the transitive coverage guaranteed
11347 -- by Elaborate_All. However, we decide to trust the user in this case.
11349 --------------------------------------
11350 -- Instantiation Elaboration Errors --
11351 --------------------------------------
11353 -- A special case arises when an instantiation appears in a context that is
11354 -- known to be before the body is elaborated, e.g.
11356 -- generic package x is ...
11358 -- package xx is new x;
11360 -- package body x is ...
11362 -- In this situation it is certain that an elaboration error will occur,
11363 -- and an unconditional raise Program_Error statement is inserted before
11364 -- the instantiation, and a warning generated.
11366 -- The problem is that in this case we have no place to put the body of
11367 -- the instantiation. We can't put it in the normal place, because it is
11368 -- too early, and will cause errors to occur as a result of referencing
11369 -- entities before they are declared.
11371 -- Our approach in this case is simply to avoid creating the body of the
11372 -- instantiation in such a case. The instantiation spec is modified to
11373 -- include dummy bodies for all subprograms, so that the resulting code
11374 -- does not contain subprogram specs with no corresponding bodies.
11376 -- The following table records the recursive call chain for output in the
11377 -- Output routine. Each entry records the call node and the entity of the
11378 -- called routine. The number of entries in the table (i.e. the value of
11379 -- Elab_Call.Last) indicates the current depth of recursion and is used to
11380 -- identify the outer level.
11382 type Elab_Call_Element
is record
11387 package Elab_Call
is new Table
.Table
11388 (Table_Component_Type
=> Elab_Call_Element
,
11389 Table_Index_Type
=> Int
,
11390 Table_Low_Bound
=> 1,
11391 Table_Initial
=> 50,
11392 Table_Increment
=> 100,
11393 Table_Name
=> "Elab_Call");
11395 -- The following table records all calls that have been processed starting
11396 -- from an outer level call. The table prevents both infinite recursion and
11397 -- useless reanalysis of calls within the same context. The use of context
11398 -- is important because it allows for proper checks in more complex code:
11401 -- Call; -- requires a check
11402 -- Call; -- does not need a check thanks to the table
11404 -- Call; -- requires a check, different context
11407 -- Call; -- requires a check, different context
11409 type Visited_Element
is record
11410 Subp_Id
: Entity_Id
;
11411 -- The entity of the subprogram being called
11414 -- The context where the call to the subprogram occurs
11417 package Elab_Visited
is new Table
.Table
11418 (Table_Component_Type
=> Visited_Element
,
11419 Table_Index_Type
=> Int
,
11420 Table_Low_Bound
=> 1,
11421 Table_Initial
=> 200,
11422 Table_Increment
=> 100,
11423 Table_Name
=> "Elab_Visited");
11425 -- The following table records delayed calls which must be examined after
11426 -- all generic bodies have been instantiated.
11428 type Delay_Element
is record
11430 -- The parameter N from the call to Check_Internal_Call. Note that this
11431 -- node may get rewritten over the delay period by expansion in the call
11432 -- case (but not in the instantiation case).
11435 -- The parameter E from the call to Check_Internal_Call
11437 Orig_Ent
: Entity_Id
;
11438 -- The parameter Orig_Ent from the call to Check_Internal_Call
11440 Curscop
: Entity_Id
;
11441 -- The current scope of the call. This is restored when we complete the
11442 -- delayed call, so that we do this in the right scope.
11444 Outer_Scope
: Entity_Id
;
11445 -- Save scope of outer level call
11447 From_Elab_Code
: Boolean;
11448 -- Save indication of whether this call is from elaboration code
11450 In_Task_Activation
: Boolean;
11451 -- Save indication of whether this call is from a task body. Tasks are
11452 -- activated at the "begin", which is after all local procedure bodies,
11453 -- so calls to those procedures can't fail, even if they occur after the
11456 From_SPARK_Code
: Boolean;
11457 -- Save indication of whether this call is under SPARK_Mode => On
11460 package Delay_Check
is new Table
.Table
11461 (Table_Component_Type
=> Delay_Element
,
11462 Table_Index_Type
=> Int
,
11463 Table_Low_Bound
=> 1,
11464 Table_Initial
=> 1000,
11465 Table_Increment
=> 100,
11466 Table_Name
=> "Delay_Check");
11468 C_Scope
: Entity_Id
;
11469 -- Top-level scope of current scope. Compute this only once at the outer
11470 -- level, i.e. for a call to Check_Elab_Call from outside this unit.
11472 Outer_Level_Sloc
: Source_Ptr
;
11473 -- Save Sloc value for outer level call node for comparisons of source
11474 -- locations. A body is too late if it appears after the *outer* level
11475 -- call, not the particular call that is being analyzed.
11477 From_Elab_Code
: Boolean;
11478 -- This flag shows whether the outer level call currently being examined
11479 -- is or is not in elaboration code. We are only interested in calls to
11480 -- routines in other units if this flag is True.
11482 In_Task_Activation
: Boolean := False;
11483 -- This flag indicates whether we are performing elaboration checks on task
11484 -- bodies, at the point of activation. If true, we do not raise
11485 -- Program_Error for calls to local procedures, because all local bodies
11486 -- are known to be elaborated. However, we still need to trace such calls,
11487 -- because a local procedure could call a procedure in another package,
11488 -- so we might need an implicit Elaborate_All.
11490 Delaying_Elab_Checks
: Boolean := True;
11491 -- This is set True till the compilation is complete, including the
11492 -- insertion of all instance bodies. Then when Check_Elab_Calls is called,
11493 -- the delay table is used to make the delayed calls and this flag is reset
11494 -- to False, so that the calls are processed.
11496 -----------------------
11497 -- Local Subprograms --
11498 -----------------------
11500 -- Note: Outer_Scope in all following specs represents the scope of
11501 -- interest of the outer level call. If it is set to Standard_Standard,
11502 -- then it means the outer level call was at elaboration level, and that
11503 -- thus all calls are of interest. If it was set to some other scope,
11504 -- then the original call was an inner call, and we are not interested
11505 -- in calls that go outside this scope.
11507 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
);
11508 -- Analysis of construct N shows that we should set Elaborate_All_Desirable
11509 -- for the WITH clause for unit U (which will always be present). A special
11510 -- case is when N is a function or procedure instantiation, in which case
11511 -- it is sufficient to set Elaborate_Desirable, since in this case there is
11512 -- no possibility of transitive elaboration issues.
11514 procedure Check_A_Call
11517 Outer_Scope
: Entity_Id
;
11518 Inter_Unit_Only
: Boolean;
11519 Generate_Warnings
: Boolean := True;
11520 In_Init_Proc
: Boolean := False);
11521 -- This is the internal recursive routine that is called to check for
11522 -- possible elaboration error. The argument N is a subprogram call or
11523 -- generic instantiation, or 'Access attribute reference to be checked, and
11524 -- E is the entity of the called subprogram, or instantiated generic unit,
11525 -- or subprogram referenced by 'Access.
11527 -- In SPARK mode, N can also be a variable reference, since in SPARK this
11528 -- also triggers a requirement for Elaborate_All, and in this case E is the
11529 -- entity being referenced.
11531 -- Outer_Scope is the outer level scope for the original reference.
11532 -- Inter_Unit_Only is set if the call is only to be checked in the
11533 -- case where it is to another unit (and skipped if within a unit).
11534 -- Generate_Warnings is set to False to suppress warning messages about
11535 -- missing pragma Elaborate_All's. These messages are not wanted for
11536 -- inner calls in the dynamic model. Note that an instance of the Access
11537 -- attribute applied to a subprogram also generates a call to this
11538 -- procedure (since the referenced subprogram may be called later
11539 -- indirectly). Flag In_Init_Proc should be set whenever the current
11540 -- context is a type init proc.
11542 -- Note: this might better be called Check_A_Reference to recognize the
11543 -- variable case for SPARK, but we prefer to retain the historical name
11544 -- since in practice this is mostly about checking calls for the possible
11545 -- occurrence of an access-before-elaboration exception.
11547 procedure Check_Bad_Instantiation
(N
: Node_Id
);
11548 -- N is a node for an instantiation (if called with any other node kind,
11549 -- Check_Bad_Instantiation ignores the call). This subprogram checks for
11550 -- the special case of a generic instantiation of a generic spec in the
11551 -- same declarative part as the instantiation where a body is present and
11552 -- has not yet been seen. This is an obvious error, but needs to be checked
11553 -- specially at the time of the instantiation, since it is a case where we
11554 -- cannot insert the body anywhere. If this case is detected, warnings are
11555 -- generated, and a raise of Program_Error is inserted. In addition any
11556 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation
11557 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this
11558 -- flag as an indication that no attempt should be made to insert an
11561 procedure Check_Internal_Call
11564 Outer_Scope
: Entity_Id
;
11565 Orig_Ent
: Entity_Id
);
11566 -- N is a function call or procedure statement call node and E is the
11567 -- entity of the called function, which is within the current compilation
11568 -- unit (where subunits count as part of the parent). This call checks if
11569 -- this call, or any call within any accessed body could cause an ABE, and
11570 -- if so, outputs a warning. Orig_Ent differs from E only in the case of
11571 -- renamings, and points to the original name of the entity. This is used
11572 -- for error messages. Outer_Scope is the outer level scope for the
11575 procedure Check_Internal_Call_Continue
11578 Outer_Scope
: Entity_Id
;
11579 Orig_Ent
: Entity_Id
);
11580 -- The processing for Check_Internal_Call is divided up into two phases,
11581 -- and this represents the second phase. The second phase is delayed if
11582 -- Delaying_Elab_Checks is set to True. In this delayed case, the first
11583 -- phase makes an entry in the Delay_Check table, which is processed when
11584 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
11585 -- Check_Internal_Call. Outer_Scope is the outer level scope for the
11588 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
;
11589 -- N is either a function or procedure call or an access attribute that
11590 -- references a subprogram. This call retrieves the relevant entity. If
11591 -- this is a call to a protected subprogram, the entity is a selected
11592 -- component. The callable entity may be absent, in which case Empty is
11593 -- returned. This happens with non-analyzed calls in nested generics.
11595 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable
11596 -- entity, in which case, the value returned is simply this entity.
11598 function Has_Generic_Body
(N
: Node_Id
) return Boolean;
11599 -- N is a generic package instantiation node, and this routine determines
11600 -- if this package spec does in fact have a generic body. If so, then
11601 -- True is returned, otherwise False. Note that this is not at all the
11602 -- same as checking if the unit requires a body, since it deals with
11603 -- the case of optional bodies accurately (i.e. if a body is optional,
11604 -- then it looks to see if a body is actually present). Note: this
11605 -- function can only do a fully correct job if in generating code mode
11606 -- where all bodies have to be present. If we are operating in semantics
11607 -- check only mode, then in some cases of optional bodies, a result of
11608 -- False may incorrectly be given. In practice this simply means that
11609 -- some cases of warnings for incorrect order of elaboration will only
11610 -- be given when generating code, which is not a big problem (and is
11611 -- inevitable, given the optional body semantics of Ada).
11613 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
);
11614 -- Given code for an elaboration check (or unconditional raise if the check
11615 -- is not needed), inserts the code in the appropriate place. N is the call
11616 -- or instantiation node for which the check code is required. C is the
11617 -- test whose failure triggers the raise.
11619 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean;
11620 -- Returns True if node N is a call to a generic formal subprogram
11622 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean;
11623 -- Determine whether entity Id denotes a [Deep_]Finalize procedure
11625 procedure Output_Calls
11627 Check_Elab_Flag
: Boolean);
11628 -- Outputs chain of calls stored in the Elab_Call table. The caller has
11629 -- already generated the main warning message, so the warnings generated
11630 -- are all continuation messages. The argument is the call node at which
11631 -- the messages are to be placed. When Check_Elab_Flag is set, calls are
11632 -- enumerated only when flag Elab_Warning is set for the dynamic case or
11633 -- when flag Elab_Info_Messages is set for the static case.
11635 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean;
11636 -- Given two scopes, determine whether they are the same scope from an
11637 -- elaboration point of view, i.e. packages and blocks are ignored.
11639 procedure Set_C_Scope
;
11640 -- On entry C_Scope is set to some scope. On return, C_Scope is reset
11641 -- to be the enclosing compilation unit of this scope.
11643 procedure Set_Elaboration_Constraint
11647 -- The current unit U may depend semantically on some unit P that is not
11648 -- in the current context. If there is an elaboration call that reaches P,
11649 -- we need to indicate that P requires an Elaborate_All, but this is not
11650 -- effective in U's ali file, if there is no with_clause for P. In this
11651 -- case we add the Elaborate_All on the unit Q that directly or indirectly
11652 -- makes P available. This can happen in two cases:
11654 -- a) Q declares a subtype of a type declared in P, and the call is an
11655 -- initialization call for an object of that subtype.
11657 -- b) Q declares an object of some tagged type whose root type is
11658 -- declared in P, and the initialization call uses object notation on
11659 -- that object to reach a primitive operation or a classwide operation
11662 -- If P appears in the context of U, the current processing is correct.
11663 -- Otherwise we must identify these two cases to retrieve Q and place the
11664 -- Elaborate_All_Desirable on it.
11666 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
;
11667 -- Given a compilation unit entity, if it is a spec entity, it is returned
11668 -- unchanged. If it is a body entity, then the spec for the corresponding
11669 -- spec is returned
11671 function Within
(E1
, E2
: Entity_Id
) return Boolean;
11672 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
11673 -- of its contained scopes, False otherwise.
11675 function Within_Elaborate_All
11676 (Unit
: Unit_Number_Type
;
11677 E
: Entity_Id
) return Boolean;
11678 -- Return True if we are within the scope of an Elaborate_All for E, or if
11679 -- we are within the scope of an Elaborate_All for some other unit U, and U
11680 -- with's E. This prevents spurious warnings when the called entity is
11681 -- renamed within U, or in case of generic instances.
11683 --------------------------------------
11684 -- Activate_Elaborate_All_Desirable --
11685 --------------------------------------
11687 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
) is
11688 UN
: constant Unit_Number_Type
:= Get_Code_Unit
(N
);
11689 CU
: constant Node_Id
:= Cunit
(UN
);
11690 UE
: constant Entity_Id
:= Cunit_Entity
(UN
);
11691 Unm
: constant Unit_Name_Type
:= Unit_Name
(UN
);
11692 CI
: constant List_Id
:= Context_Items
(CU
);
11696 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
);
11697 -- This procedure is called when the elaborate indication must be
11698 -- applied to a unit not in the context of the referencing unit. The
11699 -- unit gets added to the context as an implicit with.
11701 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean;
11702 -- UEs is the spec entity of a unit. If the unit to be marked is
11703 -- in the context item list of this unit spec, then the call returns
11704 -- True and Itm is left set to point to the relevant N_With_Clause node.
11706 procedure Set_Elab_Flag
(Itm
: Node_Id
);
11707 -- Sets Elaborate_[All_]Desirable as appropriate on Itm
11709 -----------------------------
11710 -- Add_To_Context_And_Mark --
11711 -----------------------------
11713 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
) is
11714 CW
: constant Node_Id
:=
11715 Make_With_Clause
(Sloc
(Itm
),
11716 Name
=> Name
(Itm
));
11719 Set_Library_Unit
(CW
, Library_Unit
(Itm
));
11720 Set_Implicit_With
(CW
, True);
11722 -- Set elaborate all desirable on copy and then append the copy to
11723 -- the list of body with's and we are done.
11725 Set_Elab_Flag
(CW
);
11726 Append_To
(CI
, CW
);
11727 end Add_To_Context_And_Mark
;
11733 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean is
11734 UNs
: constant Unit_Number_Type
:= Get_Source_Unit
(UEs
);
11735 CUs
: constant Node_Id
:= Cunit
(UNs
);
11736 CIs
: constant List_Id
:= Context_Items
(CUs
);
11739 Itm
:= First
(CIs
);
11740 while Present
(Itm
) loop
11741 if Nkind
(Itm
) = N_With_Clause
then
11743 Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
11756 -------------------
11757 -- Set_Elab_Flag --
11758 -------------------
11760 procedure Set_Elab_Flag
(Itm
: Node_Id
) is
11762 if Nkind
(N
) in N_Subprogram_Instantiation
then
11763 Set_Elaborate_Desirable
(Itm
);
11765 Set_Elaborate_All_Desirable
(Itm
);
11769 -- Start of processing for Activate_Elaborate_All_Desirable
11772 -- Do not set binder indication if expansion is disabled, as when
11773 -- compiling a generic unit.
11775 if not Expander_Active
then
11779 -- If an instance of a generic package contains a controlled object (so
11780 -- we're calling Initialize at elaboration time), and the instance is in
11781 -- a package body P that says "with P;", then we need to return without
11782 -- adding "pragma Elaborate_All (P);" to P.
11784 if U
= Main_Unit_Entity
then
11789 while Present
(Itm
) loop
11790 if Nkind
(Itm
) = N_With_Clause
then
11791 Ent
:= Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
11793 -- If we find it, then mark elaborate all desirable and return
11796 Set_Elab_Flag
(Itm
);
11804 -- If we fall through then the with clause is not present in the
11805 -- current unit. One legitimate possibility is that the with clause
11806 -- is present in the spec when we are a body.
11808 if Is_Body_Name
(Unm
)
11809 and then In_Withs_Of
(Spec_Entity
(UE
))
11811 Add_To_Context_And_Mark
(Itm
);
11815 -- Similarly, we may be in the spec or body of a child unit, where
11816 -- the unit in question is with'ed by some ancestor of the child unit.
11818 if Is_Child_Name
(Unm
) then
11825 Pkg
:= Scope
(Pkg
);
11826 exit when Pkg
= Standard_Standard
;
11828 if In_Withs_Of
(Pkg
) then
11829 Add_To_Context_And_Mark
(Itm
);
11836 -- Here if we do not find with clause on spec or body. We just ignore
11837 -- this case; it means that the elaboration involves some other unit
11838 -- than the unit being compiled, and will be caught elsewhere.
11839 end Activate_Elaborate_All_Desirable
;
11845 procedure Check_A_Call
11848 Outer_Scope
: Entity_Id
;
11849 Inter_Unit_Only
: Boolean;
11850 Generate_Warnings
: Boolean := True;
11851 In_Init_Proc
: Boolean := False)
11853 Access_Case
: constant Boolean := Nkind
(N
) = N_Attribute_Reference
;
11854 -- Indicates if we have Access attribute case
11856 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean;
11857 -- True if we're calling an instance of a generic subprogram, or a
11858 -- subprogram in an instance of a generic package, and the call is
11859 -- outside that instance.
11861 procedure Elab_Warning
11864 Ent
: Node_Or_Entity_Id
);
11865 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
11866 -- dynamic or static elaboration model), N and Ent. Msg_D is a real
11867 -- warning (output if Msg_D is non-null and Elab_Warnings is set),
11868 -- Msg_S is an info message (output if Elab_Info_Messages is set).
11870 function Find_W_Scope
return Entity_Id
;
11871 -- Find top-level scope for called entity (not following renamings
11872 -- or derivations). This is where the Elaborate_All will go if it is
11873 -- needed. We start with the called entity, except in the case of an
11874 -- initialization procedure outside the current package, where the init
11875 -- proc is in the root package, and we start from the entity of the name
11878 -----------------------------------
11879 -- Call_To_Instance_From_Outside --
11880 -----------------------------------
11882 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean is
11883 Scop
: Entity_Id
:= Id
;
11887 if Scop
= Standard_Standard
then
11891 if Is_Generic_Instance
(Scop
) then
11892 return not In_Open_Scopes
(Scop
);
11895 Scop
:= Scope
(Scop
);
11897 end Call_To_Instance_From_Outside
;
11903 procedure Elab_Warning
11906 Ent
: Node_Or_Entity_Id
)
11909 -- Dynamic elaboration checks, real warning
11911 if Dynamic_Elaboration_Checks
then
11912 if not Access_Case
then
11913 if Msg_D
/= "" and then Elab_Warnings
then
11914 Error_Msg_NE
(Msg_D
, N
, Ent
);
11917 -- In the access case emit first warning message as well,
11918 -- otherwise list of calls will appear as errors.
11920 elsif Elab_Warnings
then
11921 Error_Msg_NE
(Msg_S
, N
, Ent
);
11924 -- Static elaboration checks, info message
11927 if Elab_Info_Messages
then
11928 Error_Msg_NE
(Msg_S
, N
, Ent
);
11937 function Find_W_Scope
return Entity_Id
is
11938 Refed_Ent
: constant Entity_Id
:= Get_Referenced_Ent
(N
);
11939 W_Scope
: Entity_Id
;
11942 if Is_Init_Proc
(Refed_Ent
)
11943 and then not In_Same_Extended_Unit
(N
, Refed_Ent
)
11945 W_Scope
:= Scope
(Refed_Ent
);
11950 -- Now loop through scopes to get to the enclosing compilation unit
11952 while not Is_Compilation_Unit
(W_Scope
) loop
11953 W_Scope
:= Scope
(W_Scope
);
11961 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
11962 -- Indicates if we have instantiation case
11964 Loc
: constant Source_Ptr
:= Sloc
(N
);
11966 Variable_Case
: constant Boolean :=
11967 Nkind
(N
) in N_Has_Entity
11968 and then Present
(Entity
(N
))
11969 and then Ekind
(Entity
(N
)) = E_Variable
;
11970 -- Indicates if we have variable reference case
11972 W_Scope
: constant Entity_Id
:= Find_W_Scope
;
11973 -- Top-level scope of directly called entity for subprogram. This
11974 -- differs from E_Scope in the case where renamings or derivations
11975 -- are involved, since it does not follow these links. W_Scope is
11976 -- generally in a visible unit, and it is this scope that may require
11977 -- an Elaborate_All. However, there are some cases (initialization
11978 -- calls and calls involving object notation) where W_Scope might not
11979 -- be in the context of the current unit, and there is an intermediate
11980 -- package that is, in which case the Elaborate_All has to be placed
11981 -- on this intermediate package. These special cases are handled in
11982 -- Set_Elaboration_Constraint.
11985 Callee_Unit_Internal
: Boolean;
11986 Caller_Unit_Internal
: Boolean;
11988 Inst_Callee
: Source_Ptr
;
11989 Inst_Caller
: Source_Ptr
;
11990 Unit_Callee
: Unit_Number_Type
;
11991 Unit_Caller
: Unit_Number_Type
;
11993 Body_Acts_As_Spec
: Boolean;
11994 -- Set to true if call is to body acting as spec (no separate spec)
11996 Cunit_SC
: Boolean := False;
11997 -- Set to suppress dynamic elaboration checks where one of the
11998 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
11999 -- if a pragma Elaborate[_All] applies to that scope, in which case
12000 -- warnings on the scope are also suppressed. For the internal case,
12001 -- we ignore this flag.
12003 E_Scope
: Entity_Id
;
12004 -- Top-level scope of entity for called subprogram. This value includes
12005 -- following renamings and derivations, so this scope can be in a
12006 -- non-visible unit. This is the scope that is to be investigated to
12007 -- see whether an elaboration check is required.
12010 -- Flag set when the subprogram being invoked is the procedure generated
12011 -- for pragma Default_Initial_Condition.
12013 SPARK_Elab_Errors
: Boolean;
12014 -- Flag set when an entity is called or a variable is read during SPARK
12015 -- dynamic elaboration.
12017 -- Start of processing for Check_A_Call
12020 -- If the call is known to be within a local Suppress Elaboration
12021 -- pragma, nothing to check. This can happen in task bodies. But
12022 -- we ignore this for a call to a generic formal.
12024 if Nkind
(N
) in N_Subprogram_Call
12025 and then No_Elaboration_Check
(N
)
12026 and then not Is_Call_Of_Generic_Formal
(N
)
12030 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to
12031 -- check, we don't mind in this case if the call occurs before the body
12032 -- since this is all generated code.
12034 elsif Nkind
(Original_Node
(N
)) = N_Attribute_Reference
12035 and then Attribute_Name
(Original_Node
(N
)) = Name_Valid_Scalars
12039 -- Intrinsics such as instances of Unchecked_Deallocation do not have
12040 -- any body, so elaboration checking is not needed, and would be wrong.
12042 elsif Is_Intrinsic_Subprogram
(E
) then
12045 -- Do not consider references to internal variables for SPARK semantics
12047 elsif Variable_Case
and then not Comes_From_Source
(E
) then
12051 -- Proceed with check
12055 -- For a variable reference, just set Body_Acts_As_Spec to False
12057 if Variable_Case
then
12058 Body_Acts_As_Spec
:= False;
12060 -- Additional checks for all other cases
12063 -- Go to parent for derived subprogram, or to original subprogram in
12064 -- the case of a renaming (Alias covers both these cases).
12067 if (Suppress_Elaboration_Warnings
(Ent
)
12068 or else Elaboration_Checks_Suppressed
(Ent
))
12069 and then (Inst_Case
or else No
(Alias
(Ent
)))
12074 -- Nothing to do for imported entities
12076 if Is_Imported
(Ent
) then
12080 exit when Inst_Case
or else No
(Alias
(Ent
));
12081 Ent
:= Alias
(Ent
);
12084 Decl
:= Unit_Declaration_Node
(Ent
);
12086 if Nkind
(Decl
) = N_Subprogram_Body
then
12087 Body_Acts_As_Spec
:= True;
12089 elsif Nkind_In
(Decl
, N_Subprogram_Declaration
,
12090 N_Subprogram_Body_Stub
)
12093 Body_Acts_As_Spec
:= False;
12095 -- If we have none of an instantiation, subprogram body or subprogram
12096 -- declaration, or in the SPARK case, a variable reference, then
12097 -- it is not a case that we want to check. (One case is a call to a
12098 -- generic formal subprogram, where we do not want the check in the
12108 if Elaboration_Checks_Suppressed
(E_Scope
)
12109 or else Suppress_Elaboration_Warnings
(E_Scope
)
12114 -- Exit when we get to compilation unit, not counting subunits
12116 exit when Is_Compilation_Unit
(E_Scope
)
12117 and then (Is_Child_Unit
(E_Scope
)
12118 or else Scope
(E_Scope
) = Standard_Standard
);
12120 pragma Assert
(E_Scope
/= Standard_Standard
);
12122 -- Move up a scope looking for compilation unit
12124 E_Scope
:= Scope
(E_Scope
);
12127 -- No checks needed for pure or preelaborated compilation units
12129 if Is_Pure
(E_Scope
) or else Is_Preelaborated
(E_Scope
) then
12133 -- If the generic entity is within a deeper instance than we are, then
12134 -- either the instantiation to which we refer itself caused an ABE, in
12135 -- which case that will be handled separately, or else we know that the
12136 -- body we need appears as needed at the point of the instantiation.
12137 -- However, this assumption is only valid if we are in static mode.
12139 if not Dynamic_Elaboration_Checks
12141 Instantiation_Depth
(Sloc
(Ent
)) > Instantiation_Depth
(Sloc
(N
))
12146 -- Do not give a warning for a package with no body
12148 if Ekind
(Ent
) = E_Generic_Package
and then not Has_Generic_Body
(N
) then
12152 -- Case of entity is in same unit as call or instantiation. In the
12153 -- instantiation case, W_Scope may be different from E_Scope; we want
12154 -- the unit in which the instantiation occurs, since we're analyzing
12155 -- based on the expansion.
12157 if W_Scope
= C_Scope
then
12158 if not Inter_Unit_Only
then
12159 Check_Internal_Call
(N
, Ent
, Outer_Scope
, E
);
12165 -- Case of entity is not in current unit (i.e. with'ed unit case)
12167 -- We are only interested in such calls if the outer call was from
12168 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
12170 if not From_Elab_Code
and then not Dynamic_Elaboration_Checks
then
12174 -- Nothing to do if some scope said that no checks were required
12180 -- Nothing to do for a generic instance, because a call to an instance
12181 -- cannot fail the elaboration check, because the body of the instance
12182 -- is always elaborated immediately after the spec.
12184 if Call_To_Instance_From_Outside
(Ent
) then
12188 -- Nothing to do if subprogram with no separate spec. However, a call
12189 -- to Deep_Initialize may result in a call to a user-defined Initialize
12190 -- procedure, which imposes a body dependency. This happens only if the
12191 -- type is controlled and the Initialize procedure is not inherited.
12193 if Body_Acts_As_Spec
then
12194 if Is_TSS
(Ent
, TSS_Deep_Initialize
) then
12196 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Ent
));
12200 if not Is_Controlled
(Typ
) then
12203 Init
:= Find_Prim_Op
(Typ
, Name_Initialize
);
12205 if Comes_From_Source
(Init
) then
12218 -- Check cases of internal units
12220 Callee_Unit_Internal
:= In_Internal_Unit
(E_Scope
);
12222 -- Do not give a warning if the with'ed unit is internal and this is
12223 -- the generic instantiation case (this saves a lot of hassle dealing
12224 -- with the Text_IO special child units)
12226 if Callee_Unit_Internal
and Inst_Case
then
12230 if C_Scope
= Standard_Standard
then
12231 Caller_Unit_Internal
:= False;
12233 Caller_Unit_Internal
:= In_Internal_Unit
(C_Scope
);
12236 -- Do not give a warning if the with'ed unit is internal and the caller
12237 -- is not internal (since the binder always elaborates internal units
12240 if Callee_Unit_Internal
and not Caller_Unit_Internal
then
12244 -- For now, if debug flag -gnatdE is not set, do no checking for one
12245 -- internal unit withing another. This fixes the problem with the sgi
12246 -- build and storage errors. To be resolved later ???
12248 if (Callee_Unit_Internal
and Caller_Unit_Internal
)
12249 and not Debug_Flag_EE
12254 if Is_TSS
(E
, TSS_Deep_Initialize
) then
12258 -- If the call is in an instance, and the called entity is not
12259 -- defined in the same instance, then the elaboration issue focuses
12260 -- around the unit containing the template, it is this unit that
12261 -- requires an Elaborate_All.
12263 -- However, if we are doing dynamic elaboration, we need to chase the
12264 -- call in the usual manner.
12266 -- We also need to chase the call in the usual manner if it is a call
12267 -- to a generic formal parameter, since that case was not handled as
12268 -- part of the processing of the template.
12270 Inst_Caller
:= Instantiation
(Get_Source_File_Index
(Sloc
(N
)));
12271 Inst_Callee
:= Instantiation
(Get_Source_File_Index
(Sloc
(Ent
)));
12273 if Inst_Caller
= No_Location
then
12274 Unit_Caller
:= No_Unit
;
12276 Unit_Caller
:= Get_Source_Unit
(N
);
12279 if Inst_Callee
= No_Location
then
12280 Unit_Callee
:= No_Unit
;
12282 Unit_Callee
:= Get_Source_Unit
(Ent
);
12285 if Unit_Caller
/= No_Unit
12286 and then Unit_Callee
/= Unit_Caller
12287 and then not Dynamic_Elaboration_Checks
12288 and then not Is_Call_Of_Generic_Formal
(N
)
12290 E_Scope
:= Spec_Entity
(Cunit_Entity
(Unit_Caller
));
12292 -- If we don't get a spec entity, just ignore call. Not quite
12293 -- clear why this check is necessary. ???
12295 if No
(E_Scope
) then
12299 -- Otherwise step to enclosing compilation unit
12301 while not Is_Compilation_Unit
(E_Scope
) loop
12302 E_Scope
:= Scope
(E_Scope
);
12305 -- For the case where N is not an instance, and is not a call within
12306 -- instance to other than a generic formal, we recompute E_Scope
12307 -- for the error message, since we do NOT want to go to the unit
12308 -- that has the ultimate declaration in the case of renaming and
12309 -- derivation and we also want to go to the generic unit in the
12310 -- case of an instance, and no further.
12313 -- Loop to carefully follow renamings and derivations one step
12314 -- outside the current unit, but not further.
12316 if not (Inst_Case
or Variable_Case
)
12317 and then Present
(Alias
(Ent
))
12319 E_Scope
:= Alias
(Ent
);
12325 while not Is_Compilation_Unit
(E_Scope
) loop
12326 E_Scope
:= Scope
(E_Scope
);
12329 -- If E_Scope is the same as C_Scope, it means that there
12330 -- definitely was a local renaming or derivation, and we
12331 -- are not yet out of the current unit.
12333 exit when E_Scope
/= C_Scope
;
12334 Ent
:= Alias
(Ent
);
12337 -- If no alias, there could be a previous error, but not if we've
12338 -- already reached the outermost level (Standard).
12346 if Within_Elaborate_All
(Current_Sem_Unit
, E_Scope
) then
12350 -- Determine whether the Default_Initial_Condition procedure of some
12351 -- type is being invoked.
12353 Is_DIC
:= Ekind
(Ent
) = E_Procedure
and then Is_DIC_Procedure
(Ent
);
12355 -- Checks related to Default_Initial_Condition fall under the SPARK
12356 -- umbrella because this is a SPARK-specific annotation.
12358 SPARK_Elab_Errors
:=
12359 SPARK_Mode
= On
and (Is_DIC
or Dynamic_Elaboration_Checks
);
12361 -- Now check if an Elaborate_All (or dynamic check) is needed
12363 if (Elab_Info_Messages
or Elab_Warnings
or SPARK_Elab_Errors
)
12364 and then Generate_Warnings
12365 and then not Suppress_Elaboration_Warnings
(Ent
)
12366 and then not Elaboration_Checks_Suppressed
(Ent
)
12367 and then not Suppress_Elaboration_Warnings
(E_Scope
)
12368 and then not Elaboration_Checks_Suppressed
(E_Scope
)
12370 -- Instantiation case
12373 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
12375 ("instantiation of & during elaboration in SPARK", N
, Ent
);
12378 ("instantiation of & may raise Program_Error?l?",
12379 "info: instantiation of & during elaboration?$?", Ent
);
12382 -- Indirect call case, info message only in static elaboration
12383 -- case, because the attribute reference itself cannot raise an
12384 -- exception. Note that SPARK does not permit indirect calls.
12386 elsif Access_Case
then
12387 Elab_Warning
("", "info: access to & during elaboration?$?", Ent
);
12389 -- Variable reference in SPARK mode
12391 elsif Variable_Case
then
12392 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
12394 ("reference to & during elaboration in SPARK", N
, Ent
);
12397 -- Subprogram call case
12400 if Nkind
(Name
(N
)) in N_Has_Entity
12401 and then Is_Init_Proc
(Entity
(Name
(N
)))
12402 and then Comes_From_Source
(Ent
)
12405 ("implicit call to & may raise Program_Error?l?",
12406 "info: implicit call to & during elaboration?$?",
12409 elsif SPARK_Elab_Errors
then
12411 -- Emit a specialized error message when the elaboration of an
12412 -- object of a private type evaluates the expression of pragma
12413 -- Default_Initial_Condition. This prevents the internal name
12414 -- of the procedure from appearing in the error message.
12418 ("call to Default_Initial_Condition during elaboration in "
12422 ("call to & during elaboration in SPARK", N
, Ent
);
12427 ("call to & may raise Program_Error?l?",
12428 "info: call to & during elaboration?$?",
12433 Error_Msg_Qual_Level
:= Nat
'Last;
12435 -- Case of Elaborate_All not present and required, for SPARK this
12436 -- is an error, so give an error message.
12438 if SPARK_Elab_Errors
then
12439 Error_Msg_NE
-- CODEFIX
12440 ("\Elaborate_All pragma required for&", N
, W_Scope
);
12442 -- Otherwise we generate an implicit pragma. For a subprogram
12443 -- instantiation, Elaborate is good enough, since no transitive
12444 -- call is possible at elaboration time in this case.
12446 elsif Nkind
(N
) in N_Subprogram_Instantiation
then
12448 ("\missing pragma Elaborate for&?l?",
12449 "\implicit pragma Elaborate for& generated?$?",
12452 -- For all other cases, we need an implicit Elaborate_All
12456 ("\missing pragma Elaborate_All for&?l?",
12457 "\implicit pragma Elaborate_All for & generated?$?",
12461 Error_Msg_Qual_Level
:= 0;
12463 -- Take into account the flags related to elaboration warning
12464 -- messages when enumerating the various calls involved. This
12465 -- ensures the proper pairing of the main warning and the
12466 -- clarification messages generated by Output_Calls.
12468 Output_Calls
(N
, Check_Elab_Flag
=> True);
12470 -- Set flag to prevent further warnings for same unit unless in
12471 -- All_Errors_Mode.
12473 if not All_Errors_Mode
and not Dynamic_Elaboration_Checks
then
12474 Set_Suppress_Elaboration_Warnings
(W_Scope
);
12478 -- Check for runtime elaboration check required
12480 if Dynamic_Elaboration_Checks
then
12481 if not Elaboration_Checks_Suppressed
(Ent
)
12482 and then not Elaboration_Checks_Suppressed
(W_Scope
)
12483 and then not Elaboration_Checks_Suppressed
(E_Scope
)
12484 and then not Cunit_SC
12486 -- Runtime elaboration check required. Generate check of the
12487 -- elaboration Boolean for the unit containing the entity.
12489 -- Note that for this case, we do check the real unit (the one
12490 -- from following renamings, since that is the issue).
12492 -- Could this possibly miss a useless but required PE???
12494 Insert_Elab_Check
(N
,
12495 Make_Attribute_Reference
(Loc
,
12496 Attribute_Name
=> Name_Elaborated
,
12498 New_Occurrence_Of
(Spec_Entity
(E_Scope
), Loc
)));
12500 -- Prevent duplicate elaboration checks on the same call, which
12501 -- can happen if the body enclosing the call appears itself in a
12502 -- call whose elaboration check is delayed.
12504 if Nkind
(N
) in N_Subprogram_Call
then
12505 Set_No_Elaboration_Check
(N
);
12509 -- Case of static elaboration model
12512 -- Do not do anything if elaboration checks suppressed. Note that
12513 -- we check Ent here, not E, since we want the real entity for the
12514 -- body to see if checks are suppressed for it, not the dummy
12515 -- entry for renamings or derivations.
12517 if Elaboration_Checks_Suppressed
(Ent
)
12518 or else Elaboration_Checks_Suppressed
(E_Scope
)
12519 or else Elaboration_Checks_Suppressed
(W_Scope
)
12523 -- Do not generate an Elaborate_All for finalization routines
12524 -- that perform partial clean up as part of initialization.
12526 elsif In_Init_Proc
and then Is_Finalization_Procedure
(Ent
) then
12529 -- Here we need to generate an implicit elaborate all
12532 -- Generate Elaborate_All warning unless suppressed
12534 if (Elab_Info_Messages
and Generate_Warnings
and not Inst_Case
)
12535 and then not Suppress_Elaboration_Warnings
(Ent
)
12536 and then not Suppress_Elaboration_Warnings
(E_Scope
)
12537 and then not Suppress_Elaboration_Warnings
(W_Scope
)
12539 Error_Msg_Node_2
:= W_Scope
;
12541 ("info: call to& in elaboration code requires pragma "
12542 & "Elaborate_All on&?$?", N
, E
);
12545 -- Set indication for binder to generate Elaborate_All
12547 Set_Elaboration_Constraint
(N
, E
, W_Scope
);
12552 -----------------------------
12553 -- Check_Bad_Instantiation --
12554 -----------------------------
12556 procedure Check_Bad_Instantiation
(N
: Node_Id
) is
12560 -- Nothing to do if we do not have an instantiation (happens in some
12561 -- error cases, and also in the formal package declaration case)
12563 if Nkind
(N
) not in N_Generic_Instantiation
then
12566 -- Nothing to do if serious errors detected (avoid cascaded errors)
12568 elsif Serious_Errors_Detected
/= 0 then
12571 -- Nothing to do if not in full analysis mode
12573 elsif not Full_Analysis
then
12576 -- Nothing to do if inside a generic template
12578 elsif Inside_A_Generic
then
12581 -- Nothing to do if a library level instantiation
12583 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
12586 -- Nothing to do if we are compiling a proper body for semantic
12587 -- purposes only. The generic body may be in another proper body.
12590 Nkind
(Parent
(Unit_Declaration_Node
(Main_Unit_Entity
))) = N_Subunit
12595 Ent
:= Get_Generic_Entity
(N
);
12597 -- The case we are interested in is when the generic spec is in the
12598 -- current declarative part
12600 if not Same_Elaboration_Scope
(Current_Scope
, Scope
(Ent
))
12601 or else not In_Same_Extended_Unit
(N
, Ent
)
12606 -- If the generic entity is within a deeper instance than we are, then
12607 -- either the instantiation to which we refer itself caused an ABE, in
12608 -- which case that will be handled separately. Otherwise, we know that
12609 -- the body we need appears as needed at the point of the instantiation.
12610 -- If they are both at the same level but not within the same instance
12611 -- then the body of the generic will be in the earlier instance.
12614 D1
: constant Nat
:= Instantiation_Depth
(Sloc
(Ent
));
12615 D2
: constant Nat
:= Instantiation_Depth
(Sloc
(N
));
12622 and then Is_Generic_Instance
(Scope
(Ent
))
12623 and then not In_Open_Scopes
(Scope
(Ent
))
12629 -- Now we can proceed, if the entity being called has a completion,
12630 -- then we are definitely OK, since we have already seen the body.
12632 if Has_Completion
(Ent
) then
12636 -- If there is no body, then nothing to do
12638 if not Has_Generic_Body
(N
) then
12642 -- Here we definitely have a bad instantiation
12644 Error_Msg_Warn
:= SPARK_Mode
/= On
;
12645 Error_Msg_NE
("cannot instantiate& before body seen<<", N
, Ent
);
12646 Error_Msg_N
("\Program_Error [<<", N
);
12648 Insert_Elab_Check
(N
);
12649 Set_Is_Known_Guaranteed_ABE
(N
);
12650 end Check_Bad_Instantiation
;
12652 ---------------------
12653 -- Check_Elab_Call --
12654 ---------------------
12656 procedure Check_Elab_Call
12658 Outer_Scope
: Entity_Id
:= Empty
;
12659 In_Init_Proc
: Boolean := False)
12665 pragma Assert
(Legacy_Elaboration_Checks
);
12667 -- If the reference is not in the main unit, there is nothing to check.
12668 -- Elaboration call from units in the context of the main unit will lead
12669 -- to semantic dependencies when those units are compiled.
12671 if not In_Extended_Main_Code_Unit
(N
) then
12675 -- For an entry call, check relevant restriction
12677 if Nkind
(N
) = N_Entry_Call_Statement
12678 and then not In_Subprogram_Or_Concurrent_Unit
12680 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, N
);
12682 -- Nothing to do if this is not an expected type of reference (happens
12683 -- in some error conditions, and in some cases where rewriting occurs).
12685 elsif Nkind
(N
) not in N_Subprogram_Call
12686 and then Nkind
(N
) /= N_Attribute_Reference
12687 and then (SPARK_Mode
/= On
12688 or else Nkind
(N
) not in N_Has_Entity
12689 or else No
(Entity
(N
))
12690 or else Ekind
(Entity
(N
)) /= E_Variable
)
12694 -- Nothing to do if this is a call already rewritten for elab checking.
12695 -- Such calls appear as the targets of If_Expressions.
12697 -- This check MUST be wrong, it catches far too much
12699 elsif Nkind
(Parent
(N
)) = N_If_Expression
then
12702 -- Nothing to do if inside a generic template
12704 elsif Inside_A_Generic
12705 and then No
(Enclosing_Generic_Body
(N
))
12709 -- Nothing to do if call is being pre-analyzed, as when within a
12710 -- pre/postcondition, a predicate, or an invariant.
12712 elsif In_Spec_Expression
then
12716 -- Nothing to do if this is a call to a postcondition, which is always
12717 -- within a subprogram body, even though the current scope may be the
12718 -- enclosing scope of the subprogram.
12720 if Nkind
(N
) = N_Procedure_Call_Statement
12721 and then Is_Entity_Name
(Name
(N
))
12722 and then Chars
(Entity
(Name
(N
))) = Name_uPostconditions
12727 -- Here we have a reference at elaboration time that must be checked
12729 if Debug_Flag_Underscore_LL
then
12730 Write_Str
(" Check_Elab_Ref: ");
12732 if Nkind
(N
) = N_Attribute_Reference
then
12733 if not Is_Entity_Name
(Prefix
(N
)) then
12734 Write_Str
("<<not entity name>>");
12736 Write_Name
(Chars
(Entity
(Prefix
(N
))));
12739 Write_Str
("'Access");
12741 elsif No
(Name
(N
)) or else not Is_Entity_Name
(Name
(N
)) then
12742 Write_Str
("<<not entity name>> ");
12745 Write_Name
(Chars
(Entity
(Name
(N
))));
12748 Write_Str
(" reference at ");
12749 Write_Location
(Sloc
(N
));
12753 -- Climb up the tree to make sure we are not inside default expression
12754 -- of a parameter specification or a record component, since in both
12755 -- these cases, we will be doing the actual reference later, not now,
12756 -- and it is at the time of the actual reference (statically speaking)
12757 -- that we must do our static check, not at the time of its initial
12760 -- However, we have to check references within component definitions
12761 -- (e.g. a function call that determines an array component bound),
12762 -- so we terminate the loop in that case.
12765 while Present
(P
) loop
12766 if Nkind_In
(P
, N_Parameter_Specification
,
12767 N_Component_Declaration
)
12771 -- The reference occurs within the constraint of a component,
12772 -- so it must be checked.
12774 elsif Nkind
(P
) = N_Component_Definition
then
12782 -- Stuff that happens only at the outer level
12784 if No
(Outer_Scope
) then
12785 Elab_Visited
.Set_Last
(0);
12787 -- Nothing to do if current scope is Standard (this is a bit odd, but
12788 -- it happens in the case of generic instantiations).
12790 C_Scope
:= Current_Scope
;
12792 if C_Scope
= Standard_Standard
then
12796 -- First case, we are in elaboration code
12798 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
12800 if From_Elab_Code
then
12802 -- Complain if ref that comes from source in preelaborated unit
12803 -- and we are not inside a subprogram (i.e. we are in elab code).
12805 if Comes_From_Source
(N
)
12806 and then In_Preelaborated_Unit
12807 and then not In_Inlined_Body
12808 and then Nkind
(N
) /= N_Attribute_Reference
12810 -- This is a warning in GNAT mode allowing such calls to be
12811 -- used in the predefined library with appropriate care.
12813 Error_Msg_Warn
:= GNAT_Mode
;
12815 ("<<non-static call not allowed in preelaborated unit", N
);
12819 -- Second case, we are inside a subprogram or concurrent unit, which
12820 -- means we are not in elaboration code.
12823 -- In this case, the issue is whether we are inside the
12824 -- declarative part of the unit in which we live, or inside its
12825 -- statements. In the latter case, there is no issue of ABE calls
12826 -- at this level (a call from outside to the unit in which we live
12827 -- might cause an ABE, but that will be detected when we analyze
12828 -- that outer level call, as it recurses into the called unit).
12830 -- Climb up the tree, doing this test, and also testing for being
12831 -- inside a default expression, which, as discussed above, is not
12832 -- checked at this stage.
12841 -- If we find a parentless subtree, it seems safe to assume
12842 -- that we are not in a declarative part and that no
12843 -- checking is required.
12849 if Is_List_Member
(P
) then
12850 L
:= List_Containing
(P
);
12857 exit when Nkind
(P
) = N_Subunit
;
12859 -- Filter out case of default expressions, where we do not
12860 -- do the check at this stage.
12862 if Nkind_In
(P
, N_Parameter_Specification
,
12863 N_Component_Declaration
)
12868 -- A protected body has no elaboration code and contains
12869 -- only other bodies.
12871 if Nkind
(P
) = N_Protected_Body
then
12874 elsif Nkind_In
(P
, N_Subprogram_Body
,
12879 if L
= Declarations
(P
) then
12882 -- We are not in elaboration code, but we are doing
12883 -- dynamic elaboration checks, in this case, we still
12884 -- need to do the reference, since the subprogram we are
12885 -- in could be called from another unit, also in dynamic
12886 -- elaboration check mode, at elaboration time.
12888 elsif Dynamic_Elaboration_Checks
then
12890 -- We provide a debug flag to disable this check. That
12891 -- way we have an easy work around for regressions
12892 -- that are caused by this new check. This debug flag
12893 -- can be removed later.
12895 if Debug_Flag_DD
then
12899 -- Do the check in this case
12903 elsif Nkind
(P
) = N_Task_Body
then
12905 -- The check is deferred until Check_Task_Activation
12906 -- but we need to capture local suppress pragmas
12907 -- that may inhibit checks on this call.
12909 Ent
:= Get_Referenced_Ent
(N
);
12914 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
12915 or else Elaboration_Checks_Suppressed
(Ent
)
12916 or else Elaboration_Checks_Suppressed
(Scope
(Ent
))
12918 if Nkind
(N
) in N_Subprogram_Call
then
12919 Set_No_Elaboration_Check
(N
);
12925 -- Static model, call is not in elaboration code, we
12926 -- never need to worry, because in the static model the
12927 -- top-level caller always takes care of things.
12938 Ent
:= Get_Referenced_Ent
(N
);
12944 -- Determine whether a prior call to the same subprogram was already
12945 -- examined within the same context. If this is the case, then there is
12946 -- no need to proceed with the various warnings and checks because the
12947 -- work was already done for the previous call.
12950 Self
: constant Visited_Element
:=
12951 (Subp_Id
=> Ent
, Context
=> Parent
(N
));
12954 for Index
in 1 .. Elab_Visited
.Last
loop
12955 if Self
= Elab_Visited
.Table
(Index
) then
12961 -- See if we need to analyze this reference. We analyze it if either of
12962 -- the following conditions is met:
12964 -- It is an inner level call (since in this case it was triggered
12965 -- by an outer level call from elaboration code), but only if the
12966 -- call is within the scope of the original outer level call.
12968 -- It is an outer level reference from elaboration code, or a call to
12969 -- an entity is in the same elaboration scope.
12971 -- And in these cases, we will check both inter-unit calls and
12972 -- intra-unit (within a single unit) calls.
12974 C_Scope
:= Current_Scope
;
12976 -- If not outer level reference, then we follow it if it is within the
12977 -- original scope of the outer reference.
12979 if Present
(Outer_Scope
)
12980 and then Within
(Scope
(Ent
), Outer_Scope
)
12986 Outer_Scope
=> Outer_Scope
,
12987 Inter_Unit_Only
=> False,
12988 In_Init_Proc
=> In_Init_Proc
);
12990 -- Nothing to do if elaboration checks suppressed for this scope.
12991 -- However, an interesting exception, the fact that elaboration checks
12992 -- are suppressed within an instance (because we can trace the body when
12993 -- we process the template) does not extend to calls to generic formal
12996 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
12997 and then not Is_Call_Of_Generic_Formal
(N
)
13001 elsif From_Elab_Code
then
13003 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
13005 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
13007 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
13009 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
13010 -- is set, then we will do the check, but only in the inter-unit case
13011 -- (this is to accommodate unguarded elaboration calls from other units
13012 -- in which this same mode is set). We don't want warnings in this case,
13013 -- it would generate warnings having nothing to do with elaboration.
13015 elsif Dynamic_Elaboration_Checks
then
13021 Inter_Unit_Only
=> True,
13022 Generate_Warnings
=> False);
13024 -- Otherwise nothing to do
13030 -- A call to an Init_Proc in elaboration code may bring additional
13031 -- dependencies, if some of the record components thereof have
13032 -- initializations that are function calls that come from source. We
13033 -- treat the current node as a call to each of these functions, to check
13034 -- their elaboration impact.
13036 if Is_Init_Proc
(Ent
) and then From_Elab_Code
then
13037 Process_Init_Proc
: declare
13038 Unit_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
13040 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
;
13041 -- Find subprogram calls within body of Init_Proc for Traverse
13042 -- instantiation below.
13044 procedure Traverse_Body
is new Traverse_Proc
(Check_Init_Call
);
13045 -- Traversal procedure to find all calls with body of Init_Proc
13047 ---------------------
13048 -- Check_Init_Call --
13049 ---------------------
13051 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
is
13055 if Nkind
(Nod
) in N_Subprogram_Call
13056 and then Is_Entity_Name
(Name
(Nod
))
13058 Func
:= Entity
(Name
(Nod
));
13060 if Comes_From_Source
(Func
) then
13062 (N
, Func
, Standard_Standard
, Inter_Unit_Only
=> True);
13070 end Check_Init_Call
;
13072 -- Start of processing for Process_Init_Proc
13075 if Nkind
(Unit_Decl
) = N_Subprogram_Body
then
13076 Traverse_Body
(Handled_Statement_Sequence
(Unit_Decl
));
13078 end Process_Init_Proc
;
13080 end Check_Elab_Call
;
13082 -----------------------
13083 -- Check_Elab_Assign --
13084 -----------------------
13086 procedure Check_Elab_Assign
(N
: Node_Id
) is
13090 Pkg_Spec
: Entity_Id
;
13091 Pkg_Body
: Entity_Id
;
13094 pragma Assert
(Legacy_Elaboration_Checks
);
13096 -- For record or array component, check prefix. If it is an access type,
13097 -- then there is nothing to do (we do not know what is being assigned),
13098 -- but otherwise this is an assignment to the prefix.
13100 if Nkind_In
(N
, N_Indexed_Component
,
13101 N_Selected_Component
,
13104 if not Is_Access_Type
(Etype
(Prefix
(N
))) then
13105 Check_Elab_Assign
(Prefix
(N
));
13111 -- For type conversion, check expression
13113 if Nkind
(N
) = N_Type_Conversion
then
13114 Check_Elab_Assign
(Expression
(N
));
13118 -- Nothing to do if this is not an entity reference otherwise get entity
13120 if Is_Entity_Name
(N
) then
13126 -- What we are looking for is a reference in the body of a package that
13127 -- modifies a variable declared in the visible part of the package spec.
13130 and then Comes_From_Source
(N
)
13131 and then not Suppress_Elaboration_Warnings
(Ent
)
13132 and then Ekind
(Ent
) = E_Variable
13133 and then not In_Private_Part
(Ent
)
13134 and then Is_Library_Level_Entity
(Ent
)
13136 Scop
:= Current_Scope
;
13138 if No
(Scop
) or else Scop
= Standard_Standard
then
13140 elsif Ekind
(Scop
) = E_Package
13141 and then Is_Compilation_Unit
(Scop
)
13145 Scop
:= Scope
(Scop
);
13149 -- Here Scop points to the containing library package
13152 Pkg_Body
:= Body_Entity
(Pkg_Spec
);
13154 -- All OK if the package has an Elaborate_Body pragma
13156 if Has_Pragma_Elaborate_Body
(Scop
) then
13160 -- OK if entity being modified is not in containing package spec
13162 if not In_Same_Source_Unit
(Scop
, Ent
) then
13166 -- All OK if entity appears in generic package or generic instance.
13167 -- We just get too messed up trying to give proper warnings in the
13168 -- presence of generics. Better no message than a junk one.
13170 Scop
:= Scope
(Ent
);
13171 while Present
(Scop
) and then Scop
/= Pkg_Spec
loop
13172 if Ekind
(Scop
) = E_Generic_Package
then
13174 elsif Ekind
(Scop
) = E_Package
13175 and then Is_Generic_Instance
(Scop
)
13180 Scop
:= Scope
(Scop
);
13183 -- All OK if in task, don't issue warnings there
13185 if In_Task_Activation
then
13189 -- OK if no package body
13191 if No
(Pkg_Body
) then
13195 -- OK if reference is not in package body
13197 if not In_Same_Source_Unit
(Pkg_Body
, N
) then
13201 -- OK if package body has no handled statement sequence
13204 HSS
: constant Node_Id
:=
13205 Handled_Statement_Sequence
(Declaration_Node
(Pkg_Body
));
13207 if No
(HSS
) or else not Comes_From_Source
(HSS
) then
13212 -- We definitely have a case of a modification of an entity in
13213 -- the package spec from the elaboration code of the package body.
13214 -- We may not give the warning (because there are some additional
13215 -- checks to avoid too many false positives), but it would be a good
13216 -- idea for the binder to try to keep the body elaboration close to
13217 -- the spec elaboration.
13219 Set_Elaborate_Body_Desirable
(Pkg_Spec
);
13221 -- All OK in gnat mode (we know what we are doing)
13227 -- All OK if all warnings suppressed
13229 if Warning_Mode
= Suppress
then
13233 -- All OK if elaboration checks suppressed for entity
13235 if Checks_May_Be_Suppressed
(Ent
)
13236 and then Is_Check_Suppressed
(Ent
, Elaboration_Check
)
13241 -- OK if the entity is initialized. Note that the No_Initialization
13242 -- flag usually means that the initialization has been rewritten into
13243 -- assignments, but that still counts for us.
13246 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
13248 if Nkind
(Decl
) = N_Object_Declaration
13249 and then (Present
(Expression
(Decl
))
13250 or else No_Initialization
(Decl
))
13256 -- Here is where we give the warning
13258 -- All OK if warnings suppressed on the entity
13260 if not Has_Warnings_Off
(Ent
) then
13261 Error_Msg_Sloc
:= Sloc
(Ent
);
13264 ("??& can be accessed by clients before this initialization",
13267 ("\??add Elaborate_Body to spec to ensure & is initialized",
13271 if not All_Errors_Mode
then
13272 Set_Suppress_Elaboration_Warnings
(Ent
);
13275 end Check_Elab_Assign
;
13277 ----------------------
13278 -- Check_Elab_Calls --
13279 ----------------------
13281 -- WARNING: This routine manages SPARK regions
13283 procedure Check_Elab_Calls
is
13284 Saved_SM
: SPARK_Mode_Type
;
13285 Saved_SMP
: Node_Id
;
13288 pragma Assert
(Legacy_Elaboration_Checks
);
13290 -- If expansion is disabled, do not generate any checks, unless we
13291 -- are in GNATprove mode, so that errors are issued in GNATprove for
13292 -- violations of static elaboration rules in SPARK code. Also skip
13293 -- checks if any subunits are missing because in either case we lack the
13294 -- full information that we need, and no object file will be created in
13297 if (not Expander_Active
and not GNATprove_Mode
)
13298 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
13299 or else Subunits_Missing
13304 -- Skip delayed calls if we had any errors
13306 if Serious_Errors_Detected
= 0 then
13307 Delaying_Elab_Checks
:= False;
13308 Expander_Mode_Save_And_Set
(True);
13310 for J
in Delay_Check
.First
.. Delay_Check
.Last
loop
13311 Push_Scope
(Delay_Check
.Table
(J
).Curscop
);
13312 From_Elab_Code
:= Delay_Check
.Table
(J
).From_Elab_Code
;
13313 In_Task_Activation
:= Delay_Check
.Table
(J
).In_Task_Activation
;
13315 Saved_SM
:= SPARK_Mode
;
13316 Saved_SMP
:= SPARK_Mode_Pragma
;
13318 -- Set appropriate value of SPARK_Mode
13320 if Delay_Check
.Table
(J
).From_SPARK_Code
then
13324 Check_Internal_Call_Continue
13325 (N
=> Delay_Check
.Table
(J
).N
,
13326 E
=> Delay_Check
.Table
(J
).E
,
13327 Outer_Scope
=> Delay_Check
.Table
(J
).Outer_Scope
,
13328 Orig_Ent
=> Delay_Check
.Table
(J
).Orig_Ent
);
13330 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
13334 -- Set Delaying_Elab_Checks back on for next main compilation
13336 Expander_Mode_Restore
;
13337 Delaying_Elab_Checks
:= True;
13339 end Check_Elab_Calls
;
13341 ------------------------------
13342 -- Check_Elab_Instantiation --
13343 ------------------------------
13345 procedure Check_Elab_Instantiation
13347 Outer_Scope
: Entity_Id
:= Empty
)
13352 pragma Assert
(Legacy_Elaboration_Checks
);
13354 -- Check for and deal with bad instantiation case. There is some
13355 -- duplicated code here, but we will worry about this later ???
13357 Check_Bad_Instantiation
(N
);
13359 if Is_Known_Guaranteed_ABE
(N
) then
13363 -- Nothing to do if we do not have an instantiation (happens in some
13364 -- error cases, and also in the formal package declaration case)
13366 if Nkind
(N
) not in N_Generic_Instantiation
then
13370 -- Nothing to do if inside a generic template
13372 if Inside_A_Generic
then
13376 -- Nothing to do if the instantiation is not in the main unit
13378 if not In_Extended_Main_Code_Unit
(N
) then
13382 Ent
:= Get_Generic_Entity
(N
);
13383 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
13385 -- See if we need to analyze this instantiation. We analyze it if
13386 -- either of the following conditions is met:
13388 -- It is an inner level instantiation (since in this case it was
13389 -- triggered by an outer level call from elaboration code), but
13390 -- only if the instantiation is within the scope of the original
13391 -- outer level call.
13393 -- It is an outer level instantiation from elaboration code, or the
13394 -- instantiated entity is in the same elaboration scope.
13396 -- And in these cases, we will check both the inter-unit case and
13397 -- the intra-unit (within a single unit) case.
13399 C_Scope
:= Current_Scope
;
13401 if Present
(Outer_Scope
) and then Within
(Scope
(Ent
), Outer_Scope
) then
13403 Check_A_Call
(N
, Ent
, Outer_Scope
, Inter_Unit_Only
=> False);
13405 elsif From_Elab_Code
then
13407 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
13409 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
13411 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
13413 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is
13414 -- set, then we will do the check, but only in the inter-unit case (this
13415 -- is to accommodate unguarded elaboration calls from other units in
13416 -- which this same mode is set). We inhibit warnings in this case, since
13417 -- this instantiation is not occurring in elaboration code.
13419 elsif Dynamic_Elaboration_Checks
then
13425 Inter_Unit_Only
=> True,
13426 Generate_Warnings
=> False);
13431 end Check_Elab_Instantiation
;
13433 -------------------------
13434 -- Check_Internal_Call --
13435 -------------------------
13437 procedure Check_Internal_Call
13440 Outer_Scope
: Entity_Id
;
13441 Orig_Ent
: Entity_Id
)
13443 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean;
13444 -- Determine whether call Call occurs within pragma Initial_Condition or
13445 -- pragma Check with check_kind set to Initial_Condition.
13447 ------------------------------
13448 -- Within_Initial_Condition --
13449 ------------------------------
13451 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean is
13457 -- Traverse the parent chain looking for an enclosing pragma
13460 while Present
(Par
) loop
13461 if Nkind
(Par
) = N_Pragma
then
13462 Nam
:= Pragma_Name
(Par
);
13464 -- Pragma Initial_Condition appears in its alternative from as
13465 -- Check (Initial_Condition, ...).
13467 if Nam
= Name_Check
then
13468 Args
:= Pragma_Argument_Associations
(Par
);
13470 -- Pragma Check should have at least two arguments
13472 pragma Assert
(Present
(Args
));
13475 Chars
(Expression
(First
(Args
))) = Name_Initial_Condition
;
13479 elsif Nam
= Name_Initial_Condition
then
13482 -- Since pragmas are never nested within other pragmas, stop
13489 -- Prevent the search from going too far
13491 elsif Is_Body_Or_Package_Declaration
(Par
) then
13495 Par
:= Parent
(Par
);
13497 -- If assertions are not enabled, the check pragma is rewritten
13498 -- as an if_statement in sem_prag, to generate various warnings
13499 -- on boolean expressions. Retrieve the original pragma.
13501 if Nkind
(Original_Node
(Par
)) = N_Pragma
then
13502 Par
:= Original_Node
(Par
);
13507 end Within_Initial_Condition
;
13511 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
13513 -- Start of processing for Check_Internal_Call
13516 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the
13517 -- node comes from source.
13519 if Nkind
(N
) = N_Attribute_Reference
13520 and then ((not Warn_On_Elab_Access
and then not Debug_Flag_Dot_O
)
13521 or else not Comes_From_Source
(N
))
13525 -- If not function or procedure call, instantiation, or 'Access, then
13526 -- ignore call (this happens in some error cases and rewriting cases).
13528 elsif not Nkind_In
(N
, N_Attribute_Reference
,
13530 N_Procedure_Call_Statement
)
13531 and then not Inst_Case
13535 -- Nothing to do if this is a call or instantiation that has already
13536 -- been found to be a sure ABE.
13538 elsif Nkind
(N
) /= N_Attribute_Reference
13539 and then Is_Known_Guaranteed_ABE
(N
)
13543 -- Nothing to do if errors already detected (avoid cascaded errors)
13545 elsif Serious_Errors_Detected
/= 0 then
13548 -- Nothing to do if not in full analysis mode
13550 elsif not Full_Analysis
then
13553 -- Nothing to do if analyzing in special spec-expression mode, since the
13554 -- call is not actually being made at this time.
13556 elsif In_Spec_Expression
then
13559 -- Nothing to do for call to intrinsic subprogram
13561 elsif Is_Intrinsic_Subprogram
(E
) then
13564 -- Nothing to do if call is within a generic unit
13566 elsif Inside_A_Generic
then
13569 -- Nothing to do when the call appears within pragma Initial_Condition.
13570 -- The pragma is part of the elaboration statements of a package body
13571 -- and may only call external subprograms or subprograms whose body is
13572 -- already available.
13574 elsif Within_Initial_Condition
(N
) then
13578 -- Delay this call if we are still delaying calls
13580 if Delaying_Elab_Checks
then
13584 Orig_Ent
=> Orig_Ent
,
13585 Curscop
=> Current_Scope
,
13586 Outer_Scope
=> Outer_Scope
,
13587 From_Elab_Code
=> From_Elab_Code
,
13588 In_Task_Activation
=> In_Task_Activation
,
13589 From_SPARK_Code
=> SPARK_Mode
= On
));
13592 -- Otherwise, call phase 2 continuation right now
13595 Check_Internal_Call_Continue
(N
, E
, Outer_Scope
, Orig_Ent
);
13597 end Check_Internal_Call
;
13599 ----------------------------------
13600 -- Check_Internal_Call_Continue --
13601 ----------------------------------
13603 procedure Check_Internal_Call_Continue
13606 Outer_Scope
: Entity_Id
;
13607 Orig_Ent
: Entity_Id
)
13609 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
;
13610 -- Function applied to each node as we traverse the body. Checks for
13611 -- call or entity reference that needs checking, and if so checks it.
13612 -- Always returns OK, so entire tree is traversed, except that as
13613 -- described below subprogram bodies are skipped for now.
13615 procedure Traverse
is new Atree
.Traverse_Proc
(Find_Elab_Reference
);
13616 -- Traverse procedure using above Find_Elab_Reference function
13618 -------------------------
13619 -- Find_Elab_Reference --
13620 -------------------------
13622 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
is
13626 -- If user has specified that there are no entry calls in elaboration
13627 -- code, do not trace past an accept statement, because the rendez-
13628 -- vous will happen after elaboration.
13630 if Nkind_In
(Original_Node
(N
), N_Accept_Statement
,
13631 N_Selective_Accept
)
13632 and then Restriction_Active
(No_Entry_Calls_In_Elaboration_Code
)
13636 -- If we have a function call, check it
13638 elsif Nkind
(N
) = N_Function_Call
then
13639 Check_Elab_Call
(N
, Outer_Scope
);
13642 -- If we have a procedure call, check the call, and also check
13643 -- arguments that are assignments (OUT or IN OUT mode formals).
13645 elsif Nkind
(N
) = N_Procedure_Call_Statement
then
13646 Check_Elab_Call
(N
, Outer_Scope
, In_Init_Proc
=> Is_Init_Proc
(E
));
13648 Actual
:= First_Actual
(N
);
13649 while Present
(Actual
) loop
13650 if Known_To_Be_Assigned
(Actual
) then
13651 Check_Elab_Assign
(Actual
);
13654 Next_Actual
(Actual
);
13659 -- If we have an access attribute for a subprogram, check it.
13660 -- Suppress this behavior under debug flag.
13662 elsif not Debug_Flag_Dot_UU
13663 and then Nkind
(N
) = N_Attribute_Reference
13664 and then Nam_In
(Attribute_Name
(N
), Name_Access
,
13665 Name_Unrestricted_Access
)
13666 and then Is_Entity_Name
(Prefix
(N
))
13667 and then Is_Subprogram
(Entity
(Prefix
(N
)))
13669 Check_Elab_Call
(N
, Outer_Scope
);
13672 -- In SPARK mode, if we have an entity reference to a variable, then
13673 -- check it. For now we consider any reference.
13675 elsif SPARK_Mode
= On
13676 and then Nkind
(N
) in N_Has_Entity
13677 and then Present
(Entity
(N
))
13678 and then Ekind
(Entity
(N
)) = E_Variable
13680 Check_Elab_Call
(N
, Outer_Scope
);
13683 -- If we have a generic instantiation, check it
13685 elsif Nkind
(N
) in N_Generic_Instantiation
then
13686 Check_Elab_Instantiation
(N
, Outer_Scope
);
13689 -- Skip subprogram bodies that come from source (wait for call to
13690 -- analyze these). The reason for the come from source test is to
13691 -- avoid catching task bodies.
13693 -- For task bodies, we should really avoid these too, waiting for the
13694 -- task activation, but that's too much trouble to catch for now, so
13695 -- we go in unconditionally. This is not so terrible, it means the
13696 -- error backtrace is not quite complete, and we are too eager to
13697 -- scan bodies of tasks that are unused, but this is hardly very
13700 elsif Nkind
(N
) = N_Subprogram_Body
13701 and then Comes_From_Source
(N
)
13705 elsif Nkind
(N
) = N_Assignment_Statement
13706 and then Comes_From_Source
(N
)
13708 Check_Elab_Assign
(Name
(N
));
13714 end Find_Elab_Reference
;
13716 Inst_Case
: constant Boolean := Is_Generic_Unit
(E
);
13717 Loc
: constant Source_Ptr
:= Sloc
(N
);
13722 -- Start of processing for Check_Internal_Call_Continue
13725 -- Save outer level call if at outer level
13727 if Elab_Call
.Last
= 0 then
13728 Outer_Level_Sloc
:= Loc
;
13731 -- If the call is to a function that renames a literal, no check needed
13733 if Ekind
(E
) = E_Enumeration_Literal
then
13737 -- Register the subprogram as examined within this particular context.
13738 -- This ensures that calls to the same subprogram but in different
13739 -- contexts receive warnings and checks of their own since the calls
13740 -- may be reached through different flow paths.
13742 Elab_Visited
.Append
((Subp_Id
=> E
, Context
=> Parent
(N
)));
13744 Sbody
:= Unit_Declaration_Node
(E
);
13746 if not Nkind_In
(Sbody
, N_Subprogram_Body
, N_Package_Body
) then
13747 Ebody
:= Corresponding_Body
(Sbody
);
13752 Sbody
:= Unit_Declaration_Node
(Ebody
);
13756 -- If the body appears after the outer level call or instantiation then
13757 -- we have an error case handled below.
13759 if Earlier_In_Extended_Unit
(Outer_Level_Sloc
, Sloc
(Sbody
))
13760 and then not In_Task_Activation
13764 -- If we have the instantiation case we are done, since we now know that
13765 -- the body of the generic appeared earlier.
13767 elsif Inst_Case
then
13770 -- Otherwise we have a call, so we trace through the called body to see
13771 -- if it has any problems.
13774 pragma Assert
(Nkind
(Sbody
) = N_Subprogram_Body
);
13776 Elab_Call
.Append
((Cloc
=> Loc
, Ent
=> E
));
13778 if Debug_Flag_Underscore_LL
then
13779 Write_Str
("Elab_Call.Last = ");
13780 Write_Int
(Int
(Elab_Call
.Last
));
13781 Write_Str
(" Ent = ");
13782 Write_Name
(Chars
(E
));
13783 Write_Str
(" at ");
13784 Write_Location
(Sloc
(N
));
13788 -- Now traverse declarations and statements of subprogram body. Note
13789 -- that we cannot simply Traverse (Sbody), since traverse does not
13790 -- normally visit subprogram bodies.
13795 Decl
:= First
(Declarations
(Sbody
));
13796 while Present
(Decl
) loop
13802 Traverse
(Handled_Statement_Sequence
(Sbody
));
13804 Elab_Call
.Decrement_Last
;
13808 -- Here is the case of calling a subprogram where the body has not yet
13809 -- been encountered. A warning message is needed, except if this is the
13810 -- case of appearing within an aspect specification that results in
13811 -- a check call, we do not really have such a situation, so no warning
13812 -- is needed (e.g. the case of a precondition, where the call appears
13813 -- textually before the body, but in actual fact is moved to the
13814 -- appropriate subprogram body and so does not need a check).
13823 -- Keep looking at parents if we are still in the subexpression
13825 if Nkind
(P
) in N_Subexpr
then
13828 -- Here P is the parent of the expression, check for special case
13831 O
:= Original_Node
(P
);
13833 -- Definitely not the special case if orig node is not a pragma
13835 exit when Nkind
(O
) /= N_Pragma
;
13837 -- Check we have an If statement or a null statement (happens
13838 -- when the If has been expanded to be True).
13840 exit when not Nkind_In
(P
, N_If_Statement
, N_Null_Statement
);
13842 -- Our special case will be indicated either by the pragma
13843 -- coming from an aspect ...
13845 if Present
(Corresponding_Aspect
(O
)) then
13848 -- Or, in the case of an initial condition, specifically by a
13849 -- Check pragma specifying an Initial_Condition check.
13851 elsif Pragma_Name
(O
) = Name_Check
13854 (Expression
(First
(Pragma_Argument_Associations
(O
)))) =
13855 Name_Initial_Condition
13859 -- For anything else, we have an error
13868 -- Not that special case, warning and dynamic check is required
13870 -- If we have nothing in the call stack, then this is at the outer
13871 -- level, and the ABE is bound to occur, unless it's a 'Access, or
13872 -- it's a renaming.
13874 if Elab_Call
.Last
= 0 then
13875 Error_Msg_Warn
:= SPARK_Mode
/= On
;
13878 Insert_Check
: Boolean := True;
13879 -- This flag is set to True if an elaboration check should be
13883 if In_Task_Activation
then
13884 Insert_Check
:= False;
13886 elsif Inst_Case
then
13888 ("cannot instantiate& before body seen<<", N
, Orig_Ent
);
13890 elsif Nkind
(N
) = N_Attribute_Reference
then
13892 ("Access attribute of & before body seen<<", N
, Orig_Ent
);
13893 Error_Msg_N
("\possible Program_Error on later references<", N
);
13894 Insert_Check
:= False;
13896 elsif Nkind
(Unit_Declaration_Node
(Orig_Ent
)) /=
13897 N_Subprogram_Renaming_Declaration
13900 ("cannot call& before body seen<<", N
, Orig_Ent
);
13902 elsif not Is_Generic_Actual_Subprogram
(Orig_Ent
) then
13903 Insert_Check
:= False;
13906 if Insert_Check
then
13907 Error_Msg_N
("\Program_Error [<<", N
);
13908 Insert_Elab_Check
(N
);
13912 -- Call is not at outer level
13915 -- Do not generate elaboration checks in GNATprove mode because the
13916 -- elaboration counter and the check are both forms of expansion.
13918 if GNATprove_Mode
then
13921 -- Generate an elaboration check
13923 elsif not Elaboration_Checks_Suppressed
(E
) then
13924 Set_Elaboration_Entity_Required
(E
);
13926 -- Create a declaration of the elaboration entity, and insert it
13927 -- prior to the subprogram or the generic unit, within the same
13928 -- scope. Since the subprogram may be overloaded, create a unique
13931 if No
(Elaboration_Entity
(E
)) then
13933 Loce
: constant Source_Ptr
:= Sloc
(E
);
13934 Ent
: constant Entity_Id
:=
13935 Make_Defining_Identifier
(Loc
,
13936 New_External_Name
(Chars
(E
), 'E', -1));
13939 Set_Elaboration_Entity
(E
, Ent
);
13940 Push_Scope
(Scope
(E
));
13942 Insert_Action
(Declaration_Node
(E
),
13943 Make_Object_Declaration
(Loce
,
13944 Defining_Identifier
=> Ent
,
13945 Object_Definition
=>
13946 New_Occurrence_Of
(Standard_Short_Integer
, Loce
),
13948 Make_Integer_Literal
(Loc
, Uint_0
)));
13950 -- Set elaboration flag at the point of the body
13952 Set_Elaboration_Flag
(Sbody
, E
);
13954 -- Kill current value indication. This is necessary because
13955 -- the tests of this flag are inserted out of sequence and
13956 -- must not pick up bogus indications of the wrong constant
13957 -- value. Also, this is never a true constant, since one way
13958 -- or another, it gets reset.
13960 Set_Current_Value
(Ent
, Empty
);
13961 Set_Last_Assignment
(Ent
, Empty
);
13962 Set_Is_True_Constant
(Ent
, False);
13969 -- raise Program_Error with "access before elaboration";
13972 Insert_Elab_Check
(N
,
13973 Make_Attribute_Reference
(Loc
,
13974 Attribute_Name
=> Name_Elaborated
,
13975 Prefix
=> New_Occurrence_Of
(E
, Loc
)));
13978 -- Generate the warning
13980 if not Suppress_Elaboration_Warnings
(E
)
13981 and then not Elaboration_Checks_Suppressed
(E
)
13983 -- Suppress this warning if we have a function call that occurred
13984 -- within an assertion expression, since we can get false warnings
13985 -- in this case, due to the out of order handling in this case.
13988 (Nkind
(Original_Node
(N
)) /= N_Function_Call
13989 or else not In_Assertion_Expression_Pragma
(Original_Node
(N
)))
13991 Error_Msg_Warn
:= SPARK_Mode
/= On
;
13995 ("instantiation of& may occur before body is seen<l<",
13998 -- A rather specific check. For Finalize/Adjust/Initialize, if
13999 -- the type has Warnings_Off set, suppress the warning.
14001 if Nam_In
(Chars
(E
), Name_Adjust
,
14004 and then Present
(First_Formal
(E
))
14007 T
: constant Entity_Id
:= Etype
(First_Formal
(E
));
14009 if Is_Controlled
(T
) then
14010 if Warnings_Off
(T
)
14011 or else (Ekind
(T
) = E_Private_Type
14012 and then Warnings_Off
(Full_View
(T
)))
14020 -- Go ahead and give warning if not this special case
14023 ("call to& may occur before body is seen<l<", N
, Orig_Ent
);
14026 Error_Msg_N
("\Program_Error ]<l<", N
);
14028 -- There is no need to query the elaboration warning message flags
14029 -- because the main message is an error, not a warning, therefore
14030 -- all the clarification messages produces by Output_Calls must be
14031 -- emitted unconditionally.
14035 Output_Calls
(N
, Check_Elab_Flag
=> False);
14038 end Check_Internal_Call_Continue
;
14040 ---------------------------
14041 -- Check_Task_Activation --
14042 ---------------------------
14044 procedure Check_Task_Activation
(N
: Node_Id
) is
14045 Loc
: constant Source_Ptr
:= Sloc
(N
);
14046 Inter_Procs
: constant Elist_Id
:= New_Elmt_List
;
14047 Intra_Procs
: constant Elist_Id
:= New_Elmt_List
;
14050 Task_Scope
: Entity_Id
;
14051 Cunit_SC
: Boolean := False;
14054 Enclosing
: Entity_Id
;
14056 procedure Add_Task_Proc
(Typ
: Entity_Id
);
14057 -- Add to Task_Procs the task body procedure(s) of task types in Typ.
14058 -- For record types, this procedure recurses over component types.
14060 procedure Collect_Tasks
(Decls
: List_Id
);
14061 -- Collect the types of the tasks that are to be activated in the given
14062 -- list of declarations, in order to perform elaboration checks on the
14063 -- corresponding task procedures that are called implicitly here.
14065 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
;
14066 -- find enclosing compilation unit of Entity, ignoring subunits, or
14067 -- else enclosing subprogram. If E is not a package, there is no need
14068 -- for inter-unit elaboration checks.
14070 -------------------
14071 -- Add_Task_Proc --
14072 -------------------
14074 procedure Add_Task_Proc
(Typ
: Entity_Id
) is
14076 Proc
: Entity_Id
:= Empty
;
14079 if Is_Task_Type
(Typ
) then
14080 Proc
:= Get_Task_Body_Procedure
(Typ
);
14082 elsif Is_Array_Type
(Typ
)
14083 and then Has_Task
(Base_Type
(Typ
))
14085 Add_Task_Proc
(Component_Type
(Typ
));
14087 elsif Is_Record_Type
(Typ
)
14088 and then Has_Task
(Base_Type
(Typ
))
14090 Comp
:= First_Component
(Typ
);
14091 while Present
(Comp
) loop
14092 Add_Task_Proc
(Etype
(Comp
));
14093 Comp
:= Next_Component
(Comp
);
14097 -- If the task type is another unit, we will perform the usual
14098 -- elaboration check on its enclosing unit. If the type is in the
14099 -- same unit, we can trace the task body as for an internal call,
14100 -- but we only need to examine other external calls, because at
14101 -- the point the task is activated, internal subprogram bodies
14102 -- will have been elaborated already. We keep separate lists for
14103 -- each kind of task.
14105 -- Skip this test if errors have occurred, since in this case
14106 -- we can get false indications.
14108 if Serious_Errors_Detected
/= 0 then
14112 if Present
(Proc
) then
14113 if Outer_Unit
(Scope
(Proc
)) = Enclosing
then
14115 if No
(Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
14117 (not Is_Generic_Instance
(Scope
(Proc
))
14118 or else Scope
(Proc
) = Scope
(Defining_Identifier
(Decl
)))
14120 Error_Msg_Warn
:= SPARK_Mode
/= On
;
14122 ("task will be activated before elaboration of its body<<",
14124 Error_Msg_N
("\Program_Error [<<", Decl
);
14127 (Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
14129 Append_Elmt
(Proc
, Intra_Procs
);
14133 -- No need for multiple entries of the same type
14135 Elmt
:= First_Elmt
(Inter_Procs
);
14136 while Present
(Elmt
) loop
14137 if Node
(Elmt
) = Proc
then
14144 Append_Elmt
(Proc
, Inter_Procs
);
14149 -------------------
14150 -- Collect_Tasks --
14151 -------------------
14153 procedure Collect_Tasks
(Decls
: List_Id
) is
14155 if Present
(Decls
) then
14156 Decl
:= First
(Decls
);
14157 while Present
(Decl
) loop
14158 if Nkind
(Decl
) = N_Object_Declaration
14159 and then Has_Task
(Etype
(Defining_Identifier
(Decl
)))
14161 Add_Task_Proc
(Etype
(Defining_Identifier
(Decl
)));
14173 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
is
14178 while Present
(Outer
) loop
14179 if Elaboration_Checks_Suppressed
(Outer
) then
14183 exit when Is_Child_Unit
(Outer
)
14184 or else Scope
(Outer
) = Standard_Standard
14185 or else Ekind
(Outer
) /= E_Package
;
14186 Outer
:= Scope
(Outer
);
14192 -- Start of processing for Check_Task_Activation
14195 pragma Assert
(Legacy_Elaboration_Checks
);
14197 Enclosing
:= Outer_Unit
(Current_Scope
);
14199 -- Find all tasks declared in the current unit
14201 if Nkind
(N
) = N_Package_Body
then
14202 P
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
14204 Collect_Tasks
(Declarations
(N
));
14205 Collect_Tasks
(Visible_Declarations
(Specification
(P
)));
14206 Collect_Tasks
(Private_Declarations
(Specification
(P
)));
14208 elsif Nkind
(N
) = N_Package_Declaration
then
14209 Collect_Tasks
(Visible_Declarations
(Specification
(N
)));
14210 Collect_Tasks
(Private_Declarations
(Specification
(N
)));
14213 Collect_Tasks
(Declarations
(N
));
14216 -- We only perform detailed checks in all tasks that are library level
14217 -- entities. If the master is a subprogram or task, activation will
14218 -- depend on the activation of the master itself.
14220 -- Should dynamic checks be added in the more general case???
14222 if Ekind
(Enclosing
) /= E_Package
then
14226 -- For task types defined in other units, we want the unit containing
14227 -- the task body to be elaborated before the current one.
14229 Elmt
:= First_Elmt
(Inter_Procs
);
14230 while Present
(Elmt
) loop
14231 Ent
:= Node
(Elmt
);
14232 Task_Scope
:= Outer_Unit
(Scope
(Ent
));
14234 if not Is_Compilation_Unit
(Task_Scope
) then
14237 elsif Suppress_Elaboration_Warnings
(Task_Scope
)
14238 or else Elaboration_Checks_Suppressed
(Task_Scope
)
14242 elsif Dynamic_Elaboration_Checks
then
14243 if not Elaboration_Checks_Suppressed
(Ent
)
14244 and then not Cunit_SC
14245 and then not Restriction_Active
14246 (No_Entry_Calls_In_Elaboration_Code
)
14248 -- Runtime elaboration check required. Generate check of the
14249 -- elaboration counter for the unit containing the entity.
14251 Insert_Elab_Check
(N
,
14252 Make_Attribute_Reference
(Loc
,
14254 New_Occurrence_Of
(Spec_Entity
(Task_Scope
), Loc
),
14255 Attribute_Name
=> Name_Elaborated
));
14259 -- Force the binder to elaborate other unit first
14261 if Elab_Info_Messages
14262 and then not Suppress_Elaboration_Warnings
(Ent
)
14263 and then not Elaboration_Checks_Suppressed
(Ent
)
14264 and then not Suppress_Elaboration_Warnings
(Task_Scope
)
14265 and then not Elaboration_Checks_Suppressed
(Task_Scope
)
14267 Error_Msg_Node_2
:= Task_Scope
;
14269 ("info: activation of an instance of task type & requires "
14270 & "pragma Elaborate_All on &?$?", N
, Ent
);
14273 Activate_Elaborate_All_Desirable
(N
, Task_Scope
);
14274 Set_Suppress_Elaboration_Warnings
(Task_Scope
);
14280 -- For tasks declared in the current unit, trace other calls within the
14281 -- task procedure bodies, which are available.
14283 if not Debug_Flag_Dot_Y
then
14284 In_Task_Activation
:= True;
14286 Elmt
:= First_Elmt
(Intra_Procs
);
14287 while Present
(Elmt
) loop
14288 Ent
:= Node
(Elmt
);
14289 Check_Internal_Call_Continue
(N
, Ent
, Enclosing
, Ent
);
14293 In_Task_Activation
:= False;
14295 end Check_Task_Activation
;
14297 ------------------------
14298 -- Get_Referenced_Ent --
14299 ------------------------
14301 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
is
14305 if Nkind
(N
) in N_Has_Entity
14306 and then Present
(Entity
(N
))
14307 and then Ekind
(Entity
(N
)) = E_Variable
14312 if Nkind
(N
) = N_Attribute_Reference
then
14320 elsif Nkind
(Nam
) = N_Selected_Component
then
14321 return Entity
(Selector_Name
(Nam
));
14322 elsif not Is_Entity_Name
(Nam
) then
14325 return Entity
(Nam
);
14327 end Get_Referenced_Ent
;
14329 ----------------------
14330 -- Has_Generic_Body --
14331 ----------------------
14333 function Has_Generic_Body
(N
: Node_Id
) return Boolean is
14334 Ent
: constant Entity_Id
:= Get_Generic_Entity
(N
);
14335 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
14338 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
;
14339 -- Determine if the list of nodes headed by N and linked by Next
14340 -- contains a package body for the package spec entity E, and if so
14341 -- return the package body. If not, then returns Empty.
14343 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
;
14344 -- This procedure is called load the unit whose name is given by Nam.
14345 -- This unit is being loaded to see whether it contains an optional
14346 -- generic body. The returned value is the loaded unit, which is always
14347 -- a package body (only package bodies can contain other entities in the
14348 -- sense in which Has_Generic_Body is interested). We only attempt to
14349 -- load bodies if we are generating code. If we are in semantics check
14350 -- only mode, then it would be wrong to load bodies that are not
14351 -- required from a semantic point of view, so in this case we return
14352 -- Empty. The result is that the caller may incorrectly decide that a
14353 -- generic spec does not have a body when in fact it does, but the only
14354 -- harm in this is that some warnings on elaboration problems may be
14355 -- lost in semantic checks only mode, which is not big loss. We also
14356 -- return Empty if we go for a body and it is not there.
14358 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
;
14359 -- PE is the entity for a package spec. This function locates the
14360 -- corresponding package body, returning Empty if none is found. The
14361 -- package body returned is fully parsed but may not yet be analyzed,
14362 -- so only syntactic fields should be referenced.
14368 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
is
14373 while Present
(Nod
) loop
14375 -- If we found the package body we are looking for, return it
14377 if Nkind
(Nod
) = N_Package_Body
14378 and then Chars
(Defining_Unit_Name
(Nod
)) = Chars
(E
)
14382 -- If we found the stub for the body, go after the subunit,
14383 -- loading it if necessary.
14385 elsif Nkind
(Nod
) = N_Package_Body_Stub
14386 and then Chars
(Defining_Identifier
(Nod
)) = Chars
(E
)
14388 if Present
(Library_Unit
(Nod
)) then
14389 return Unit
(Library_Unit
(Nod
));
14392 return Load_Package_Body
(Get_Unit_Name
(Nod
));
14395 -- If neither package body nor stub, keep looking on chain
14405 -----------------------
14406 -- Load_Package_Body --
14407 -----------------------
14409 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
is
14410 U
: Unit_Number_Type
;
14413 if Operating_Mode
/= Generate_Code
then
14423 if U
= No_Unit
then
14426 return Unit
(Cunit
(U
));
14429 end Load_Package_Body
;
14431 -------------------------------
14432 -- Locate_Corresponding_Body --
14433 -------------------------------
14435 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
is
14436 Spec
: constant Node_Id
:= Declaration_Node
(PE
);
14437 Decl
: constant Node_Id
:= Parent
(Spec
);
14438 Scop
: constant Entity_Id
:= Scope
(PE
);
14442 if Is_Library_Level_Entity
(PE
) then
14444 -- If package is a library unit that requires a body, we have no
14445 -- choice but to go after that body because it might contain an
14446 -- optional body for the original generic package.
14448 if Unit_Requires_Body
(PE
) then
14450 -- Load the body. Note that we are a little careful here to use
14451 -- Spec to get the unit number, rather than PE or Decl, since
14452 -- in the case where the package is itself a library level
14453 -- instantiation, Spec will properly reference the generic
14454 -- template, which is what we really want.
14458 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec
))));
14460 -- But if the package is a library unit that does NOT require
14461 -- a body, then no body is permitted, so we are sure that there
14462 -- is no body for the original generic package.
14468 -- Otherwise look and see if we are embedded in a further package
14470 elsif Is_Package_Or_Generic_Package
(Scop
) then
14472 -- If so, get the body of the enclosing package, and look in
14473 -- its package body for the package body we are looking for.
14475 PBody
:= Locate_Corresponding_Body
(Scop
);
14480 return Find_Body_In
(PE
, First
(Declarations
(PBody
)));
14483 -- If we are not embedded in a further package, then the body
14484 -- must be in the same declarative part as we are.
14487 return Find_Body_In
(PE
, Next
(Decl
));
14489 end Locate_Corresponding_Body
;
14491 -- Start of processing for Has_Generic_Body
14494 if Present
(Corresponding_Body
(Decl
)) then
14497 elsif Unit_Requires_Body
(Ent
) then
14500 -- Compilation units cannot have optional bodies
14502 elsif Is_Compilation_Unit
(Ent
) then
14505 -- Otherwise look at what scope we are in
14508 Scop
:= Scope
(Ent
);
14510 -- Case of entity is in other than a package spec, in this case
14511 -- the body, if present, must be in the same declarative part.
14513 if not Is_Package_Or_Generic_Package
(Scop
) then
14518 -- Declaration node may get us a spec, so if so, go to
14519 -- the parent declaration.
14521 P
:= Declaration_Node
(Ent
);
14522 while not Is_List_Member
(P
) loop
14526 return Present
(Find_Body_In
(Ent
, Next
(P
)));
14529 -- If the entity is in a package spec, then we have to locate
14530 -- the corresponding package body, and look there.
14534 PBody
: constant Node_Id
:= Locate_Corresponding_Body
(Scop
);
14542 (Find_Body_In
(Ent
, (First
(Declarations
(PBody
)))));
14547 end Has_Generic_Body
;
14549 -----------------------
14550 -- Insert_Elab_Check --
14551 -----------------------
14553 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
) is
14555 Loc
: constant Source_Ptr
:= Sloc
(N
);
14558 -- The check (N_Raise_Program_Error) node to be inserted
14561 -- If expansion is disabled, do not generate any checks. Also
14562 -- skip checks if any subunits are missing because in either
14563 -- case we lack the full information that we need, and no object
14564 -- file will be created in any case.
14566 if not Expander_Active
or else Subunits_Missing
then
14570 -- If we have a generic instantiation, where Instance_Spec is set,
14571 -- then this field points to a generic instance spec that has
14572 -- been inserted before the instantiation node itself, so that
14573 -- is where we want to insert a check.
14575 if Nkind
(N
) in N_Generic_Instantiation
14576 and then Present
(Instance_Spec
(N
))
14578 Nod
:= Instance_Spec
(N
);
14583 -- Build check node, possibly with condition
14586 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Access_Before_Elaboration
);
14588 if Present
(C
) then
14589 Set_Condition
(Chk
, Make_Op_Not
(Loc
, Right_Opnd
=> C
));
14592 -- If we are inserting at the top level, insert in Aux_Decls
14594 if Nkind
(Parent
(Nod
)) = N_Compilation_Unit
then
14596 ADN
: constant Node_Id
:= Aux_Decls_Node
(Parent
(Nod
));
14599 if No
(Declarations
(ADN
)) then
14600 Set_Declarations
(ADN
, New_List
(Chk
));
14602 Append_To
(Declarations
(ADN
), Chk
);
14608 -- Otherwise just insert as an action on the node in question
14611 Insert_Action
(Nod
, Chk
);
14613 end Insert_Elab_Check
;
14615 -------------------------------
14616 -- Is_Call_Of_Generic_Formal --
14617 -------------------------------
14619 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean is
14621 return Nkind_In
(N
, N_Function_Call
, N_Procedure_Call_Statement
)
14623 -- Always return False if debug flag -gnatd.G is set
14625 and then not Debug_Flag_Dot_GG
14627 -- For now, we detect this by looking for the strange identifier
14628 -- node, whose Chars reflect the name of the generic formal, but
14629 -- the Chars of the Entity references the generic actual.
14631 and then Nkind
(Name
(N
)) = N_Identifier
14632 and then Chars
(Name
(N
)) /= Chars
(Entity
(Name
(N
)));
14633 end Is_Call_Of_Generic_Formal
;
14635 -------------------------------
14636 -- Is_Finalization_Procedure --
14637 -------------------------------
14639 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean is
14641 -- Check whether Id is a procedure with at least one parameter
14643 if Ekind
(Id
) = E_Procedure
and then Present
(First_Formal
(Id
)) then
14645 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Id
));
14646 Deep_Fin
: Entity_Id
:= Empty
;
14647 Fin
: Entity_Id
:= Empty
;
14650 -- If the type of the first formal does not require finalization
14651 -- actions, then this is definitely not [Deep_]Finalize.
14653 if not Needs_Finalization
(Typ
) then
14657 -- At this point we have the following scenario:
14659 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
14661 -- Recover the two possible versions of [Deep_]Finalize using the
14662 -- type of the first parameter and compare with the input.
14664 Deep_Fin
:= TSS
(Typ
, TSS_Deep_Finalize
);
14666 if Is_Controlled
(Typ
) then
14667 Fin
:= Find_Prim_Op
(Typ
, Name_Finalize
);
14670 return (Present
(Deep_Fin
) and then Id
= Deep_Fin
)
14671 or else (Present
(Fin
) and then Id
= Fin
);
14676 end Is_Finalization_Procedure
;
14682 procedure Output_Calls
14684 Check_Elab_Flag
: Boolean)
14686 function Emit
(Flag
: Boolean) return Boolean;
14687 -- Determine whether to emit an error message based on the combination
14688 -- of flags Check_Elab_Flag and Flag.
14690 function Is_Printable_Error_Name
return Boolean;
14691 -- An internal function, used to determine if a name, stored in the
14692 -- Name_Buffer, is either a non-internal name, or is an internal name
14693 -- that is printable by the error message circuits (i.e. it has a single
14694 -- upper case letter at the end).
14700 function Emit
(Flag
: Boolean) return Boolean is
14702 if Check_Elab_Flag
then
14709 -----------------------------
14710 -- Is_Printable_Error_Name --
14711 -----------------------------
14713 function Is_Printable_Error_Name
return Boolean is
14715 if not Is_Internal_Name
then
14718 elsif Name_Len
= 1 then
14722 Name_Len
:= Name_Len
- 1;
14723 return not Is_Internal_Name
;
14725 end Is_Printable_Error_Name
;
14731 -- Start of processing for Output_Calls
14734 for J
in reverse 1 .. Elab_Call
.Last
loop
14735 Error_Msg_Sloc
:= Elab_Call
.Table
(J
).Cloc
;
14737 Ent
:= Elab_Call
.Table
(J
).Ent
;
14738 Get_Name_String
(Chars
(Ent
));
14740 -- Dynamic elaboration model, warnings controlled by -gnatwl
14742 if Dynamic_Elaboration_Checks
then
14743 if Emit
(Elab_Warnings
) then
14744 if Is_Generic_Unit
(Ent
) then
14745 Error_Msg_NE
("\\?l?& instantiated #", N
, Ent
);
14746 elsif Is_Init_Proc
(Ent
) then
14747 Error_Msg_N
("\\?l?initialization procedure called #", N
);
14748 elsif Is_Printable_Error_Name
then
14749 Error_Msg_NE
("\\?l?& called #", N
, Ent
);
14751 Error_Msg_N
("\\?l?called #", N
);
14755 -- Static elaboration model, info messages controlled by -gnatel
14758 if Emit
(Elab_Info_Messages
) then
14759 if Is_Generic_Unit
(Ent
) then
14760 Error_Msg_NE
("\\?$?& instantiated #", N
, Ent
);
14761 elsif Is_Init_Proc
(Ent
) then
14762 Error_Msg_N
("\\?$?initialization procedure called #", N
);
14763 elsif Is_Printable_Error_Name
then
14764 Error_Msg_NE
("\\?$?& called #", N
, Ent
);
14766 Error_Msg_N
("\\?$?called #", N
);
14773 ----------------------------
14774 -- Same_Elaboration_Scope --
14775 ----------------------------
14777 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean is
14782 -- Find elaboration scope for Scop1
14783 -- This is either a subprogram or a compilation unit.
14786 while S1
/= Standard_Standard
14787 and then not Is_Compilation_Unit
(S1
)
14788 and then Ekind_In
(S1
, E_Package
, E_Protected_Type
, E_Block
)
14793 -- Find elaboration scope for Scop2
14796 while S2
/= Standard_Standard
14797 and then not Is_Compilation_Unit
(S2
)
14798 and then Ekind_In
(S2
, E_Package
, E_Protected_Type
, E_Block
)
14804 end Same_Elaboration_Scope
;
14810 procedure Set_C_Scope
is
14812 while not Is_Compilation_Unit
(C_Scope
) loop
14813 C_Scope
:= Scope
(C_Scope
);
14817 --------------------------------
14818 -- Set_Elaboration_Constraint --
14819 --------------------------------
14821 procedure Set_Elaboration_Constraint
14826 Elab_Unit
: Entity_Id
;
14828 -- Check whether this is a call to an Initialize subprogram for a
14829 -- controlled type. Note that Call can also be a 'Access attribute
14830 -- reference, which now generates an elaboration check.
14832 Init_Call
: constant Boolean :=
14833 Nkind
(Call
) = N_Procedure_Call_Statement
14834 and then Chars
(Subp
) = Name_Initialize
14835 and then Comes_From_Source
(Subp
)
14836 and then Present
(Parameter_Associations
(Call
))
14837 and then Is_Controlled
(Etype
(First_Actual
(Call
)));
14840 -- If the unit is mentioned in a with_clause of the current unit, it is
14841 -- visible, and we can set the elaboration flag.
14843 if Is_Immediately_Visible
(Scop
)
14844 or else (Is_Child_Unit
(Scop
) and then Is_Visible_Lib_Unit
(Scop
))
14846 Activate_Elaborate_All_Desirable
(Call
, Scop
);
14847 Set_Suppress_Elaboration_Warnings
(Scop
);
14851 -- If this is not an initialization call or a call using object notation
14852 -- we know that the unit of the called entity is in the context, and we
14853 -- can set the flag as well. The unit need not be visible if the call
14854 -- occurs within an instantiation.
14856 if Is_Init_Proc
(Subp
)
14858 or else Nkind
(Original_Node
(Call
)) = N_Selected_Component
14860 null; -- detailed processing follows.
14863 Activate_Elaborate_All_Desirable
(Call
, Scop
);
14864 Set_Suppress_Elaboration_Warnings
(Scop
);
14868 -- If the unit is not in the context, there must be an intermediate unit
14869 -- that is, on which we need to place to elaboration flag. This happens
14870 -- with init proc calls.
14872 if Is_Init_Proc
(Subp
) or else Init_Call
then
14874 -- The initialization call is on an object whose type is not declared
14875 -- in the same scope as the subprogram. The type of the object must
14876 -- be a subtype of the type of operation. This object is the first
14877 -- actual in the call.
14880 Typ
: constant Entity_Id
:=
14881 Etype
(First
(Parameter_Associations
(Call
)));
14883 Elab_Unit
:= Scope
(Typ
);
14884 while (Present
(Elab_Unit
))
14885 and then not Is_Compilation_Unit
(Elab_Unit
)
14887 Elab_Unit
:= Scope
(Elab_Unit
);
14891 -- If original node uses selected component notation, the prefix is
14892 -- visible and determines the scope that must be elaborated. After
14893 -- rewriting, the prefix is the first actual in the call.
14895 elsif Nkind
(Original_Node
(Call
)) = N_Selected_Component
then
14896 Elab_Unit
:= Scope
(Etype
(First
(Parameter_Associations
(Call
))));
14898 -- Not one of special cases above
14901 -- Using previously computed scope. If the elaboration check is
14902 -- done after analysis, the scope is not visible any longer, but
14903 -- must still be in the context.
14908 Activate_Elaborate_All_Desirable
(Call
, Elab_Unit
);
14909 Set_Suppress_Elaboration_Warnings
(Elab_Unit
);
14910 end Set_Elaboration_Constraint
;
14916 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
is
14920 -- Check for case of body entity
14921 -- Why is the check for E_Void needed???
14923 if Ekind_In
(E
, E_Void
, E_Subprogram_Body
, E_Package_Body
) then
14927 Decl
:= Parent
(Decl
);
14928 exit when Nkind
(Decl
) in N_Proper_Body
;
14931 return Corresponding_Spec
(Decl
);
14942 function Within
(E1
, E2
: Entity_Id
) return Boolean is
14949 elsif Scop
= Standard_Standard
then
14952 Scop
:= Scope
(Scop
);
14957 --------------------------
14958 -- Within_Elaborate_All --
14959 --------------------------
14961 function Within_Elaborate_All
14962 (Unit
: Unit_Number_Type
;
14963 E
: Entity_Id
) return Boolean
14965 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
14966 pragma Pack
(Unit_Number_Set
);
14968 Seen
: Unit_Number_Set
:= (others => False);
14969 -- Seen (X) is True after we have seen unit X in the walk. This is used
14970 -- to prevent processing the same unit more than once.
14972 Result
: Boolean := False;
14974 procedure Helper
(Unit
: Unit_Number_Type
);
14975 -- This helper procedure does all the work for Within_Elaborate_All. It
14976 -- walks the dependency graph, and sets Result to True if it finds an
14977 -- appropriate Elaborate_All.
14983 procedure Helper
(Unit
: Unit_Number_Type
) is
14984 CU
: constant Node_Id
:= Cunit
(Unit
);
14988 Elab_Id
: Entity_Id
;
14992 if Seen
(Unit
) then
14995 Seen
(Unit
) := True;
14998 -- First, check for Elaborate_Alls on this unit
15000 Item
:= First
(Context_Items
(CU
));
15001 while Present
(Item
) loop
15002 if Nkind
(Item
) = N_Pragma
15003 and then Pragma_Name
(Item
) = Name_Elaborate_All
15005 -- Return if some previous error on the pragma itself. The
15006 -- pragma may be unanalyzed, because of a previous error, or
15007 -- if it is the context of a subunit, inherited by its parent.
15009 if Error_Posted
(Item
) or else not Analyzed
(Item
) then
15015 (Expression
(First
(Pragma_Argument_Associations
(Item
))));
15017 if E
= Elab_Id
then
15022 Par
:= Parent
(Unit_Declaration_Node
(Elab_Id
));
15024 Item2
:= First
(Context_Items
(Par
));
15025 while Present
(Item2
) loop
15026 if Nkind
(Item2
) = N_With_Clause
15027 and then Entity
(Name
(Item2
)) = E
15028 and then not Limited_Present
(Item2
)
15041 -- Second, recurse on with's. We could do this as part of the above
15042 -- loop, but it's probably more efficient to have two loops, because
15043 -- the relevant Elaborate_All is likely to be on the initial unit. In
15044 -- other words, we're walking the with's breadth-first. This part is
15045 -- only necessary in the dynamic elaboration model.
15047 if Dynamic_Elaboration_Checks
then
15048 Item
:= First
(Context_Items
(CU
));
15049 while Present
(Item
) loop
15050 if Nkind
(Item
) = N_With_Clause
15051 and then not Limited_Present
(Item
)
15053 -- Note: the following call to Get_Cunit_Unit_Number does a
15054 -- linear search, which could be slow, but it's OK because
15055 -- we're about to give a warning anyway. Also, there might
15056 -- be hundreds of units, but not millions. If it turns out
15057 -- to be a problem, we could store the Get_Cunit_Unit_Number
15058 -- in each N_Compilation_Unit node, but that would involve
15059 -- rearranging N_Compilation_Unit_Aux to make room.
15061 Helper
(Get_Cunit_Unit_Number
(Library_Unit
(Item
)));
15073 -- Start of processing for Within_Elaborate_All
15078 end Within_Elaborate_All
;