1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2024, 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 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Ch11
; use Exp_Ch11
;
36 with Exp_Tss
; use Exp_Tss
;
37 with Exp_Util
; use Exp_Util
;
38 with Expander
; use Expander
;
40 with Lib
.Load
; use Lib
.Load
;
41 with Nlists
; use Nlists
;
42 with Nmake
; use Nmake
;
44 with Output
; use Output
;
45 with Restrict
; use Restrict
;
46 with Rident
; use Rident
;
47 with Rtsfind
; use Rtsfind
;
49 with Sem_Aux
; use Sem_Aux
;
50 with Sem_Cat
; use Sem_Cat
;
51 with Sem_Ch7
; use Sem_Ch7
;
52 with Sem_Ch8
; use Sem_Ch8
;
53 with Sem_Disp
; use Sem_Disp
;
54 with Sem_Prag
; use Sem_Prag
;
55 with Sem_Util
; use Sem_Util
;
56 with Sinfo
; use Sinfo
;
57 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
58 with Sinfo
.Utils
; use Sinfo
.Utils
;
59 with Sinput
; use Sinput
;
60 with Snames
; use Snames
;
61 with Stand
; use Stand
;
63 with Tbuild
; use Tbuild
;
64 with Uintp
; use Uintp
;
65 with Uname
; use Uname
;
66 with Warnsw
; use Warnsw
;
69 with GNAT
.Dynamic_HTables
; use GNAT
.Dynamic_HTables
;
70 with GNAT
.Lists
; use GNAT
.Lists
;
71 with GNAT
.Sets
; use GNAT
.Sets
;
73 package body Sem_Elab
is
75 -----------------------------------------
76 -- Access-before-elaboration mechanism --
77 -----------------------------------------
79 -- The access-before-elaboration (ABE) mechanism implemented in this unit
80 -- has the following objectives:
82 -- * Diagnose at compile time or install run-time checks to prevent ABE
83 -- access to data and behavior.
85 -- The high-level idea is to accurately diagnose ABE issues within a
86 -- single unit because the ABE mechanism can inspect the whole unit.
87 -- As soon as the elaboration graph extends to an external unit, the
88 -- diagnostics stop because the body of the unit may not be available.
89 -- Due to control and data flow, the ABE mechanism cannot accurately
90 -- determine whether a particular scenario will be elaborated or not.
91 -- Conditional ABE checks are therefore used to verify the elaboration
92 -- status of local and external targets at run time.
94 -- * Supply implicit elaboration dependencies for a unit to binde
96 -- The ABE mechanism creates implicit dependencies in the form of with
97 -- clauses subject to pragma Elaborate[_All] when the elaboration graph
98 -- reaches into an external unit. The implicit dependencies are encoded
99 -- in the ALI file of the main unit. GNATbind and binde then use these
100 -- dependencies to augment the library item graph and determine the
101 -- elaboration order of all units in the compilation.
103 -- * Supply pieces of the invocation graph for a unit to bindo
105 -- The ABE mechanism captures paths starting from elaboration code or
106 -- top level constructs that reach into an external unit. The paths are
107 -- encoded in the ALI file of the main unit in the form of declarations
108 -- which represent nodes, and relations which represent edges. GNATbind
109 -- and bindo then build the full invocation graph in order to augment
110 -- the library item graph and determine the elaboration order of all
111 -- units in the compilation.
113 -- The ABE mechanism supports three models of elaboration:
115 -- * Dynamic model - This is the most permissive of the three models.
116 -- When the dynamic model is in effect, the mechanism diagnoses and
117 -- installs run-time checks to detect ABE issues in the main unit.
118 -- The behavior of this model is identical to that specified by the
119 -- Ada RM. This model is enabled with switch -gnatE.
121 -- Static model - This is the middle ground of the three models. When
122 -- the static model is in effect, the mechanism diagnoses and installs
123 -- run-time checks to detect ABE issues in the main unit. In addition,
124 -- the mechanism generates implicit dependencies between units in the
125 -- form of with clauses subject to pragma Elaborate[_All] to ensure
126 -- the prior elaboration of withed units. This is the default model.
128 -- * SPARK model - This is the most conservative of the three models and
129 -- implements the semantics defined in SPARK RM 7.7. The SPARK model
130 -- is in effect only when a context resides in a SPARK_Mode On region,
131 -- otherwise the mechanism falls back to one of the previous models.
133 -- The ABE mechanism consists of a "recording" phase and a "processing"
140 -- * ABE - An attempt to invoke a scenario which has not been elaborated
143 -- * Bridge target - A type of target. A bridge target is a link between
144 -- scenarios. It is usually a byproduct of expansion and does not have
145 -- any direct ABE ramifications.
147 -- * Call marker - A special node used to indicate the presence of a call
148 -- in the tree in case expansion transforms or eliminates the original
149 -- call. N_Call_Marker nodes do not have static and run-time semantics.
151 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the
152 -- invocation of a target by a scenario within the main unit causes an
153 -- ABE, but does not cause an ABE for another scenarios within the main
156 -- * Declaration level - A type of enclosing level. A scenario or target is
157 -- at the declaration level when it appears within the declarations of a
158 -- block statement, entry body, subprogram body, or task body, ignoring
159 -- enclosing packages.
161 -- * Early call region - A section of code which ends at a subprogram body
162 -- and starts from the nearest non-preelaborable construct which precedes
163 -- the subprogram body. The early call region extends from a package body
164 -- to a package spec when the spec carries pragma Elaborate_Body.
166 -- * Generic library level - A type of enclosing level. A scenario or
167 -- target is at the generic library level if it appears in a generic
168 -- package library unit, ignoring enclosing packages.
170 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the
171 -- invocation of a target by all scenarios within the main unit causes
174 -- * Instantiation library level - A type of enclosing level. A scenario
175 -- or target is at the instantiation library level if it appears in an
176 -- instantiation library unit, ignoring enclosing packages.
178 -- * Invocation - The act of activating a task, calling a subprogram, or
179 -- instantiating a generic.
181 -- * Invocation construct - An entry declaration, [single] protected type,
182 -- subprogram declaration, subprogram instantiation, or a [single] task
183 -- type declared in the visible, private, or body declarations of the
186 -- * Invocation relation - A flow link between two invocation constructs
188 -- * Invocation signature - A set of attributes that uniquely identify an
189 -- invocation construct within the namespace of all ALI files.
191 -- * Library level - A type of enclosing level. A scenario or target is at
192 -- the library level if it appears in a package library unit, ignoring
193 -- enclosing packages.
195 -- * Non-library-level encapsulator - A construct that cannot be elaborated
196 -- on its own and requires elaboration by a top-level scenario.
198 -- * Scenario - A construct or context which is invoked by elaboration code
199 -- or invocation construct. The scenarios recognized by the ABE mechanism
202 -- - '[Unrestricted_]Access of entries, operators, and subprograms
204 -- - Assignments to variables
206 -- - Calls to entries, operators, and subprograms
208 -- - Derived type declarations
212 -- - Pragma Refined_State
214 -- - Reads of variables
218 -- * Target - A construct invoked by a scenario. The targets recognized by
219 -- the ABE mechanism are as follows:
221 -- - For '[Unrestricted_]Access of entries, operators, and subprograms,
222 -- the target is the entry, operator, or subprogram.
224 -- - For assignments to variables, the target is the variable
226 -- - For calls, the target is the entry, operator, or subprogram
228 -- - For derived type declarations, the target is the derived type
230 -- - For instantiations, the target is the generic template
232 -- - For pragma Refined_State, the targets are the constituents
234 -- - For reads of variables, the target is the variable
236 -- - For task activation, the target is the task body
242 -- Analysis/Resolution
244 -- +- Build_Call_Marker
246 -- +- Build_Variable_Reference_Marker
248 -- +- | -------------------- Recording phase ---------------------------+
250 -- | Record_Elaboration_Scenario |
252 -- | +--> Check_Preelaborated_Call |
254 -- | +--> Process_Guaranteed_ABE |
256 -- | | +--> Process_Guaranteed_ABE_Activation |
257 -- | | +--> Process_Guaranteed_ABE_Call |
258 -- | | +--> Process_Guaranteed_ABE_Instantiation |
260 -- +- | ----------------------------------------------------------------+
263 -- +--> Internal_Representation
265 -- +--> Scenario_Storage
267 -- End of Compilation
269 -- +- | --------------------- Processing phase -------------------------+
271 -- | Check_Elaboration_Scenarios |
273 -- | +--> Check_Conditional_ABE_Scenarios |
275 -- | | +--> Process_Conditional_ABE <----------------------+ |
277 -- | | +--> Process_Conditional_ABE_Activation | |
279 -- | | | +-----------------------------+ | |
281 -- | | +--> Process_Conditional_ABE_Call +---> Traverse_Body |
283 -- | | | +-----------------------------+ |
285 -- | | +--> Process_Conditional_ABE_Access_Taken |
286 -- | | +--> Process_Conditional_ABE_Instantiation |
287 -- | | +--> Process_Conditional_ABE_Variable_Assignment |
288 -- | | +--> Process_Conditional_ABE_Variable_Reference |
290 -- | +--> Check_SPARK_Scenario |
292 -- | | +--> Process_SPARK_Scenario |
294 -- | | +--> Process_SPARK_Derived_Type |
295 -- | | +--> Process_SPARK_Instantiation |
296 -- | | +--> Process_SPARK_Refined_State_Pragma |
298 -- | +--> Record_Invocation_Graph |
300 -- | +--> Process_Invocation_Body_Scenarios |
301 -- | +--> Process_Invocation_Spec_Scenarios |
302 -- | +--> Process_Main_Unit |
304 -- | +--> Process_Invocation_Scenario <-------------+ |
306 -- | +--> Process_Invocation_Activation | |
308 -- | | +------------------------+ | |
310 -- | +--> Process_Invocation_Call +---> Traverse_Body |
312 -- | +------------------------+ |
314 -- +--------------------------------------------------------------------+
316 ---------------------
317 -- Recording phase --
318 ---------------------
320 -- The Recording phase coincides with the analysis/resolution phase of the
321 -- compiler. It has the following objectives:
323 -- * Record all suitable scenarios for examination by the Processing
326 -- Saving only a certain number of nodes improves the performance of
327 -- the ABE mechanism. This eliminates the need to examine the whole
328 -- tree in a separate pass.
330 -- * Record certain SPARK scenarios which are not necessarily invoked
331 -- during elaboration, but still require elaboration-related checks.
333 -- Saving only a certain number of nodes improves the performance of
334 -- the ABE mechanism. This eliminates the need to examine the whole
335 -- tree in a separate pass.
337 -- * Detect and diagnose calls in preelaborable or pure units, including
340 -- This diagnostic is carried out during the Recording phase because it
341 -- does not need the heavy recursive traversal done by the Processing
344 -- * Detect and diagnose guaranteed ABEs caused by instantiations, calls,
345 -- and task activation.
347 -- The issues detected by the ABE mechanism are reported as warnings
348 -- because they do not violate Ada semantics. Forward instantiations
349 -- may thus reach gigi, however gigi cannot handle certain kinds of
350 -- premature instantiations and may crash. To avoid this limitation,
351 -- the ABE mechanism must identify forward instantiations as early as
352 -- possible and suppress their bodies. Calls and task activations are
353 -- included in this category for completeness.
355 ----------------------
356 -- Processing phase --
357 ----------------------
359 -- The Processing phase is a separate pass which starts after instantiating
360 -- and/or inlining of bodies, but before the removal of Ghost code. It has
361 -- the following objectives:
363 -- * Examine all scenarios saved during the Recording phase, and perform
364 -- the following actions:
368 -- Diagnose conditional ABEs, and install run-time conditional ABE
369 -- checks for all scenarios.
373 -- Enforce the SPARK elaboration rules
377 -- Diagnose conditional ABEs, install run-time conditional ABE
378 -- checks only for scenarios are reachable from elaboration code,
379 -- and guarantee the elaboration of external units by creating
380 -- implicit with clauses subject to pragma Elaborate[_All].
382 -- * Examine library-level scenarios and invocation constructs, and
383 -- perform the following actions:
385 -- - Determine whether the flow of execution reaches into an external
386 -- unit. If this is the case, encode the path in the ALI file of
389 -- - Create declarations for invocation constructs in the ALI file of
392 ----------------------
393 -- Important points --
394 ----------------------
396 -- The Processing phase starts after the analysis, resolution, expansion
397 -- phase has completed. As a result, no current semantic information is
398 -- available. The scope stack is empty, global flags such as In_Instance
399 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism
400 -- must either save or recompute semantic information.
402 -- Expansion heavily transforms calls and to some extent instantiations. To
403 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to
404 -- capture the target and relevant attributes of the original call.
406 -- The diagnostics of the ABE mechanism depend on accurate source locations
407 -- to determine the spatial relation of nodes.
409 -----------------------------------------
410 -- Suppression of elaboration warnings --
411 -----------------------------------------
413 -- Elaboration warnings along multiple traversal paths rooted at a scenario
414 -- are suppressed when the scenario has elaboration warnings suppressed.
418 -- +-- Child scenario 1
420 -- | +-- Grandchild scenario 1
422 -- | +-- Grandchild scenario N
424 -- +-- Child scenario N
426 -- If the root scenario has elaboration warnings suppressed, then all its
427 -- child, grandchild, etc. scenarios will have their elaboration warnings
430 -- In addition to switch -gnatwL, pragma Warnings may be used to suppress
431 -- elaboration-related warnings when used in the following manner:
433 -- pragma Warnings ("L");
434 -- <scenario-or-target>
437 -- pragma Warnings (Off, target);
439 -- pragma Warnings (Off);
440 -- <scenario-or-target>
442 -- * To suppress elaboration warnings for '[Unrestricted_]Access of
443 -- entries, operators, and subprograms, either:
445 -- - Suppress the entry, operator, or subprogram, or
446 -- - Suppress the attribute, or
447 -- - Use switch -gnatw.f
449 -- * To suppress elaboration warnings for calls to entries, operators,
450 -- and subprograms, either:
452 -- - Suppress the entry, operator, or subprogram, or
453 -- - Suppress the call
455 -- * To suppress elaboration warnings for instantiations, suppress the
458 -- * To suppress elaboration warnings for task activations, either:
460 -- - Suppress the task object, or
461 -- - Suppress the task type, or
462 -- - Suppress the activation call
468 -- The following switches may be used to control the behavior of the ABE
471 -- -gnatd_a stop elaboration checks on accept or select statement
473 -- The ABE mechanism stops the traversal of a task body when it
474 -- encounters an accept or a select statement. This behavior is
475 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code,
476 -- but without penalizing actual entry calls during elaboration.
478 -- -gnatd_e ignore entry calls and requeue statements for elaboration
480 -- The ABE mechanism does not generate N_Call_Marker nodes for
481 -- protected or task entry calls as well as requeue statements.
482 -- As a result, the calls and requeues are not recorded or
485 -- -gnatdE elaboration checks on predefined units
487 -- The ABE mechanism considers scenarios which appear in internal
488 -- units (Ada, GNAT, Interfaces, System).
490 -- -gnatd_F encode full invocation paths in ALI files
492 -- The ABE mechanism encodes the full path from an elaboration
493 -- procedure or invocable construct to an external target. The
494 -- path contains all intermediate activations, instantiations,
497 -- -gnatd.G ignore calls through generic formal parameters for elaboration
499 -- The ABE mechanism does not generate N_Call_Marker nodes for
500 -- calls which occur in expanded instances, and invoke generic
501 -- actual subprograms through generic formal subprograms. As a
502 -- result, the calls are not recorded or processed.
504 -- -gnatd_i ignore activations and calls to instances for elaboration
506 -- The ABE mechanism ignores calls and task activations when they
507 -- target a subprogram or task type defined an external instance.
508 -- As a result, the calls and task activations are not processed.
510 -- -gnatdL ignore external calls from instances for elaboration
512 -- The ABE mechanism does not generate N_Call_Marker nodes for
513 -- calls which occur in expanded instances, do not invoke generic
514 -- actual subprograms through formal subprograms, and the target
515 -- is external to the instance. As a result, the calls are not
516 -- recorded or processed.
518 -- -gnatd.o conservative elaboration order for indirect calls
520 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
521 -- operator, or subprogram as an immediate invocation of the
522 -- target. As a result, it performs ABE checks and diagnostics on
523 -- the immediate call.
525 -- -gnatd_p ignore assertion pragmas for elaboration
527 -- The ABE mechanism does not generate N_Call_Marker nodes for
528 -- calls to subprograms which verify the run-time semantics of
529 -- the following assertion pragmas:
531 -- Default_Initial_Condition
539 -- Type_Invariant_Class
541 -- As a result, the assertion expressions of the pragmas are not
544 -- -gnatd_s stop elaboration checks on synchronous suspension
546 -- The ABE mechanism stops the traversal of a task body when it
547 -- encounters a call to one of the following routines:
549 -- Ada.Synchronous_Barriers.Wait_For_Release
550 -- Ada.Synchronous_Task_Control.Suspend_Until_True
552 -- -gnatd_T output trace information on invocation relation construction
554 -- The ABE mechanism outputs text information concerning relation
555 -- construction to standard output.
557 -- -gnatd.U ignore indirect calls for static elaboration
559 -- The ABE mechanism does not consider '[Unrestricted_]Access of
560 -- entries, operators, and subprograms. As a result, the scenarios
561 -- are not recorder or processed.
563 -- -gnatd.v enforce SPARK elaboration rules in SPARK code
565 -- The ABE mechanism applies some of the SPARK elaboration rules
566 -- defined in the SPARK reference manual, chapter 7.7. Note that
567 -- certain rules are always enforced, regardless of whether the
570 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies
572 -- The ABE mechanism does not generate implicit Elaborate_All when
573 -- the need for the pragma came from a task body.
575 -- -gnatE dynamic elaboration checking mode enabled
577 -- The ABE mechanism assumes that any scenario is elaborated or
578 -- invoked by elaboration code. The ABE mechanism performs very
579 -- little diagnostics and generates condintional ABE checks to
580 -- detect ABE issues at run-time.
582 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas
584 -- The ABE mechanism produces information messages on generated
585 -- implicit Elabote[_All] pragmas along with traceback showing
586 -- why the pragma was generated. In addition, the ABE mechanism
587 -- produces information messages for each scenario elaborated or
588 -- invoked by elaboration code.
590 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas
592 -- The complementary switch for -gnatel.
594 -- -gnatH legacy elaboration checking mode enabled
596 -- When this switch is in effect, the pre-18.x ABE model becomes
597 -- the de facto ABE model. This amounts to cutting off all entry
598 -- points into the new ABE mechanism, and giving full control to
599 -- the old ABE mechanism.
601 -- -gnatJ permissive elaboration checking mode enabled
603 -- This switch activates the following switches:
615 -- IMPORTANT: The behavior of the ABE mechanism becomes more
616 -- permissive at the cost of accurate diagnostics and runtime
619 -- -gnatw.f turn on warnings for suspicious Subp'Access
621 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
622 -- operator, or subprogram as a pseudo invocation of the target.
623 -- As a result, it performs ABE diagnostics on the pseudo call.
625 -- -gnatw.F turn off warnings for suspicious Subp'Access
627 -- The complementary switch for -gnatw.f.
629 -- -gnatwl turn on warnings for elaboration problems
631 -- The ABE mechanism produces warnings on detected ABEs along with
632 -- a traceback showing the graph of the ABE.
634 -- -gnatwL turn off warnings for elaboration problems
636 -- The complementary switch for -gnatwl.
638 --------------------------
639 -- Debugging ABE issues --
640 --------------------------
642 -- * If the issue involves a call, ensure that the call is eligible for ABE
643 -- processing and receives a corresponding call marker. The routines of
647 -- Record_Elaboration_Scenario
649 -- * If the issue involves an arbitrary scenario, ensure that the scenario
650 -- is either recorded, or is successfully recognized while traversing a
651 -- body. The routines of interest are
653 -- Record_Elaboration_Scenario
654 -- Process_Conditional_ABE
655 -- Process_Guaranteed_ABE
658 -- * If the issue involves a circularity in the elaboration order, examine
659 -- the ALI files and look for the following encodings next to units:
661 -- E indicates a source Elaborate
663 -- EA indicates a source Elaborate_All
665 -- AD indicates an implicit Elaborate_All
667 -- ED indicates an implicit Elaborate
669 -- If possible, compare these encodings with those generated by the old
670 -- ABE mechanism. The routines of interest are
672 -- Ensure_Prior_Elaboration
678 -- The following type enumerates all possible elaboration phase statutes
680 type Elaboration_Phase_Status
is
682 -- The elaboration phase of the compiler has not started yet
685 -- The elaboration phase of the compiler is currently in progress
688 -- The elaboration phase of the compiler has finished
690 Elaboration_Phase
: Elaboration_Phase_Status
:= Inactive
;
691 -- The status of the elaboration phase. Use routine Set_Elaboration_Phase
692 -- to alter its value.
694 -- The following type enumerates all subprogram body traversal modes
696 type Body_Traversal_Kind
is
698 -- The traversal examines the internals of a subprogram
702 -- The following type enumerates all operation modes
704 type Processing_Kind
is
705 (Conditional_ABE_Processing
,
706 -- The ABE mechanism detects and diagnoses conditional ABEs for library
707 -- and declaration-level scenarios.
709 Dynamic_Model_Processing
,
710 -- The ABE mechanism installs conditional ABE checks for all eligible
711 -- scenarios when the dynamic model is in effect.
713 Guaranteed_ABE_Processing
,
714 -- The ABE mechanism detects and diagnoses guaranteed ABEs caused by
715 -- calls, instantiations, and task activations.
717 Invocation_Construct_Processing
,
718 -- The ABE mechanism locates all invocation constructs within the main
719 -- unit and utilizes them as roots of miltiple DFS traversals aimed at
720 -- detecting transitions from the main unit to an external unit.
722 Invocation_Body_Processing
,
723 -- The ABE mechanism utilizes all library-level body scenarios as roots
724 -- of miltiple DFS traversals aimed at detecting transitions from the
725 -- main unit to an external unit.
727 Invocation_Spec_Processing
,
728 -- The ABE mechanism utilizes all library-level spec scenarios as roots
729 -- of miltiple DFS traversals aimed at detecting transitions from the
730 -- main unit to an external unit.
733 -- The ABE mechanism detects and diagnoses violations of the SPARK
734 -- elaboration rules for SPARK-specific scenarios.
738 -- The following type enumerates all possible scenario kinds
740 type Scenario_Kind
is
741 (Access_Taken_Scenario
,
742 -- An attribute reference which takes 'Access or 'Unrestricted_Access of
743 -- an entry, operator, or subprogram.
746 -- A call which invokes an entry, operator, or subprogram
748 Derived_Type_Scenario
,
749 -- A declaration of a derived type. This is a SPARK-specific scenario.
751 Instantiation_Scenario
,
752 -- An instantiation which instantiates a generic package or subprogram.
753 -- This scenario is also subject to SPARK-specific rules.
755 Refined_State_Pragma_Scenario
,
756 -- A Refined_State pragma. This is a SPARK-specific scenario.
758 Task_Activation_Scenario
,
759 -- A call which activates objects of various task types
761 Variable_Assignment_Scenario
,
762 -- An assignment statement which modifies the value of some variable
764 Variable_Reference_Scenario
,
765 -- A reference to a variable. This is a SPARK-specific scenario.
769 -- The following type enumerates all possible consistency models of target
770 -- and scenario representations.
772 type Representation_Kind
is
773 (Inconsistent_Representation
,
774 -- A representation is said to be "inconsistent" when it is created from
775 -- a partially analyzed tree. In such an environment, certain attributes
776 -- such as a completing body may not be available yet.
778 Consistent_Representation
,
779 -- A representation is said to be "consistent" when it is created from a
780 -- fully analyzed tree, where all attributes are available.
784 -- The following type enumerates all possible target kinds
788 -- A generic unit being instantiated
791 -- The package form of an instantiation
794 -- An entry, operator, or subprogram being invoked, or aliased through
795 -- 'Access or 'Unrestricted_Access.
798 -- A task being activated by an activation call
801 -- A variable being updated through an assignment statement, or read
802 -- through a variable reference.
810 procedure Destroy
(NE
: in out Node_Or_Entity_Id
);
811 pragma Inline
(Destroy
);
812 -- Destroy node or entity NE
814 function Hash
(NE
: Node_Or_Entity_Id
) return Bucket_Range_Type
;
815 pragma Inline
(Hash
);
816 -- Obtain the hash value of key NE
818 -- The following is a general purpose list for nodes and entities
820 package NE_List
is new Doubly_Linked_Lists
821 (Element_Type
=> Node_Or_Entity_Id
,
823 Destroy_Element
=> Destroy
);
825 -- The following is a general purpose map which relates nodes and entities
826 -- to lists of nodes and entities.
828 package NE_List_Map
is new Dynamic_Hash_Tables
829 (Key_Type
=> Node_Or_Entity_Id
,
830 Value_Type
=> NE_List
.Doubly_Linked_List
,
831 No_Value
=> NE_List
.Nil
,
832 Expansion_Threshold
=> 1.5,
833 Expansion_Factor
=> 2,
834 Compression_Threshold
=> 0.3,
835 Compression_Factor
=> 2,
837 Destroy_Value
=> NE_List
.Destroy
,
840 -- The following is a general purpose membership set for nodes and entities
842 package NE_Set
is new Membership_Sets
843 (Element_Type
=> Node_Or_Entity_Id
,
847 -- The following type captures relevant attributes which pertain to the
848 -- in state of the Processing phase.
850 type Processing_In_State
is record
851 Processing
: Processing_Kind
:= No_Processing
;
852 -- Operation mode of the Processing phase. Once set, this value should
855 Representation
: Representation_Kind
:= No_Representation
;
856 -- Required level of scenario and target representation. Once set, this
857 -- value should not be changed.
859 Suppress_Checks
: Boolean := False;
860 -- This flag is set when the Processing phase must not generate any ABE
863 Suppress_Implicit_Pragmas
: Boolean := False;
864 -- This flag is set when the Processing phase must not generate any
865 -- implicit Elaborate[_All] pragmas.
867 Suppress_Info_Messages
: Boolean := False;
868 -- This flag is set when the Processing phase must not emit any info
871 Suppress_Up_Level_Targets
: Boolean := False;
872 -- This flag is set when the Processing phase must ignore up-level
875 Suppress_Warnings
: Boolean := False;
876 -- This flag is set when the Processing phase must not emit any warnings
877 -- on elaboration problems.
879 Traversal
: Body_Traversal_Kind
:= No_Traversal
;
880 -- The subprogram body traversal mode. Once set, this value should not
883 Within_Freezing_Actions
: Boolean := False;
884 -- This flag is set when the Processing phase is currently examining a
885 -- scenario which was reached from the actions of a freeze node.
887 Within_Generic
: Boolean := False;
888 -- This flag is set when the Processing phase is currently within a
891 Within_Initial_Condition
: Boolean := False;
892 -- This flag is set when the Processing phase is currently examining a
893 -- scenario which was reached from an initial condition procedure.
895 Within_Partial_Finalization
: Boolean := False;
896 -- This flag is set when the Processing phase is currently examining a
897 -- scenario which was reached from a partial finalization procedure.
899 Within_Task_Body
: Boolean := False;
900 -- This flag is set when the Processing phase is currently examining a
901 -- scenario which was reached from a task body.
904 -- The following constants define the various operational states of the
907 -- The conditional ABE state is used when processing scenarios that appear
908 -- at the declaration, instantiation, and library levels to detect errors
909 -- and install conditional ABE checks.
911 Conditional_ABE_State
: constant Processing_In_State
:=
912 (Processing
=> Conditional_ABE_Processing
,
913 Representation
=> Consistent_Representation
,
914 Traversal
=> Deep_Traversal
,
917 -- The dynamic model state is used to install conditional ABE checks when
918 -- switch -gnatE (dynamic elaboration checking mode enabled) is in effect.
920 Dynamic_Model_State
: constant Processing_In_State
:=
921 (Processing
=> Dynamic_Model_Processing
,
922 Representation
=> Consistent_Representation
,
923 Suppress_Implicit_Pragmas
=> True,
924 Suppress_Info_Messages
=> True,
925 Suppress_Up_Level_Targets
=> True,
926 Suppress_Warnings
=> True,
927 Traversal
=> No_Traversal
,
930 -- The guaranteed ABE state is used when processing scenarios that appear
931 -- at the declaration, instantiation, and library levels to detect errors
932 -- and install guarateed ABE failures.
934 Guaranteed_ABE_State
: constant Processing_In_State
:=
935 (Processing
=> Guaranteed_ABE_Processing
,
936 Representation
=> Inconsistent_Representation
,
937 Suppress_Implicit_Pragmas
=> True,
938 Traversal
=> No_Traversal
,
941 -- The invocation body state is used when processing scenarios that appear
942 -- at the body library level to encode paths that start from elaboration
943 -- code and ultimately reach into external units.
945 Invocation_Body_State
: constant Processing_In_State
:=
946 (Processing
=> Invocation_Body_Processing
,
947 Representation
=> Consistent_Representation
,
948 Suppress_Checks
=> True,
949 Suppress_Implicit_Pragmas
=> True,
950 Suppress_Info_Messages
=> True,
951 Suppress_Up_Level_Targets
=> True,
952 Suppress_Warnings
=> True,
953 Traversal
=> Deep_Traversal
,
956 -- The invocation construct state is used when processing constructs that
957 -- appear within the spec and body of the main unit and eventually reach
958 -- into external units.
960 Invocation_Construct_State
: constant Processing_In_State
:=
961 (Processing
=> Invocation_Construct_Processing
,
962 Representation
=> Consistent_Representation
,
963 Suppress_Checks
=> True,
964 Suppress_Implicit_Pragmas
=> True,
965 Suppress_Info_Messages
=> True,
966 Suppress_Up_Level_Targets
=> True,
967 Suppress_Warnings
=> True,
968 Traversal
=> Deep_Traversal
,
971 -- The invocation spec state is used when processing scenarios that appear
972 -- at the spec library level to encode paths that start from elaboration
973 -- code and ultimately reach into external units.
975 Invocation_Spec_State
: constant Processing_In_State
:=
976 (Processing
=> Invocation_Spec_Processing
,
977 Representation
=> Consistent_Representation
,
978 Suppress_Checks
=> True,
979 Suppress_Implicit_Pragmas
=> True,
980 Suppress_Info_Messages
=> True,
981 Suppress_Up_Level_Targets
=> True,
982 Suppress_Warnings
=> True,
983 Traversal
=> Deep_Traversal
,
986 -- The SPARK state is used when verying SPARK-specific semantics of certain
989 SPARK_State
: constant Processing_In_State
:=
990 (Processing
=> SPARK_Processing
,
991 Representation
=> Consistent_Representation
,
992 Traversal
=> No_Traversal
,
995 -- The following type identifies a scenario representation
997 type Scenario_Rep_Id
is new Natural;
999 No_Scenario_Rep
: constant Scenario_Rep_Id
:= Scenario_Rep_Id
'First;
1000 First_Scenario_Rep
: constant Scenario_Rep_Id
:= No_Scenario_Rep
+ 1;
1002 -- The following type identifies a target representation
1004 type Target_Rep_Id
is new Natural;
1006 No_Target_Rep
: constant Target_Rep_Id
:= Target_Rep_Id
'First;
1007 First_Target_Rep
: constant Target_Rep_Id
:= No_Target_Rep
+ 1;
1013 -- The following package keeps track of all active scenarios during a DFS
1016 package Active_Scenarios
is
1022 -- The following type defines the position within the active scenario
1025 type Active_Scenario_Pos
is new Natural;
1027 ---------------------
1028 -- Data structures --
1029 ---------------------
1031 -- The following table stores all active scenarios in a DFS traversal.
1032 -- This table must be maintained in a FIFO fashion.
1034 package Active_Scenario_Stack
is new Table
.Table
1035 (Table_Index_Type
=> Active_Scenario_Pos
,
1036 Table_Component_Type
=> Node_Id
,
1037 Table_Low_Bound
=> 1,
1038 Table_Initial
=> 50,
1039 Table_Increment
=> 200,
1040 Table_Name
=> "Active_Scenario_Stack");
1046 procedure Output_Active_Scenarios
1047 (Error_Nod
: Node_Id
;
1048 In_State
: Processing_In_State
);
1049 pragma Inline
(Output_Active_Scenarios
);
1050 -- Output the contents of the active scenario stack from earliest to
1051 -- latest to supplement an earlier error emitted for node Error_Nod.
1052 -- In_State denotes the current state of the Processing phase.
1054 procedure Pop_Active_Scenario
(N
: Node_Id
);
1055 pragma Inline
(Pop_Active_Scenario
);
1056 -- Pop the top of the scenario stack. A check is made to ensure that the
1057 -- scenario being removed is the same as N.
1059 procedure Push_Active_Scenario
(N
: Node_Id
);
1060 pragma Inline
(Push_Active_Scenario
);
1061 -- Push scenario N on top of the scenario stack
1063 function Root_Scenario
return Node_Id
;
1064 pragma Inline
(Root_Scenario
);
1065 -- Return the scenario which started a DFS traversal
1067 end Active_Scenarios
;
1068 use Active_Scenarios
;
1070 -- The following package provides the main entry point for task activation
1073 package Activation_Processor
is
1079 type Activation_Processor_Ptr
is access procedure
1081 Call_Rep
: Scenario_Rep_Id
;
1083 Obj_Rep
: Target_Rep_Id
;
1084 Task_Typ
: Entity_Id
;
1085 Task_Rep
: Target_Rep_Id
;
1086 In_State
: Processing_In_State
);
1087 -- Reference to a procedure that takes all attributes of an activation
1088 -- and performs a desired action. Call is the activation call. Call_Rep
1089 -- is the representation of the call. Obj_Id is the task object being
1090 -- activated. Obj_Rep is the representation of the object. Task_Typ is
1091 -- the task type whose body is being activated. Task_Rep denotes the
1092 -- representation of the task type. In_State is the current state of
1093 -- the Processing phase.
1099 procedure Process_Activation
1101 Call_Rep
: Scenario_Rep_Id
;
1102 Processor
: Activation_Processor_Ptr
;
1103 In_State
: Processing_In_State
);
1104 -- Find all task objects activated by activation call Call and invoke
1105 -- Processor on them. Call_Rep denotes the representation of the call.
1106 -- In_State is the current state of the Processing phase.
1108 end Activation_Processor
;
1109 use Activation_Processor
;
1111 -- The following package profides functionality for traversing subprogram
1112 -- bodies in DFS manner and processing of eligible scenarios within.
1114 package Body_Processor
is
1120 type Scenario_Predicate_Ptr
is access function
1121 (N
: Node_Id
) return Boolean;
1122 -- Reference to a function which determines whether arbitrary node N
1123 -- denotes a suitable scenario for processing.
1125 type Scenario_Processor_Ptr
is access procedure
1126 (N
: Node_Id
; In_State
: Processing_In_State
);
1127 -- Reference to a procedure which processes scenario N. In_State is the
1128 -- current state of the Processing phase.
1134 procedure Traverse_Body
1136 Requires_Processing
: Scenario_Predicate_Ptr
;
1137 Processor
: Scenario_Processor_Ptr
;
1138 In_State
: Processing_In_State
);
1139 pragma Inline
(Traverse_Body
);
1140 -- Traverse the declarations and handled statements of subprogram body
1141 -- N, looking for scenarios that satisfy predicate Requires_Processing.
1142 -- Routine Processor is invoked for each such scenario.
1144 procedure Reset_Traversed_Bodies
;
1145 pragma Inline
(Reset_Traversed_Bodies
);
1146 -- Reset the visited status of all subprogram bodies that have already
1147 -- been processed by routine Traverse_Body.
1153 procedure Finalize_Body_Processor
;
1154 pragma Inline
(Finalize_Body_Processor
);
1155 -- Finalize all internal data structures
1157 procedure Initialize_Body_Processor
;
1158 pragma Inline
(Initialize_Body_Processor
);
1159 -- Initialize all internal data structures
1164 -- The following package provides functionality for installing ABE-related
1165 -- checks and failures.
1167 package Check_Installer
is
1173 function Check_Or_Failure_Generation_OK
return Boolean;
1174 pragma Inline
(Check_Or_Failure_Generation_OK
);
1175 -- Determine whether a conditional ABE check or guaranteed ABE failure
1176 -- can be generated.
1178 procedure Install_Dynamic_ABE_Checks
;
1179 pragma Inline
(Install_Dynamic_ABE_Checks
);
1180 -- Install conditional ABE checks for all saved scenarios when the
1181 -- dynamic model is in effect.
1183 procedure Install_Scenario_ABE_Check
1185 Targ_Id
: Entity_Id
;
1186 Targ_Rep
: Target_Rep_Id
;
1187 Disable
: Scenario_Rep_Id
);
1188 pragma Inline
(Install_Scenario_ABE_Check
);
1189 -- Install a conditional ABE check for scenario N to ensure that target
1190 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
1191 -- target. If the check is installed, disable the elaboration checks of
1192 -- scenario Disable.
1194 procedure Install_Scenario_ABE_Check
1196 Targ_Id
: Entity_Id
;
1197 Targ_Rep
: Target_Rep_Id
;
1198 Disable
: Target_Rep_Id
);
1199 pragma Inline
(Install_Scenario_ABE_Check
);
1200 -- Install a conditional ABE check for scenario N to ensure that target
1201 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
1202 -- target. If the check is installed, disable the elaboration checks of
1205 procedure Install_Scenario_ABE_Failure
1207 Targ_Id
: Entity_Id
;
1208 Targ_Rep
: Target_Rep_Id
;
1209 Disable
: Scenario_Rep_Id
);
1210 pragma Inline
(Install_Scenario_ABE_Failure
);
1211 -- Install a guaranteed ABE failure for scenario N with target Targ_Id.
1212 -- Targ_Rep denotes the representation of the target. If the failure is
1213 -- installed, disable the elaboration checks of scenario Disable.
1215 procedure Install_Scenario_ABE_Failure
1217 Targ_Id
: Entity_Id
;
1218 Targ_Rep
: Target_Rep_Id
;
1219 Disable
: Target_Rep_Id
);
1220 pragma Inline
(Install_Scenario_ABE_Failure
);
1221 -- Install a guaranteed ABE failure for scenario N with target Targ_Id.
1222 -- Targ_Rep denotes the representation of the target. If the failure is
1223 -- installed, disable the elaboration checks of target Disable.
1225 procedure Install_Unit_ABE_Check
1227 Unit_Id
: Entity_Id
;
1228 Disable
: Scenario_Rep_Id
);
1229 pragma Inline
(Install_Unit_ABE_Check
);
1230 -- Install a conditional ABE check for scenario N to ensure that unit
1231 -- Unit_Id is properly elaborated. If the check is installed, disable
1232 -- the elaboration checks of scenario Disable.
1234 procedure Install_Unit_ABE_Check
1236 Unit_Id
: Entity_Id
;
1237 Disable
: Target_Rep_Id
);
1238 pragma Inline
(Install_Unit_ABE_Check
);
1239 -- Install a conditional ABE check for scenario N to ensure that unit
1240 -- Unit_Id is properly elaborated. If the check is installed, disable
1241 -- the elaboration checks of target Disable.
1243 end Check_Installer
;
1244 use Check_Installer
;
1246 -- The following package provides the main entry point for conditional ABE
1247 -- checks and diagnostics.
1249 package Conditional_ABE_Processor
is
1255 procedure Check_Conditional_ABE_Scenarios
1256 (Iter
: in out NE_Set
.Iterator
);
1257 pragma Inline
(Check_Conditional_ABE_Scenarios
);
1258 -- Perform conditional ABE checks and diagnostics for all scenarios
1259 -- available through iterator Iter.
1261 procedure Process_Conditional_ABE
1263 In_State
: Processing_In_State
);
1264 pragma Inline
(Process_Conditional_ABE
);
1265 -- Perform conditional ABE checks and diagnostics for scenario N.
1266 -- In_State denotes the current state of the Processing phase.
1268 end Conditional_ABE_Processor
;
1269 use Conditional_ABE_Processor
;
1271 -- The following package provides functionality to emit errors, information
1272 -- messages, and warnings.
1274 package Diagnostics
is
1280 procedure Elab_Msg_NE
1285 In_SPARK
: Boolean);
1286 pragma Inline
(Elab_Msg_NE
);
1287 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary
1288 -- node N and entity. If flag Info_Msg is set, the routine emits an
1289 -- information message, otherwise it emits an error. If flag In_SPARK
1290 -- is set, then string " in SPARK" is added to the end of the message.
1294 Subp_Id
: Entity_Id
;
1296 In_SPARK
: Boolean);
1297 pragma Inline
(Info_Call
);
1298 -- Output information concerning call Call that invokes subprogram
1299 -- Subp_Id. When flag Info_Msg is set, the routine emits an information
1300 -- message, otherwise it emits an error. When flag In_SPARK is set, " in
1301 -- SPARK" is added to the end of the message.
1303 procedure Info_Instantiation
1307 In_SPARK
: Boolean);
1308 pragma Inline
(Info_Instantiation
);
1309 -- Output information concerning instantiation Inst which instantiates
1310 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an
1311 -- information message, otherwise it emits an error. If flag In_SPARK
1312 -- is set, then string " in SPARK" is added to the end of the message.
1314 procedure Info_Variable_Reference
1316 Var_Id
: Entity_Id
);
1317 pragma Inline
(Info_Variable_Reference
);
1318 -- Output information concerning reference Ref which mentions variable
1319 -- Var_Id. The routine emits an error suffixed with " in SPARK".
1324 -- The following package provides functionality to locate the early call
1325 -- region of a subprogram body.
1327 package Early_Call_Region_Processor
is
1333 function Find_Early_Call_Region
1334 (Body_Decl
: Node_Id
;
1335 Assume_Elab_Body
: Boolean := False;
1336 Skip_Memoization
: Boolean := False) return Node_Id
;
1337 pragma Inline
(Find_Early_Call_Region
);
1338 -- Find the start of the early call region that belongs to subprogram
1339 -- body Body_Decl as defined in SPARK RM 7.7. This routine finds the
1340 -- early call region, memoizes it, and returns it, but this behavior
1341 -- can be altered. Flag Assume_Elab_Body should be set when a package
1342 -- spec may lack pragma Elaborate_Body, but the routine must still
1343 -- examine that spec. Flag Skip_Memoization should be set when the
1344 -- routine must avoid memoizing the region.
1350 procedure Finalize_Early_Call_Region_Processor
;
1351 pragma Inline
(Finalize_Early_Call_Region_Processor
);
1352 -- Finalize all internal data structures
1354 procedure Initialize_Early_Call_Region_Processor
;
1355 pragma Inline
(Initialize_Early_Call_Region_Processor
);
1356 -- Initialize all internal data structures
1358 end Early_Call_Region_Processor
;
1359 use Early_Call_Region_Processor
;
1361 -- The following package provides access to the elaboration statuses of all
1362 -- units withed by the main unit.
1364 package Elaborated_Units
is
1370 procedure Collect_Elaborated_Units
;
1371 pragma Inline
(Collect_Elaborated_Units
);
1372 -- Save the elaboration statuses of all units withed by the main unit
1374 procedure Ensure_Prior_Elaboration
1376 Unit_Id
: Entity_Id
;
1378 In_State
: Processing_In_State
);
1379 pragma Inline
(Ensure_Prior_Elaboration
);
1380 -- Guarantee the elaboration of unit Unit_Id with respect to the main
1381 -- unit by either suggesting or installing an Elaborate[_All] pragma
1382 -- denoted by Prag_Nam. N denotes the related scenario. In_State is the
1383 -- current state of the Processing phase.
1385 function Has_Prior_Elaboration
1386 (Unit_Id
: Entity_Id
;
1387 Context_OK
: Boolean := False;
1388 Elab_Body_OK
: Boolean := False;
1389 Same_Unit_OK
: Boolean := False) return Boolean;
1390 pragma Inline
(Has_Prior_Elaboration
);
1391 -- Determine whether unit Unit_Id is elaborated prior to the main unit.
1392 -- If flag Context_OK is set, the routine considers the following case
1393 -- as valid prior elaboration:
1395 -- * Unit_Id is in the elaboration context of the main unit
1397 -- If flag Elab_Body_OK is set, the routine considers the following case
1398 -- as valid prior elaboration:
1400 -- * Unit_Id has pragma Elaborate_Body and is not the main unit
1402 -- If flag Same_Unit_OK is set, the routine considers the following
1403 -- cases as valid prior elaboration:
1405 -- * Unit_Id is the main unit
1407 -- * Unit_Id denotes the spec of the main unit body
1409 procedure Meet_Elaboration_Requirement
1411 Targ_Id
: Entity_Id
;
1413 In_State
: Processing_In_State
);
1414 pragma Inline
(Meet_Elaboration_Requirement
);
1415 -- Determine whether elaboration requirement Req_Nam for scenario N with
1416 -- target Targ_Id is met by the context of the main unit using the SPARK
1417 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an
1418 -- error if this is not the case. In_State denotes the current state of
1419 -- the Processing phase.
1425 procedure Finalize_Elaborated_Units
;
1426 pragma Inline
(Finalize_Elaborated_Units
);
1427 -- Finalize all internal data structures
1429 procedure Initialize_Elaborated_Units
;
1430 pragma Inline
(Initialize_Elaborated_Units
);
1431 -- Initialize all internal data structures
1433 end Elaborated_Units
;
1434 use Elaborated_Units
;
1436 -- The following package provides the main entry point for guaranteed ABE
1437 -- checks and diagnostics.
1439 package Guaranteed_ABE_Processor
is
1445 procedure Process_Guaranteed_ABE
1447 In_State
: Processing_In_State
);
1448 pragma Inline
(Process_Guaranteed_ABE
);
1449 -- Perform guaranteed ABE checks and diagnostics for scenario N.
1450 -- In_State is the current state of the Processing phase.
1452 end Guaranteed_ABE_Processor
;
1453 use Guaranteed_ABE_Processor
;
1455 -- The following package provides access to the internal representation of
1456 -- scenarios and targets.
1458 package Internal_Representation
is
1464 -- The following type enumerates all possible Ghost mode kinds
1466 type Extended_Ghost_Mode
is
1468 Is_Checked_Or_Not_Specified
);
1470 -- The following type enumerates all possible SPARK mode kinds
1472 type Extended_SPARK_Mode
is
1474 Is_Off_Or_Not_Specified
);
1480 function Scenario_Representation_Of
1482 In_State
: Processing_In_State
) return Scenario_Rep_Id
;
1483 pragma Inline
(Scenario_Representation_Of
);
1484 -- Obtain the id of elaboration scenario N's representation. The routine
1485 -- constructs the representation if it is not available. In_State is the
1486 -- current state of the Processing phase.
1488 function Target_Representation_Of
1490 In_State
: Processing_In_State
) return Target_Rep_Id
;
1491 pragma Inline
(Target_Representation_Of
);
1492 -- Obtain the id of elaboration target Id's representation. The routine
1493 -- constructs the representation if it is not available. In_State is the
1494 -- current state of the Processing phase.
1496 -------------------------
1497 -- Scenario attributes --
1498 -------------------------
1500 function Activated_Task_Objects
1501 (S_Id
: Scenario_Rep_Id
) return NE_List
.Doubly_Linked_List
;
1502 pragma Inline
(Activated_Task_Objects
);
1503 -- For Task_Activation_Scenario S_Id, obtain the list of task objects
1504 -- the scenario is activating.
1506 function Activated_Task_Type
(S_Id
: Scenario_Rep_Id
) return Entity_Id
;
1507 pragma Inline
(Activated_Task_Type
);
1508 -- For Task_Activation_Scenario S_Id, obtain the currently activated
1511 procedure Disable_Elaboration_Checks
(S_Id
: Scenario_Rep_Id
);
1512 pragma Inline
(Disable_Elaboration_Checks
);
1513 -- Disable elaboration checks of scenario S_Id
1515 function Elaboration_Checks_OK
(S_Id
: Scenario_Rep_Id
) return Boolean;
1516 pragma Inline
(Elaboration_Checks_OK
);
1517 -- Determine whether scenario S_Id may be subjected to elaboration
1520 function Elaboration_Warnings_OK
(S_Id
: Scenario_Rep_Id
) return Boolean;
1521 pragma Inline
(Elaboration_Warnings_OK
);
1522 -- Determine whether scenario S_Id may be subjected to elaboration
1525 function Ghost_Mode_Of
1526 (S_Id
: Scenario_Rep_Id
) return Extended_Ghost_Mode
;
1527 pragma Inline
(Ghost_Mode_Of
);
1528 -- Obtain the Ghost mode of scenario S_Id
1530 function Is_Dispatching_Call
(S_Id
: Scenario_Rep_Id
) return Boolean;
1531 pragma Inline
(Is_Dispatching_Call
);
1532 -- For Call_Scenario S_Id, determine whether the call is dispatching
1534 function Is_Read_Reference
(S_Id
: Scenario_Rep_Id
) return Boolean;
1535 pragma Inline
(Is_Read_Reference
);
1536 -- For Variable_Reference_Scenario S_Id, determine whether the reference
1539 function Kind
(S_Id
: Scenario_Rep_Id
) return Scenario_Kind
;
1540 pragma Inline
(Kind
);
1541 -- Obtain the nature of scenario S_Id
1543 function Level
(S_Id
: Scenario_Rep_Id
) return Enclosing_Level_Kind
;
1544 pragma Inline
(Level
);
1545 -- Obtain the enclosing level of scenario S_Id
1547 procedure Set_Activated_Task_Objects
1548 (S_Id
: Scenario_Rep_Id
;
1549 Task_Objs
: NE_List
.Doubly_Linked_List
);
1550 pragma Inline
(Set_Activated_Task_Objects
);
1551 -- For Task_Activation_Scenario S_Id, set the list of task objects
1552 -- activated by the scenario to Task_Objs.
1554 procedure Set_Activated_Task_Type
1555 (S_Id
: Scenario_Rep_Id
;
1556 Task_Typ
: Entity_Id
);
1557 pragma Inline
(Set_Activated_Task_Type
);
1558 -- For Task_Activation_Scenario S_Id, set the currently activated task
1559 -- type to Task_Typ.
1561 function SPARK_Mode_Of
1562 (S_Id
: Scenario_Rep_Id
) return Extended_SPARK_Mode
;
1563 pragma Inline
(SPARK_Mode_Of
);
1564 -- Obtain the SPARK mode of scenario S_Id
1566 function Target
(S_Id
: Scenario_Rep_Id
) return Entity_Id
;
1567 pragma Inline
(Target
);
1568 -- Obtain the target of scenario S_Id
1570 -----------------------
1571 -- Target attributes --
1572 -----------------------
1574 function Barrier_Body_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
;
1575 pragma Inline
(Barrier_Body_Declaration
);
1576 -- For Subprogram_Target T_Id, obtain the declaration of the barrier
1579 function Body_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
;
1580 pragma Inline
(Body_Declaration
);
1581 -- Obtain the declaration of the body which belongs to target T_Id
1583 procedure Disable_Elaboration_Checks
(T_Id
: Target_Rep_Id
);
1584 pragma Inline
(Disable_Elaboration_Checks
);
1585 -- Disable elaboration checks of target T_Id
1587 function Elaboration_Checks_OK
(T_Id
: Target_Rep_Id
) return Boolean;
1588 pragma Inline
(Elaboration_Checks_OK
);
1589 -- Determine whether target T_Id may be subjected to elaboration checks
1591 function Elaboration_Warnings_OK
(T_Id
: Target_Rep_Id
) return Boolean;
1592 pragma Inline
(Elaboration_Warnings_OK
);
1593 -- Determine whether target T_Id may be subjected to elaboration
1596 function Ghost_Mode_Of
(T_Id
: Target_Rep_Id
) return Extended_Ghost_Mode
;
1597 pragma Inline
(Ghost_Mode_Of
);
1598 -- Obtain the Ghost mode of target T_Id
1600 function Kind
(T_Id
: Target_Rep_Id
) return Target_Kind
;
1601 pragma Inline
(Kind
);
1602 -- Obtain the nature of target T_Id
1604 function SPARK_Mode_Of
(T_Id
: Target_Rep_Id
) return Extended_SPARK_Mode
;
1605 pragma Inline
(SPARK_Mode_Of
);
1606 -- Obtain the SPARK mode of target T_Id
1608 function Spec_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
;
1609 pragma Inline
(Spec_Declaration
);
1610 -- Obtain the declaration of the spec which belongs to target T_Id
1612 function Unit
(T_Id
: Target_Rep_Id
) return Entity_Id
;
1613 pragma Inline
(Unit
);
1614 -- Obtain the unit where the target is defined
1616 function Variable_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
;
1617 pragma Inline
(Variable_Declaration
);
1618 -- For Variable_Target T_Id, obtain the declaration of the variable
1624 procedure Finalize_Internal_Representation
;
1625 pragma Inline
(Finalize_Internal_Representation
);
1626 -- Finalize all internal data structures
1628 procedure Initialize_Internal_Representation
;
1629 pragma Inline
(Initialize_Internal_Representation
);
1630 -- Initialize all internal data structures
1632 end Internal_Representation
;
1633 use Internal_Representation
;
1635 -- The following package provides functionality for recording pieces of the
1636 -- invocation graph in the ALI file of the main unit.
1638 package Invocation_Graph
is
1644 procedure Record_Invocation_Graph
;
1645 pragma Inline
(Record_Invocation_Graph
);
1646 -- Process all declaration, instantiation, and library level scenarios,
1647 -- along with invocation construct within the spec and body of the main
1648 -- unit to determine whether any of these reach into an external unit.
1649 -- If such a path exists, encode in the ALI file of the main unit.
1655 procedure Finalize_Invocation_Graph
;
1656 pragma Inline
(Finalize_Invocation_Graph
);
1657 -- Finalize all internal data structures
1659 procedure Initialize_Invocation_Graph
;
1660 pragma Inline
(Initialize_Invocation_Graph
);
1661 -- Initialize all internal data structures
1663 end Invocation_Graph
;
1664 use Invocation_Graph
;
1666 -- The following package stores scenarios
1668 package Scenario_Storage
is
1674 procedure Add_Declaration_Scenario
(N
: Node_Id
);
1675 pragma Inline
(Add_Declaration_Scenario
);
1676 -- Save declaration level scenario N
1678 procedure Add_Dynamic_ABE_Check_Scenario
(N
: Node_Id
);
1679 pragma Inline
(Add_Dynamic_ABE_Check_Scenario
);
1680 -- Save scenario N for conditional ABE check installation purposes when
1681 -- the dynamic model is in effect.
1683 procedure Add_Library_Body_Scenario
(N
: Node_Id
);
1684 pragma Inline
(Add_Library_Body_Scenario
);
1685 -- Save library-level body scenario N
1687 procedure Add_Library_Spec_Scenario
(N
: Node_Id
);
1688 pragma Inline
(Add_Library_Spec_Scenario
);
1689 -- Save library-level spec scenario N
1691 procedure Add_SPARK_Scenario
(N
: Node_Id
);
1692 pragma Inline
(Add_SPARK_Scenario
);
1693 -- Save SPARK scenario N
1695 procedure Delete_Scenario
(N
: Node_Id
);
1696 pragma Inline
(Delete_Scenario
);
1697 -- Delete arbitrary scenario N
1699 function Iterate_Declaration_Scenarios
return NE_Set
.Iterator
;
1700 pragma Inline
(Iterate_Declaration_Scenarios
);
1701 -- Obtain an iterator over all declaration level scenarios
1703 function Iterate_Dynamic_ABE_Check_Scenarios
return NE_Set
.Iterator
;
1704 pragma Inline
(Iterate_Dynamic_ABE_Check_Scenarios
);
1705 -- Obtain an iterator over all scenarios that require a conditional ABE
1706 -- check when the dynamic model is in effect.
1708 function Iterate_Library_Body_Scenarios
return NE_Set
.Iterator
;
1709 pragma Inline
(Iterate_Library_Body_Scenarios
);
1710 -- Obtain an iterator over all library level body scenarios
1712 function Iterate_Library_Spec_Scenarios
return NE_Set
.Iterator
;
1713 pragma Inline
(Iterate_Library_Spec_Scenarios
);
1714 -- Obtain an iterator over all library level spec scenarios
1716 function Iterate_SPARK_Scenarios
return NE_Set
.Iterator
;
1717 pragma Inline
(Iterate_SPARK_Scenarios
);
1718 -- Obtain an iterator over all SPARK scenarios
1720 procedure Replace_Scenario
(Old_N
: Node_Id
; New_N
: Node_Id
);
1721 pragma Inline
(Replace_Scenario
);
1722 -- Replace scenario Old_N with scenario New_N
1728 procedure Finalize_Scenario_Storage
;
1729 pragma Inline
(Finalize_Scenario_Storage
);
1730 -- Finalize all internal data structures
1732 procedure Initialize_Scenario_Storage
;
1733 pragma Inline
(Initialize_Scenario_Storage
);
1734 -- Initialize all internal data structures
1736 end Scenario_Storage
;
1737 use Scenario_Storage
;
1739 -- The following package provides various semantic predicates
1741 package Semantics
is
1747 function Is_Accept_Alternative_Proc
(Id
: Entity_Id
) return Boolean;
1748 pragma Inline
(Is_Accept_Alternative_Proc
);
1749 -- Determine whether arbitrary entity Id denotes an internally generated
1750 -- procedure which encapsulates the statements of an accept alternative.
1752 function Is_Activation_Proc
(Id
: Entity_Id
) return Boolean;
1753 pragma Inline
(Is_Activation_Proc
);
1754 -- Determine whether arbitrary entity Id denotes a runtime procedure in
1755 -- charge with activating tasks.
1757 function Is_Ada_Semantic_Target
(Id
: Entity_Id
) return Boolean;
1758 pragma Inline
(Is_Ada_Semantic_Target
);
1759 -- Determine whether arbitrary entity Id denotes a source or internally
1760 -- generated subprogram which emulates Ada semantics.
1762 function Is_Assertion_Pragma_Target
(Id
: Entity_Id
) return Boolean;
1763 pragma Inline
(Is_Assertion_Pragma_Target
);
1764 -- Determine whether arbitrary entity Id denotes a procedure which
1765 -- verifies the run-time semantics of an assertion pragma.
1767 function Is_Bodiless_Subprogram
(Subp_Id
: Entity_Id
) return Boolean;
1768 pragma Inline
(Is_Bodiless_Subprogram
);
1769 -- Determine whether subprogram Subp_Id will never have a body
1771 function Is_Bridge_Target
(Id
: Entity_Id
) return Boolean;
1772 pragma Inline
(Is_Bridge_Target
);
1773 -- Determine whether arbitrary entity Id denotes a bridge target
1775 function Is_Default_Initial_Condition_Proc
1776 (Id
: Entity_Id
) return Boolean;
1777 pragma Inline
(Is_Default_Initial_Condition_Proc
);
1778 -- Determine whether arbitrary entity Id denotes internally generated
1779 -- routine Default_Initial_Condition.
1781 function Is_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean;
1782 pragma Inline
(Is_Initial_Condition_Proc
);
1783 -- Determine whether arbitrary entity Id denotes internally generated
1784 -- routine Initial_Condition.
1786 function Is_Initialized
(Obj_Decl
: Node_Id
) return Boolean;
1787 pragma Inline
(Is_Initialized
);
1788 -- Determine whether object declaration Obj_Decl is initialized
1790 function Is_Invariant_Proc
(Id
: Entity_Id
) return Boolean;
1791 pragma Inline
(Is_Invariant_Proc
);
1792 -- Determine whether arbitrary entity Id denotes an invariant procedure
1794 function Is_Non_Library_Level_Encapsulator
(N
: Node_Id
) return Boolean;
1795 pragma Inline
(Is_Non_Library_Level_Encapsulator
);
1796 -- Determine whether arbitrary node N is a non-library encapsulator
1798 function Is_Partial_Invariant_Proc
(Id
: Entity_Id
) return Boolean;
1799 pragma Inline
(Is_Partial_Invariant_Proc
);
1800 -- Determine whether arbitrary entity Id denotes a partial invariant
1803 function Is_Preelaborated_Unit
(Id
: Entity_Id
) return Boolean;
1804 pragma Inline
(Is_Preelaborated_Unit
);
1805 -- Determine whether arbitrary entity Id denotes a unit which is subject
1806 -- to one of the following pragmas:
1810 -- * Remote_Call_Interface
1814 function Is_Protected_Entry
(Id
: Entity_Id
) return Boolean;
1815 pragma Inline
(Is_Protected_Entry
);
1816 -- Determine whether arbitrary entity Id denotes a protected entry
1818 function Is_Protected_Subp
(Id
: Entity_Id
) return Boolean;
1819 pragma Inline
(Is_Protected_Subp
);
1820 -- Determine whether entity Id denotes a protected subprogram
1822 function Is_Protected_Body_Subp
(Id
: Entity_Id
) return Boolean;
1823 pragma Inline
(Is_Protected_Body_Subp
);
1824 -- Determine whether entity Id denotes the protected or unprotected
1825 -- version of a protected subprogram.
1827 function Is_Scenario
(N
: Node_Id
) return Boolean;
1828 pragma Inline
(Is_Scenario
);
1829 -- Determine whether attribute node N denotes a scenario. The scenario
1830 -- may not necessarily be eligible for ABE processing.
1832 function Is_SPARK_Semantic_Target
(Id
: Entity_Id
) return Boolean;
1833 pragma Inline
(Is_SPARK_Semantic_Target
);
1834 -- Determine whether arbitrary entity Id denotes a source or internally
1835 -- generated subprogram which emulates SPARK semantics.
1837 function Is_Subprogram_Inst
(Id
: Entity_Id
) return Boolean;
1838 pragma Inline
(Is_Subprogram_Inst
);
1839 -- Determine whether arbitrary entity Id denotes a subprogram instance
1841 function Is_Suitable_Access_Taken
(N
: Node_Id
) return Boolean;
1842 pragma Inline
(Is_Suitable_Access_Taken
);
1843 -- Determine whether arbitrary node N denotes a suitable attribute for
1846 function Is_Suitable_Call
(N
: Node_Id
) return Boolean;
1847 pragma Inline
(Is_Suitable_Call
);
1848 -- Determine whether arbitrary node N denotes a suitable call for ABE
1851 function Is_Suitable_Instantiation
(N
: Node_Id
) return Boolean;
1852 pragma Inline
(Is_Suitable_Instantiation
);
1853 -- Determine whether arbitrary node N is a suitable instantiation for
1856 function Is_Suitable_SPARK_Derived_Type
(N
: Node_Id
) return Boolean;
1857 pragma Inline
(Is_Suitable_SPARK_Derived_Type
);
1858 -- Determine whether arbitrary node N denotes a suitable derived type
1859 -- declaration for ABE processing using the SPARK rules.
1861 function Is_Suitable_SPARK_Instantiation
(N
: Node_Id
) return Boolean;
1862 pragma Inline
(Is_Suitable_SPARK_Instantiation
);
1863 -- Determine whether arbitrary node N denotes a suitable instantiation
1864 -- for ABE processing using the SPARK rules.
1866 function Is_Suitable_SPARK_Refined_State_Pragma
1867 (N
: Node_Id
) return Boolean;
1868 pragma Inline
(Is_Suitable_SPARK_Refined_State_Pragma
);
1869 -- Determine whether arbitrary node N denotes a suitable Refined_State
1870 -- pragma for ABE processing using the SPARK rules.
1872 function Is_Suitable_Variable_Assignment
(N
: Node_Id
) return Boolean;
1873 pragma Inline
(Is_Suitable_Variable_Assignment
);
1874 -- Determine whether arbitrary node N denotes a suitable assignment for
1877 function Is_Suitable_Variable_Reference
(N
: Node_Id
) return Boolean;
1878 pragma Inline
(Is_Suitable_Variable_Reference
);
1879 -- Determine whether arbitrary node N is a suitable variable reference
1880 -- for ABE processing.
1882 function Is_Task_Entry
(Id
: Entity_Id
) return Boolean;
1883 pragma Inline
(Is_Task_Entry
);
1884 -- Determine whether arbitrary entity Id denotes a task entry
1886 function Is_Up_Level_Target
1887 (Targ_Decl
: Node_Id
;
1888 In_State
: Processing_In_State
) return Boolean;
1889 pragma Inline
(Is_Up_Level_Target
);
1890 -- Determine whether the current root resides at the declaration level.
1891 -- If this is the case, determine whether a target with by declaration
1892 -- Target_Decl is within a context which encloses the current root or is
1893 -- in a different unit. In_State is the current state of the Processing
1899 -- The following package provides the main entry point for SPARK-related
1900 -- checks and diagnostics.
1902 package SPARK_Processor
is
1908 procedure Check_SPARK_Model_In_Effect
;
1909 pragma Inline
(Check_SPARK_Model_In_Effect
);
1910 -- Determine whether a suitable elaboration model is currently in effect
1911 -- for verifying SPARK rules. Emit a warning if this is not the case.
1913 procedure Check_SPARK_Scenarios
;
1914 pragma Inline
(Check_SPARK_Scenarios
);
1915 -- Examine SPARK scenarios which are not necessarily executable during
1916 -- elaboration, but still requires elaboration-related checks.
1918 end SPARK_Processor
;
1919 use SPARK_Processor
;
1921 -----------------------
1922 -- Local subprograms --
1923 -----------------------
1925 function Assignment_Target
(Asmt
: Node_Id
) return Node_Id
;
1926 pragma Inline
(Assignment_Target
);
1927 -- Obtain the target of assignment statement Asmt
1929 function Call_Name
(Call
: Node_Id
) return Node_Id
;
1930 pragma Inline
(Call_Name
);
1931 -- Obtain the name of an entry, operator, or subprogram call Call
1933 function Canonical_Subprogram
(Subp_Id
: Entity_Id
) return Entity_Id
;
1934 pragma Inline
(Canonical_Subprogram
);
1935 -- Obtain the uniform canonical entity of subprogram Subp_Id
1937 function Compilation_Unit
(Unit_Id
: Entity_Id
) return Node_Id
;
1938 pragma Inline
(Compilation_Unit
);
1939 -- Return the N_Compilation_Unit node of unit Unit_Id
1941 function Elaboration_Phase_Active
return Boolean;
1942 pragma Inline
(Elaboration_Phase_Active
);
1943 -- Determine whether the elaboration phase of the compilation has started
1945 procedure Error_Preelaborated_Call
(N
: Node_Id
);
1946 -- Give an error or warning for a non-static/non-preelaborable call in a
1947 -- preelaborated unit.
1949 procedure Finalize_All_Data_Structures
;
1950 pragma Inline
(Finalize_All_Data_Structures
);
1951 -- Destroy all internal data structures
1953 function Find_Enclosing_Instance
(N
: Node_Id
) return Node_Id
;
1954 pragma Inline
(Find_Enclosing_Instance
);
1955 -- Find the declaration or body of the nearest expanded instance which
1956 -- encloses arbitrary node N. Return Empty if no such instance exists.
1958 function Find_Top_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
;
1959 pragma Inline
(Find_Top_Unit
);
1960 -- Return the top unit which contains arbitrary node or entity N. The unit
1961 -- is obtained by logically unwinding instantiations and subunits when N
1962 -- resides within one.
1964 function Find_Unit_Entity
(N
: Node_Id
) return Entity_Id
;
1965 pragma Inline
(Find_Unit_Entity
);
1966 -- Return the entity of unit N
1968 function First_Formal_Type
(Subp_Id
: Entity_Id
) return Entity_Id
;
1969 pragma Inline
(First_Formal_Type
);
1970 -- Return the type of subprogram Subp_Id's first formal parameter. If the
1971 -- subprogram lacks formal parameters, return Empty.
1973 function Has_Body
(Pack_Decl
: Node_Id
) return Boolean;
1974 pragma Inline
(Has_Body
);
1975 -- Determine whether package declaration Pack_Decl has a corresponding body
1976 -- or would eventually have one.
1978 function In_External_Instance
1980 Target_Decl
: Node_Id
) return Boolean;
1981 pragma Inline
(In_External_Instance
);
1982 -- Determine whether a target desctibed by its declaration Target_Decl
1983 -- resides in a package instance which is external to scenario N.
1985 function In_Main_Context
(N
: Node_Id
) return Boolean;
1986 pragma Inline
(In_Main_Context
);
1987 -- Determine whether arbitrary node N appears within the main compilation
1990 function In_Same_Context
1993 Nested_OK
: Boolean := False) return Boolean;
1994 pragma Inline
(In_Same_Context
);
1995 -- Determine whether two arbitrary nodes N1 and N2 appear within the same
1996 -- context ignoring enclosing library levels. Nested_OK should be set when
1997 -- the context of N1 can enclose that of N2.
1999 procedure Initialize_All_Data_Structures
;
2000 pragma Inline
(Initialize_All_Data_Structures
);
2001 -- Create all internal data structures
2003 function Instantiated_Generic
(Inst
: Node_Id
) return Entity_Id
;
2004 pragma Inline
(Instantiated_Generic
);
2005 -- Obtain the generic instantiated by instance Inst
2007 function Is_Safe_Activation
2009 Task_Rep
: Target_Rep_Id
) return Boolean;
2010 pragma Inline
(Is_Safe_Activation
);
2011 -- Determine whether activation call Call which activates an object of a
2012 -- task type described by representation Task_Rep is always ABE-safe.
2014 function Is_Safe_Call
2016 Subp_Id
: Entity_Id
;
2017 Subp_Rep
: Target_Rep_Id
) return Boolean;
2018 pragma Inline
(Is_Safe_Call
);
2019 -- Determine whether call Call which invokes entry, operator, or subprogram
2020 -- Subp_Id is always ABE-safe. Subp_Rep is the representation of the entry,
2021 -- operator, or subprogram.
2023 function Is_Safe_Instantiation
2026 Gen_Rep
: Target_Rep_Id
) return Boolean;
2027 pragma Inline
(Is_Safe_Instantiation
);
2028 -- Determine whether instantiation Inst which instantiates generic Gen_Id
2029 -- is always ABE-safe. Gen_Rep is the representation of the generic.
2031 function Is_Same_Unit
2032 (Unit_1
: Entity_Id
;
2033 Unit_2
: Entity_Id
) return Boolean;
2034 pragma Inline
(Is_Same_Unit
);
2035 -- Determine whether entities Unit_1 and Unit_2 denote the same unit
2037 function Main_Unit_Entity
return Entity_Id
;
2038 pragma Inline
(Main_Unit_Entity
);
2039 -- Return the entity of the main unit
2041 function Non_Private_View
(Typ
: Entity_Id
) return Entity_Id
;
2042 pragma Inline
(Non_Private_View
);
2043 -- Return the full view of private type Typ if available, otherwise return
2046 function Scenario
(N
: Node_Id
) return Node_Id
;
2047 pragma Inline
(Scenario
);
2048 -- Return the appropriate scenario node for scenario N
2050 procedure Set_Elaboration_Phase
(Status
: Elaboration_Phase_Status
);
2051 pragma Inline
(Set_Elaboration_Phase
);
2052 -- Change the status of the elaboration phase of the compiler to Status
2054 procedure Spec_And_Body_From_Entity
2056 Spec_Decl
: out Node_Id
;
2057 Body_Decl
: out Node_Id
);
2058 pragma Inline
(Spec_And_Body_From_Entity
);
2059 -- Given arbitrary entity Id representing a construct with a spec and body,
2060 -- retrieve declaration of the spec in Spec_Decl and the declaration of the
2061 -- body in Body_Decl.
2063 procedure Spec_And_Body_From_Node
2065 Spec_Decl
: out Node_Id
;
2066 Body_Decl
: out Node_Id
);
2067 pragma Inline
(Spec_And_Body_From_Node
);
2068 -- Given arbitrary node N representing a construct with a spec and body,
2069 -- retrieve declaration of the spec in Spec_Decl and the declaration of
2070 -- the body in Body_Decl.
2072 function Static_Elaboration_Checks
return Boolean;
2073 pragma Inline
(Static_Elaboration_Checks
);
2074 -- Determine whether the static model is in effect
2076 function Unit_Entity
(Unit_Id
: Entity_Id
) return Entity_Id
;
2077 pragma Inline
(Unit_Entity
);
2078 -- Return the entity of the initial declaration for unit Unit_Id
2080 procedure Update_Elaboration_Scenario
(New_N
: Node_Id
; Old_N
: Node_Id
);
2081 pragma Inline
(Update_Elaboration_Scenario
);
2082 -- Update all relevant internal data structures when scenario Old_N is
2083 -- transformed into scenario New_N by Atree.Rewrite.
2085 ----------------------
2086 -- Active_Scenarios --
2087 ----------------------
2089 package body Active_Scenarios
is
2091 -----------------------
2092 -- Local subprograms --
2093 -----------------------
2095 procedure Output_Access_Taken
2097 Attr_Rep
: Scenario_Rep_Id
;
2098 Error_Nod
: Node_Id
);
2099 pragma Inline
(Output_Access_Taken
);
2100 -- Emit a specific diagnostic message for 'Access attribute reference
2101 -- Attr with representation Attr_Rep. The message is associated with
2104 procedure Output_Active_Scenario
2106 Error_Nod
: Node_Id
;
2107 In_State
: Processing_In_State
);
2108 pragma Inline
(Output_Active_Scenario
);
2109 -- Top level dispatcher for outputting a scenario. Emit a specific
2110 -- diagnostic message for scenario N. The message is associated with
2111 -- node Error_Nod. In_State is the current state of the Processing
2114 procedure Output_Call
2116 Call_Rep
: Scenario_Rep_Id
;
2117 Error_Nod
: Node_Id
);
2118 pragma Inline
(Output_Call
);
2119 -- Emit a diagnostic message for call Call with representation Call_Rep.
2120 -- The message is associated with node Error_Nod.
2122 procedure Output_Header
(Error_Nod
: Node_Id
);
2123 pragma Inline
(Output_Header
);
2124 -- Emit a specific diagnostic message for the unit of the root scenario.
2125 -- The message is associated with node Error_Nod.
2127 procedure Output_Instantiation
2129 Inst_Rep
: Scenario_Rep_Id
;
2130 Error_Nod
: Node_Id
);
2131 pragma Inline
(Output_Instantiation
);
2132 -- Emit a specific diagnostic message for instantiation Inst with
2133 -- representation Inst_Rep. The message is associated with node
2136 procedure Output_Refined_State_Pragma
2138 Prag_Rep
: Scenario_Rep_Id
;
2139 Error_Nod
: Node_Id
);
2140 pragma Inline
(Output_Refined_State_Pragma
);
2141 -- Emit a specific diagnostic message for Refined_State pragma Prag
2142 -- with representation Prag_Rep. The message is associated with node
2145 procedure Output_Task_Activation
2147 Call_Rep
: Scenario_Rep_Id
;
2148 Error_Nod
: Node_Id
);
2149 pragma Inline
(Output_Task_Activation
);
2150 -- Emit a specific diagnostic message for activation call Call
2151 -- with representation Call_Rep. The message is associated with
2154 procedure Output_Variable_Assignment
2156 Asmt_Rep
: Scenario_Rep_Id
;
2157 Error_Nod
: Node_Id
);
2158 pragma Inline
(Output_Variable_Assignment
);
2159 -- Emit a specific diagnostic message for assignment statement Asmt
2160 -- with representation Asmt_Rep. The message is associated with node
2163 procedure Output_Variable_Reference
2165 Ref_Rep
: Scenario_Rep_Id
;
2166 Error_Nod
: Node_Id
);
2167 pragma Inline
(Output_Variable_Reference
);
2168 -- Emit a specific diagnostic message for read reference Ref with
2169 -- representation Ref_Rep. The message is associated with node
2176 procedure Output_Access_Taken
2178 Attr_Rep
: Scenario_Rep_Id
;
2179 Error_Nod
: Node_Id
)
2181 Subp_Id
: constant Entity_Id
:= Target
(Attr_Rep
);
2184 Error_Msg_Name_1
:= Attribute_Name
(Attr
);
2185 Error_Msg_Sloc
:= Sloc
(Attr
);
2186 Error_Msg_NE
("\\ % of & taken #", Error_Nod
, Subp_Id
);
2187 end Output_Access_Taken
;
2189 ----------------------------
2190 -- Output_Active_Scenario --
2191 ----------------------------
2193 procedure Output_Active_Scenario
2195 Error_Nod
: Node_Id
;
2196 In_State
: Processing_In_State
)
2198 Scen
: constant Node_Id
:= Scenario
(N
);
2199 Scen_Rep
: Scenario_Rep_Id
;
2204 if Is_Suitable_Access_Taken
(Scen
) then
2207 Attr_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2208 Error_Nod
=> Error_Nod
);
2210 -- Call or task activation
2212 elsif Is_Suitable_Call
(Scen
) then
2213 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
2215 if Kind
(Scen_Rep
) = Call_Scenario
then
2218 Call_Rep
=> Scen_Rep
,
2219 Error_Nod
=> Error_Nod
);
2222 pragma Assert
(Kind
(Scen_Rep
) = Task_Activation_Scenario
);
2224 Output_Task_Activation
2226 Call_Rep
=> Scen_Rep
,
2227 Error_Nod
=> Error_Nod
);
2232 elsif Is_Suitable_Instantiation
(Scen
) then
2233 Output_Instantiation
2235 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2236 Error_Nod
=> Error_Nod
);
2238 -- Pragma Refined_State
2240 elsif Is_Suitable_SPARK_Refined_State_Pragma
(Scen
) then
2241 Output_Refined_State_Pragma
2243 Prag_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2244 Error_Nod
=> Error_Nod
);
2246 -- Variable assignment
2248 elsif Is_Suitable_Variable_Assignment
(Scen
) then
2249 Output_Variable_Assignment
2251 Asmt_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2252 Error_Nod
=> Error_Nod
);
2254 -- Variable reference
2256 elsif Is_Suitable_Variable_Reference
(Scen
) then
2257 Output_Variable_Reference
2259 Ref_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2260 Error_Nod
=> Error_Nod
);
2262 end Output_Active_Scenario
;
2264 -----------------------------
2265 -- Output_Active_Scenarios --
2266 -----------------------------
2268 procedure Output_Active_Scenarios
2269 (Error_Nod
: Node_Id
;
2270 In_State
: Processing_In_State
)
2272 package Scenarios
renames Active_Scenario_Stack
;
2274 Header_Posted
: Boolean := False;
2277 -- Output the contents of the active scenario stack starting from the
2278 -- bottom, or the least recent scenario.
2280 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
2281 if not Header_Posted
then
2282 Output_Header
(Error_Nod
);
2283 Header_Posted
:= True;
2286 Output_Active_Scenario
2287 (N
=> Scenarios
.Table
(Index
),
2288 Error_Nod
=> Error_Nod
,
2289 In_State
=> In_State
);
2291 end Output_Active_Scenarios
;
2297 procedure Output_Call
2299 Call_Rep
: Scenario_Rep_Id
;
2300 Error_Nod
: Node_Id
)
2302 procedure Output_Accept_Alternative
(Alt_Id
: Entity_Id
);
2303 pragma Inline
(Output_Accept_Alternative
);
2304 -- Emit a specific diagnostic message concerning accept alternative
2305 -- with entity Alt_Id.
2307 procedure Output_Call
(Subp_Id
: Entity_Id
; Kind
: String);
2308 pragma Inline
(Output_Call
);
2309 -- Emit a specific diagnostic message concerning a call of kind Kind
2310 -- which invokes subprogram Subp_Id.
2312 procedure Output_Type_Actions
(Subp_Id
: Entity_Id
; Action
: String);
2313 pragma Inline
(Output_Type_Actions
);
2314 -- Emit a specific diagnostic message concerning action Action of a
2315 -- type performed by subprogram Subp_Id.
2317 procedure Output_Verification_Call
2321 pragma Inline
(Output_Verification_Call
);
2322 -- Emit a specific diagnostic message concerning the verification of
2323 -- predicate Pred applied to related entity Id with kind Id_Kind.
2325 -------------------------------
2326 -- Output_Accept_Alternative --
2327 -------------------------------
2329 procedure Output_Accept_Alternative
(Alt_Id
: Entity_Id
) is
2330 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Alt_Id
);
2333 pragma Assert
(Present
(Entry_Id
));
2335 Error_Msg_NE
("\\ entry & selected #", Error_Nod
, Entry_Id
);
2336 end Output_Accept_Alternative
;
2342 procedure Output_Call
(Subp_Id
: Entity_Id
; Kind
: String) is
2344 Error_Msg_NE
("\\ " & Kind
& " & called #", Error_Nod
, Subp_Id
);
2347 -------------------------
2348 -- Output_Type_Actions --
2349 -------------------------
2351 procedure Output_Type_Actions
2352 (Subp_Id
: Entity_Id
;
2355 Typ
: constant Entity_Id
:= First_Formal_Type
(Subp_Id
);
2358 pragma Assert
(Present
(Typ
));
2361 ("\\ " & Action
& " actions for type & #", Error_Nod
, Typ
);
2362 end Output_Type_Actions
;
2364 ------------------------------
2365 -- Output_Verification_Call --
2366 ------------------------------
2368 procedure Output_Verification_Call
2374 pragma Assert
(Present
(Id
));
2377 ("\\ " & Pred
& " of " & Id_Kind
& " & verified #",
2379 end Output_Verification_Call
;
2383 Subp_Id
: constant Entity_Id
:= Target
(Call_Rep
);
2385 -- Start of processing for Output_Call
2388 Error_Msg_Sloc
:= Sloc
(Call
);
2390 -- Accept alternative
2392 if Is_Accept_Alternative_Proc
(Subp_Id
) then
2393 Output_Accept_Alternative
(Subp_Id
);
2397 elsif Is_TSS
(Subp_Id
, TSS_Deep_Adjust
) then
2398 Output_Type_Actions
(Subp_Id
, "adjustment");
2400 -- Default_Initial_Condition
2402 elsif Is_Default_Initial_Condition_Proc
(Subp_Id
) then
2404 -- Only do output for a normal DIC procedure, since partial DIC
2405 -- procedures are subsidiary to those.
2407 if not Is_Partial_DIC_Procedure
(Subp_Id
) then
2408 Output_Verification_Call
2409 (Pred
=> "Default_Initial_Condition",
2410 Id
=> First_Formal_Type
(Subp_Id
),
2416 elsif Is_Protected_Entry
(Subp_Id
) then
2417 Output_Call
(Subp_Id
, "entry");
2419 -- Task entry calls are never processed because the entry being
2420 -- invoked does not have a corresponding "body", it has a select. A
2421 -- task entry call appears in the stack of active scenarios for the
2422 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
2425 elsif Is_Task_Entry
(Subp_Id
) then
2430 elsif Is_TSS
(Subp_Id
, TSS_Deep_Finalize
) then
2431 Output_Type_Actions
(Subp_Id
, "finalization");
2433 -- Calls to _Finalizer procedures must not appear in the output
2434 -- because this creates confusing noise.
2436 elsif Is_Finalizer
(Subp_Id
) then
2439 -- Initial_Condition
2441 elsif Is_Initial_Condition_Proc
(Subp_Id
) then
2442 Output_Verification_Call
2443 (Pred
=> "Initial_Condition",
2444 Id
=> Find_Enclosing_Scope
(Call
),
2445 Id_Kind
=> "package");
2449 elsif Is_Init_Proc
(Subp_Id
)
2450 or else Is_TSS
(Subp_Id
, TSS_Deep_Initialize
)
2452 Output_Type_Actions
(Subp_Id
, "initialization");
2456 elsif Is_Invariant_Proc
(Subp_Id
) then
2457 Output_Verification_Call
2458 (Pred
=> "invariants",
2459 Id
=> First_Formal_Type
(Subp_Id
),
2462 -- Partial invariant calls must not appear in the output because this
2463 -- creates confusing noise. Note that a partial invariant is always
2464 -- invoked by the "full" invariant which is already placed on the
2467 elsif Is_Partial_Invariant_Proc
(Subp_Id
) then
2470 -- Subprograms must come last because some of the previous cases fall
2471 -- under this category.
2473 elsif Ekind
(Subp_Id
) = E_Function
then
2474 Output_Call
(Subp_Id
, "function");
2476 elsif Ekind
(Subp_Id
) = E_Procedure
then
2477 Output_Call
(Subp_Id
, "procedure");
2480 pragma Assert
(False);
2489 procedure Output_Header
(Error_Nod
: Node_Id
) is
2490 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Root_Scenario
);
2493 if Ekind
(Unit_Id
) = E_Package
then
2494 Error_Msg_NE
("\\ spec of unit & elaborated", Error_Nod
, Unit_Id
);
2496 elsif Ekind
(Unit_Id
) = E_Package_Body
then
2497 Error_Msg_NE
("\\ body of unit & elaborated", Error_Nod
, Unit_Id
);
2500 Error_Msg_NE
("\\ in body of unit &", Error_Nod
, Unit_Id
);
2504 --------------------------
2505 -- Output_Instantiation --
2506 --------------------------
2508 procedure Output_Instantiation
2510 Inst_Rep
: Scenario_Rep_Id
;
2511 Error_Nod
: Node_Id
)
2513 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String);
2514 pragma Inline
(Output_Instantiation
);
2515 -- Emit a specific diagnostic message concerning an instantiation of
2516 -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
2518 --------------------------
2519 -- Output_Instantiation --
2520 --------------------------
2522 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String) is
2525 ("\\ " & Kind
& " & instantiated as & #", Error_Nod
, Gen_Id
);
2526 end Output_Instantiation
;
2530 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
2532 -- Start of processing for Output_Instantiation
2535 Error_Msg_Node_2
:= Defining_Entity
(Inst
);
2536 Error_Msg_Sloc
:= Sloc
(Inst
);
2538 if Nkind
(Inst
) = N_Function_Instantiation
then
2539 Output_Instantiation
(Gen_Id
, "function");
2541 elsif Nkind
(Inst
) = N_Package_Instantiation
then
2542 Output_Instantiation
(Gen_Id
, "package");
2544 elsif Nkind
(Inst
) = N_Procedure_Instantiation
then
2545 Output_Instantiation
(Gen_Id
, "procedure");
2548 pragma Assert
(False);
2551 end Output_Instantiation
;
2553 ---------------------------------
2554 -- Output_Refined_State_Pragma --
2555 ---------------------------------
2557 procedure Output_Refined_State_Pragma
2559 Prag_Rep
: Scenario_Rep_Id
;
2560 Error_Nod
: Node_Id
)
2562 pragma Unreferenced
(Prag_Rep
);
2565 Error_Msg_Sloc
:= Sloc
(Prag
);
2566 Error_Msg_N
("\\ refinement constituents read #", Error_Nod
);
2567 end Output_Refined_State_Pragma
;
2569 ----------------------------
2570 -- Output_Task_Activation --
2571 ----------------------------
2573 procedure Output_Task_Activation
2575 Call_Rep
: Scenario_Rep_Id
;
2576 Error_Nod
: Node_Id
)
2578 pragma Unreferenced
(Call_Rep
);
2580 function Find_Activator
return Entity_Id
;
2581 -- Find the nearest enclosing construct which houses call Call
2583 --------------------
2584 -- Find_Activator --
2585 --------------------
2587 function Find_Activator
return Entity_Id
is
2591 -- Climb the parent chain looking for a package [body] or a
2592 -- construct with a statement sequence.
2594 Par
:= Parent
(Call
);
2595 while Present
(Par
) loop
2596 if Nkind
(Par
) in N_Package_Body | N_Package_Declaration
then
2597 return Defining_Entity
(Par
);
2599 elsif Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
2600 return Defining_Entity
(Parent
(Par
));
2603 Par
:= Parent
(Par
);
2611 Activator
: constant Entity_Id
:= Find_Activator
;
2613 -- Start of processing for Output_Task_Activation
2616 pragma Assert
(Present
(Activator
));
2618 Error_Msg_NE
("\\ local tasks of & activated", Error_Nod
, Activator
);
2619 end Output_Task_Activation
;
2621 --------------------------------
2622 -- Output_Variable_Assignment --
2623 --------------------------------
2625 procedure Output_Variable_Assignment
2627 Asmt_Rep
: Scenario_Rep_Id
;
2628 Error_Nod
: Node_Id
)
2630 Var_Id
: constant Entity_Id
:= Target
(Asmt_Rep
);
2633 Error_Msg_Sloc
:= Sloc
(Asmt
);
2634 Error_Msg_NE
("\\ variable & assigned #", Error_Nod
, Var_Id
);
2635 end Output_Variable_Assignment
;
2637 -------------------------------
2638 -- Output_Variable_Reference --
2639 -------------------------------
2641 procedure Output_Variable_Reference
2643 Ref_Rep
: Scenario_Rep_Id
;
2644 Error_Nod
: Node_Id
)
2646 Var_Id
: constant Entity_Id
:= Target
(Ref_Rep
);
2649 Error_Msg_Sloc
:= Sloc
(Ref
);
2650 Error_Msg_NE
("\\ variable & read #", Error_Nod
, Var_Id
);
2651 end Output_Variable_Reference
;
2653 -------------------------
2654 -- Pop_Active_Scenario --
2655 -------------------------
2657 procedure Pop_Active_Scenario
(N
: Node_Id
) is
2658 package Scenarios
renames Active_Scenario_Stack
;
2659 Top
: Node_Id
renames Scenarios
.Table
(Scenarios
.Last
);
2662 pragma Assert
(Top
= N
);
2663 Scenarios
.Decrement_Last
;
2664 end Pop_Active_Scenario
;
2666 --------------------------
2667 -- Push_Active_Scenario --
2668 --------------------------
2670 procedure Push_Active_Scenario
(N
: Node_Id
) is
2672 Active_Scenario_Stack
.Append
(N
);
2673 end Push_Active_Scenario
;
2679 function Root_Scenario
return Node_Id
is
2680 package Scenarios
renames Active_Scenario_Stack
;
2683 -- Ensure that the scenario stack has at least one active scenario in
2684 -- it. The one at the bottom (index First) is the root scenario.
2686 pragma Assert
(Scenarios
.Last
>= Scenarios
.First
);
2687 return Scenarios
.Table
(Scenarios
.First
);
2689 end Active_Scenarios
;
2691 --------------------------
2692 -- Activation_Processor --
2693 --------------------------
2695 package body Activation_Processor
is
2697 ------------------------
2698 -- Process_Activation --
2699 ------------------------
2701 procedure Process_Activation
2703 Call_Rep
: Scenario_Rep_Id
;
2704 Processor
: Activation_Processor_Ptr
;
2705 In_State
: Processing_In_State
)
2707 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
);
2708 pragma Inline
(Process_Task_Object
);
2709 -- Invoke Processor for task object Obj_Id of type Typ
2711 procedure Process_Task_Objects
2712 (Task_Objs
: NE_List
.Doubly_Linked_List
);
2713 pragma Inline
(Process_Task_Objects
);
2714 -- Invoke Processor for all task objects found in list Task_Objs
2716 procedure Traverse_List
2718 Task_Objs
: NE_List
.Doubly_Linked_List
);
2719 pragma Inline
(Traverse_List
);
2720 -- Traverse declarative or statement list List while searching for
2721 -- objects of a task type, or containing task components. If such an
2722 -- object is found, first save it in list Task_Objs and then invoke
2725 -------------------------
2726 -- Process_Task_Object --
2727 -------------------------
2729 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
) is
2730 Root_Typ
: constant Entity_Id
:=
2731 Non_Private_View
(Root_Type
(Typ
));
2732 Comp_Id
: Entity_Id
;
2733 Obj_Rep
: Target_Rep_Id
;
2734 Root_Rep
: Target_Rep_Id
;
2736 New_In_State
: Processing_In_State
:= In_State
;
2737 -- Each step of the Processing phase constitutes a new state
2740 if Is_Task_Type
(Typ
) then
2741 Obj_Rep
:= Target_Representation_Of
(Obj_Id
, New_In_State
);
2742 Root_Rep
:= Target_Representation_Of
(Root_Typ
, New_In_State
);
2744 -- Warnings are suppressed when a prior scenario is already in
2745 -- that mode, or when the object, activation call, or task type
2746 -- have warnings suppressed. Update the state of the Processing
2747 -- phase to reflect this.
2749 New_In_State
.Suppress_Warnings
:=
2750 New_In_State
.Suppress_Warnings
2751 or else not Elaboration_Warnings_OK
(Call_Rep
)
2752 or else not Elaboration_Warnings_OK
(Obj_Rep
)
2753 or else not Elaboration_Warnings_OK
(Root_Rep
);
2755 -- Update the state of the Processing phase to indicate that
2756 -- any further traversal is now within a task body.
2758 New_In_State
.Within_Task_Body
:= True;
2760 -- Associate the current task type with the activation call
2762 Set_Activated_Task_Type
(Call_Rep
, Root_Typ
);
2764 -- Process the activation of the current task object by calling
2765 -- the supplied processor.
2769 Call_Rep
=> Call_Rep
,
2772 Task_Typ
=> Root_Typ
,
2773 Task_Rep
=> Root_Rep
,
2774 In_State
=> New_In_State
);
2776 -- Reset the association between the current task and the
2779 Set_Activated_Task_Type
(Call_Rep
, Empty
);
2781 -- Examine the component type when the object is an array
2783 elsif Is_Array_Type
(Typ
) and then Has_Task
(Root_Typ
) then
2786 Typ
=> Component_Type
(Typ
));
2788 -- Examine individual component types when the object is a record
2790 elsif Is_Record_Type
(Typ
) and then Has_Task
(Root_Typ
) then
2791 Comp_Id
:= First_Component
(Typ
);
2792 while Present
(Comp_Id
) loop
2795 Typ
=> Etype
(Comp_Id
));
2797 Next_Component
(Comp_Id
);
2800 end Process_Task_Object
;
2802 --------------------------
2803 -- Process_Task_Objects --
2804 --------------------------
2806 procedure Process_Task_Objects
2807 (Task_Objs
: NE_List
.Doubly_Linked_List
)
2809 Iter
: NE_List
.Iterator
;
2813 Iter
:= NE_List
.Iterate
(Task_Objs
);
2814 while NE_List
.Has_Next
(Iter
) loop
2815 NE_List
.Next
(Iter
, Obj_Id
);
2819 Typ
=> Etype
(Obj_Id
));
2821 end Process_Task_Objects
;
2827 procedure Traverse_List
2829 Task_Objs
: NE_List
.Doubly_Linked_List
)
2832 Item_Id
: Entity_Id
;
2833 Item_Typ
: Entity_Id
;
2836 -- Examine the contents of the list looking for an object
2837 -- declaration of a task type or one that contains a task
2840 Item
:= First
(List
);
2841 while Present
(Item
) loop
2842 if Nkind
(Item
) = N_Object_Declaration
then
2843 Item_Id
:= Defining_Entity
(Item
);
2844 Item_Typ
:= Etype
(Item_Id
);
2846 if Has_Task
(Item_Typ
) then
2848 -- The object is either of a task type, or contains a
2849 -- task component. Save it in the list of task objects
2850 -- associated with the activation call.
2852 NE_List
.Append
(Task_Objs
, Item_Id
);
2868 Task_Objs
: NE_List
.Doubly_Linked_List
;
2870 -- Start of processing for Process_Activation
2873 -- Nothing to do when the activation is a guaranteed ABE
2875 if Is_Known_Guaranteed_ABE
(Call
) then
2879 Task_Objs
:= Activated_Task_Objects
(Call_Rep
);
2881 -- The activation call has been processed at least once, and all
2882 -- task objects have already been collected. Directly process the
2883 -- objects without having to reexamine the context of the call.
2885 if NE_List
.Present
(Task_Objs
) then
2886 Process_Task_Objects
(Task_Objs
);
2888 -- Otherwise the activation call is being processed for the first
2889 -- time. Collect all task objects in case the call is reprocessed
2893 Task_Objs
:= NE_List
.Create
;
2894 Set_Activated_Task_Objects
(Call_Rep
, Task_Objs
);
2896 -- Find the context of the activation call where all task objects
2897 -- being activated are declared. This is usually the parent of the
2900 Context
:= Parent
(Call
);
2902 -- Handle the case where the activation call appears within the
2903 -- handled statements of a block or a body.
2905 if Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
2906 Context
:= Parent
(Context
);
2909 -- Process all task objects in both the spec and body when the
2910 -- activation call appears in a package body.
2912 if Nkind
(Context
) = N_Package_Body
then
2915 (Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
2918 (List
=> Visible_Declarations
(Spec
),
2919 Task_Objs
=> Task_Objs
);
2922 (List
=> Private_Declarations
(Spec
),
2923 Task_Objs
=> Task_Objs
);
2926 (List
=> Declarations
(Context
),
2927 Task_Objs
=> Task_Objs
);
2929 -- Process all task objects in the spec when the activation call
2930 -- appears in a package spec.
2932 elsif Nkind
(Context
) = N_Package_Specification
then
2934 (List
=> Visible_Declarations
(Context
),
2935 Task_Objs
=> Task_Objs
);
2938 (List
=> Private_Declarations
(Context
),
2939 Task_Objs
=> Task_Objs
);
2941 -- Otherwise the context must be a block or a body. Process all
2942 -- task objects found in the declarations.
2947 N_Block_Statement | N_Entry_Body | N_Protected_Body |
2948 N_Subprogram_Body | N_Task_Body
);
2951 (List
=> Declarations
(Context
),
2952 Task_Objs
=> Task_Objs
);
2955 end Process_Activation
;
2956 end Activation_Processor
;
2958 -----------------------
2959 -- Assignment_Target --
2960 -----------------------
2962 function Assignment_Target
(Asmt
: Node_Id
) return Node_Id
is
2968 -- When the name denotes an array or record component, find the whole
2971 while Nkind
(Nam
) in
2972 N_Explicit_Dereference | N_Indexed_Component |
2973 N_Selected_Component | N_Slice
2975 Nam
:= Prefix
(Nam
);
2979 end Assignment_Target
;
2981 --------------------
2982 -- Body_Processor --
2983 --------------------
2985 package body Body_Processor
is
2987 ---------------------
2988 -- Data structures --
2989 ---------------------
2991 -- The following map relates scenario lists to subprogram bodies
2993 Nested_Scenarios_Map
: NE_List_Map
.Dynamic_Hash_Table
:= NE_List_Map
.Nil
;
2995 -- The following set contains all subprogram bodies that have been
2996 -- processed by routine Traverse_Body.
2998 Traversed_Bodies_Set
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
3000 -----------------------
3001 -- Local subprograms --
3002 -----------------------
3004 function Is_Traversed_Body
(N
: Node_Id
) return Boolean;
3005 pragma Inline
(Is_Traversed_Body
);
3006 -- Determine whether subprogram body N has already been traversed
3008 function Nested_Scenarios
3009 (N
: Node_Id
) return NE_List
.Doubly_Linked_List
;
3010 pragma Inline
(Nested_Scenarios
);
3011 -- Obtain the list of scenarios associated with subprogram body N
3013 procedure Set_Is_Traversed_Body
(N
: Node_Id
);
3014 pragma Inline
(Set_Is_Traversed_Body
);
3015 -- Mark subprogram body N as traversed
3017 procedure Set_Nested_Scenarios
3019 Scenarios
: NE_List
.Doubly_Linked_List
);
3020 pragma Inline
(Set_Nested_Scenarios
);
3021 -- Associate scenario list Scenarios with subprogram body N
3023 -----------------------------
3024 -- Finalize_Body_Processor --
3025 -----------------------------
3027 procedure Finalize_Body_Processor
is
3029 NE_List_Map
.Destroy
(Nested_Scenarios_Map
);
3030 NE_Set
.Destroy
(Traversed_Bodies_Set
);
3031 end Finalize_Body_Processor
;
3033 -------------------------------
3034 -- Initialize_Body_Processor --
3035 -------------------------------
3037 procedure Initialize_Body_Processor
is
3039 Nested_Scenarios_Map
:= NE_List_Map
.Create
(250);
3040 Traversed_Bodies_Set
:= NE_Set
.Create
(250);
3041 end Initialize_Body_Processor
;
3043 -----------------------
3044 -- Is_Traversed_Body --
3045 -----------------------
3047 function Is_Traversed_Body
(N
: Node_Id
) return Boolean is
3048 pragma Assert
(Present
(N
));
3050 return NE_Set
.Contains
(Traversed_Bodies_Set
, N
);
3051 end Is_Traversed_Body
;
3053 ----------------------
3054 -- Nested_Scenarios --
3055 ----------------------
3057 function Nested_Scenarios
3058 (N
: Node_Id
) return NE_List
.Doubly_Linked_List
3060 pragma Assert
(Present
(N
));
3061 pragma Assert
(Nkind
(N
) = N_Subprogram_Body
);
3064 return NE_List_Map
.Get
(Nested_Scenarios_Map
, N
);
3065 end Nested_Scenarios
;
3067 ----------------------------
3068 -- Reset_Traversed_Bodies --
3069 ----------------------------
3071 procedure Reset_Traversed_Bodies
is
3073 NE_Set
.Reset
(Traversed_Bodies_Set
);
3074 end Reset_Traversed_Bodies
;
3076 ---------------------------
3077 -- Set_Is_Traversed_Body --
3078 ---------------------------
3080 procedure Set_Is_Traversed_Body
(N
: Node_Id
) is
3081 pragma Assert
(Present
(N
));
3084 NE_Set
.Insert
(Traversed_Bodies_Set
, N
);
3085 end Set_Is_Traversed_Body
;
3087 --------------------------
3088 -- Set_Nested_Scenarios --
3089 --------------------------
3091 procedure Set_Nested_Scenarios
3093 Scenarios
: NE_List
.Doubly_Linked_List
)
3095 pragma Assert
(Present
(N
));
3097 NE_List_Map
.Put
(Nested_Scenarios_Map
, N
, Scenarios
);
3098 end Set_Nested_Scenarios
;
3104 procedure Traverse_Body
3106 Requires_Processing
: Scenario_Predicate_Ptr
;
3107 Processor
: Scenario_Processor_Ptr
;
3108 In_State
: Processing_In_State
)
3110 Scenarios
: NE_List
.Doubly_Linked_List
:= NE_List
.Nil
;
3111 -- The list of scenarios that appear within the declarations and
3112 -- statement of subprogram body N. The variable is intentionally
3113 -- global because Is_Potential_Scenario needs to populate it.
3115 function In_Task_Body
(Nod
: Node_Id
) return Boolean;
3116 pragma Inline
(In_Task_Body
);
3117 -- Determine whether arbitrary node Nod appears within a task body
3119 function Is_Synchronous_Suspension_Call
3120 (Nod
: Node_Id
) return Boolean;
3121 pragma Inline
(Is_Synchronous_Suspension_Call
);
3122 -- Determine whether arbitrary node Nod denotes a call to one of
3125 -- Ada.Synchronous_Barriers.Wait_For_Release
3126 -- Ada.Synchronous_Task_Control.Suspend_Until_True
3128 procedure Traverse_Collected_Scenarios
;
3129 pragma Inline
(Traverse_Collected_Scenarios
);
3130 -- Traverse the already collected scenarios in list Scenarios by
3131 -- invoking Processor on each individual one.
3133 procedure Traverse_List
(List
: List_Id
);
3134 pragma Inline
(Traverse_List
);
3135 -- Invoke Traverse_Potential_Scenarios on each node in list List
3137 function Traverse_Potential_Scenario
3138 (Scen
: Node_Id
) return Traverse_Result
;
3139 pragma Inline
(Traverse_Potential_Scenario
);
3140 -- Determine whether arbitrary node Scen is a suitable scenario using
3141 -- predicate Is_Scenario and traverse it by invoking Processor on it.
3143 procedure Traverse_Potential_Scenarios
is
3144 new Traverse_Proc
(Traverse_Potential_Scenario
);
3150 function In_Task_Body
(Nod
: Node_Id
) return Boolean is
3154 -- Climb the parent chain looking for a task body [procedure]
3157 while Present
(Par
) loop
3158 if Nkind
(Par
) = N_Task_Body
then
3161 elsif Nkind
(Par
) = N_Subprogram_Body
3162 and then Is_Task_Body_Procedure
(Par
)
3166 -- Prevent the search from going too far. Note that this test
3167 -- shares nodes with the two cases above, and must come last.
3169 elsif Is_Body_Or_Package_Declaration
(Par
) then
3173 Par
:= Parent
(Par
);
3179 ------------------------------------
3180 -- Is_Synchronous_Suspension_Call --
3181 ------------------------------------
3183 function Is_Synchronous_Suspension_Call
3184 (Nod
: Node_Id
) return Boolean
3186 Subp_Id
: Entity_Id
;
3189 -- To qualify, the call must invoke one of the runtime routines
3190 -- which perform synchronous suspension.
3192 if Is_Suitable_Call
(Nod
) then
3193 Subp_Id
:= Target
(Nod
);
3196 Is_RTE
(Subp_Id
, RE_Suspend_Until_True
)
3198 Is_RTE
(Subp_Id
, RE_Wait_For_Release
);
3202 end Is_Synchronous_Suspension_Call
;
3204 ----------------------------------
3205 -- Traverse_Collected_Scenarios --
3206 ----------------------------------
3208 procedure Traverse_Collected_Scenarios
is
3209 Iter
: NE_List
.Iterator
;
3213 Iter
:= NE_List
.Iterate
(Scenarios
);
3214 while NE_List
.Has_Next
(Iter
) loop
3215 NE_List
.Next
(Iter
, Scen
);
3217 -- The current scenario satisfies the input predicate, process
3220 if Requires_Processing
.all (Scen
) then
3221 Processor
.all (Scen
, In_State
);
3224 end Traverse_Collected_Scenarios
;
3230 procedure Traverse_List
(List
: List_Id
) is
3234 Scen
:= First
(List
);
3235 while Present
(Scen
) loop
3236 Traverse_Potential_Scenarios
(Scen
);
3241 ---------------------------------
3242 -- Traverse_Potential_Scenario --
3243 ---------------------------------
3245 function Traverse_Potential_Scenario
3246 (Scen
: Node_Id
) return Traverse_Result
3251 -- Skip constructs which do not have elaboration of their own and
3252 -- need to be elaborated by other means such as invocation, task
3255 if Is_Non_Library_Level_Encapsulator
(Scen
) then
3258 -- Terminate the traversal of a task body when encountering an
3259 -- accept or select statement, and
3261 -- * Entry calls during elaboration are not allowed. In this
3262 -- case the accept or select statement will cause the task
3263 -- to block at elaboration time because there are no entry
3264 -- calls to unblock it.
3268 -- * Switch -gnatd_a (stop elaboration checks on accept or
3269 -- select statement) is in effect.
3271 elsif (Debug_Flag_Underscore_A
3272 or else Restriction_Active
3273 (No_Entry_Calls_In_Elaboration_Code
))
3274 and then Nkind
(Original_Node
(Scen
)) in
3275 N_Accept_Statement | N_Selective_Accept
3279 -- Terminate the traversal of a task body when encountering a
3280 -- suspension call, and
3282 -- * Entry calls during elaboration are not allowed. In this
3283 -- case the suspension call emulates an entry call and will
3284 -- cause the task to block at elaboration time.
3288 -- * Switch -gnatd_s (stop elaboration checks on synchronous
3289 -- suspension) is in effect.
3291 -- Note that the guard should not be checking the state of flag
3292 -- Within_Task_Body because only suspension calls which appear
3293 -- immediately within the statements of the task are supported.
3294 -- Flag Within_Task_Body carries over to deeper levels of the
3297 elsif (Debug_Flag_Underscore_S
3298 or else Restriction_Active
3299 (No_Entry_Calls_In_Elaboration_Code
))
3300 and then Is_Synchronous_Suspension_Call
(Scen
)
3301 and then In_Task_Body
(Scen
)
3305 -- Certain nodes carry semantic lists which act as repositories
3306 -- until expansion transforms the node and relocates the contents.
3307 -- Examine these lists in case expansion is disabled.
3309 elsif Nkind
(Scen
) in N_And_Then | N_Or_Else
then
3310 Traverse_List
(Actions
(Scen
));
3312 elsif Nkind
(Scen
) in N_Elsif_Part | N_Iteration_Scheme
then
3313 Traverse_List
(Condition_Actions
(Scen
));
3315 elsif Nkind
(Scen
) = N_If_Expression
then
3316 Traverse_List
(Then_Actions
(Scen
));
3317 Traverse_List
(Else_Actions
(Scen
));
3319 elsif Nkind
(Scen
) in
3320 N_Component_Association
3321 | N_Iterated_Component_Association
3322 | N_Iterated_Element_Association
3324 Traverse_List
(Loop_Actions
(Scen
));
3328 -- The current node satisfies the input predicate, process it
3330 elsif Requires_Processing
.all (Scen
) then
3331 Processor
.all (Scen
, In_State
);
3334 -- Save a general scenario regardless of whether it satisfies the
3335 -- input predicate. This allows for quick subsequent traversals of
3336 -- general scenarios, even with different predicates.
3338 if Is_Suitable_Access_Taken
(Scen
)
3339 or else Is_Suitable_Call
(Scen
)
3340 or else Is_Suitable_Instantiation
(Scen
)
3341 or else Is_Suitable_Variable_Assignment
(Scen
)
3342 or else Is_Suitable_Variable_Reference
(Scen
)
3344 NE_List
.Append
(Scenarios
, Scen
);
3348 end Traverse_Potential_Scenario
;
3350 -- Start of processing for Traverse_Body
3353 -- Nothing to do when the traversal is suppressed
3355 if In_State
.Traversal
= No_Traversal
then
3358 -- Nothing to do when there is no input
3363 -- Nothing to do when the input is not a subprogram body
3365 elsif Nkind
(N
) /= N_Subprogram_Body
then
3368 -- Nothing to do if the subprogram body was already traversed
3370 elsif Is_Traversed_Body
(N
) then
3374 -- Mark the subprogram body as traversed
3376 Set_Is_Traversed_Body
(N
);
3378 Scenarios
:= Nested_Scenarios
(N
);
3380 -- The subprogram body has been traversed at least once, and all
3381 -- scenarios that appear within its declarations and statements
3382 -- have already been collected. Directly retraverse the scenarios
3383 -- without having to retraverse the subprogram body subtree.
3385 if NE_List
.Present
(Scenarios
) then
3386 Traverse_Collected_Scenarios
;
3388 -- Otherwise the subprogram body is being traversed for the first
3389 -- time. Collect all scenarios that appear within its declarations
3390 -- and statements in case the subprogram body has to be retraversed
3394 Scenarios
:= NE_List
.Create
;
3395 Set_Nested_Scenarios
(N
, Scenarios
);
3397 Traverse_List
(Declarations
(N
));
3398 Traverse_Potential_Scenarios
(Handled_Statement_Sequence
(N
));
3403 -----------------------
3404 -- Build_Call_Marker --
3405 -----------------------
3407 procedure Build_Call_Marker
(N
: Node_Id
) is
3408 function In_External_Context
3410 Subp_Id
: Entity_Id
) return Boolean;
3411 pragma Inline
(In_External_Context
);
3412 -- Determine whether entry, operator, or subprogram Subp_Id is external
3413 -- to call Call which must reside within an instance.
3415 function In_Premature_Context
(Call
: Node_Id
) return Boolean;
3416 pragma Inline
(In_Premature_Context
);
3417 -- Determine whether call Call appears within a premature context
3419 function Is_Default_Expression
(Call
: Node_Id
) return Boolean;
3420 pragma Inline
(Is_Default_Expression
);
3421 -- Determine whether call Call acts as the expression of a defaulted
3422 -- parameter within a source call.
3424 function Is_Generic_Formal_Subp
(Subp_Id
: Entity_Id
) return Boolean;
3425 pragma Inline
(Is_Generic_Formal_Subp
);
3426 -- Determine whether subprogram Subp_Id denotes a generic formal
3427 -- subprogram which appears in the "prologue" of an instantiation.
3429 -------------------------
3430 -- In_External_Context --
3431 -------------------------
3433 function In_External_Context
3435 Subp_Id
: Entity_Id
) return Boolean
3437 Spec_Decl
: constant Entity_Id
:= Unit_Declaration_Node
(Subp_Id
);
3440 Inst_Body
: Node_Id
;
3441 Inst_Spec
: Node_Id
;
3444 Inst
:= Find_Enclosing_Instance
(Call
);
3446 -- The call appears within an instance
3448 if Present
(Inst
) then
3450 -- The call comes from the main unit and the target does not
3452 if In_Extended_Main_Code_Unit
(Call
)
3453 and then not In_Extended_Main_Code_Unit
(Spec_Decl
)
3457 -- Otherwise the target declaration must not appear within the
3458 -- instance spec or body.
3461 Spec_And_Body_From_Node
3463 Spec_Decl
=> Inst_Spec
,
3464 Body_Decl
=> Inst_Body
);
3466 return not In_Subtree
3469 Root2
=> Inst_Body
);
3474 end In_External_Context
;
3476 --------------------------
3477 -- In_Premature_Context --
3478 --------------------------
3480 function In_Premature_Context
(Call
: Node_Id
) return Boolean is
3484 -- Climb the parent chain looking for premature contexts
3486 Par
:= Parent
(Call
);
3487 while Present
(Par
) loop
3489 -- Aspect specifications and generic associations are premature
3490 -- contexts because nested calls has not been relocated to their
3493 if Nkind
(Par
) in N_Aspect_Specification | N_Generic_Association
3497 -- Prevent the search from going too far
3499 elsif Is_Body_Or_Package_Declaration
(Par
) then
3503 Par
:= Parent
(Par
);
3507 end In_Premature_Context
;
3509 ---------------------------
3510 -- Is_Default_Expression --
3511 ---------------------------
3513 function Is_Default_Expression
(Call
: Node_Id
) return Boolean is
3514 Outer_Call
: constant Node_Id
:= Parent
(Call
);
3515 Outer_Nam
: Node_Id
;
3518 -- To qualify, the node must appear immediately within a source call
3519 -- which invokes a source target.
3521 if Nkind
(Outer_Call
) in N_Entry_Call_Statement
3523 | N_Procedure_Call_Statement
3524 and then Comes_From_Source
(Outer_Call
)
3526 Outer_Nam
:= Call_Name
(Outer_Call
);
3529 Is_Entity_Name
(Outer_Nam
)
3530 and then Present
(Entity
(Outer_Nam
))
3531 and then Is_Subprogram_Or_Entry
(Entity
(Outer_Nam
))
3532 and then Comes_From_Source
(Entity
(Outer_Nam
));
3536 end Is_Default_Expression
;
3538 ----------------------------
3539 -- Is_Generic_Formal_Subp --
3540 ----------------------------
3542 function Is_Generic_Formal_Subp
(Subp_Id
: Entity_Id
) return Boolean is
3543 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
3544 Context
: constant Node_Id
:= Parent
(Subp_Decl
);
3547 -- To qualify, the subprogram must rename a generic actual subprogram
3548 -- where the enclosing context is an instantiation.
3551 Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
3552 and then not Comes_From_Source
(Subp_Decl
)
3553 and then Nkind
(Context
) in N_Function_Specification
3554 | N_Package_Specification
3555 | N_Procedure_Specification
3556 and then Present
(Generic_Parent
(Context
));
3557 end Is_Generic_Formal_Subp
;
3563 Subp_Id
: Entity_Id
;
3565 -- Start of processing for Build_Call_Marker
3568 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
3569 -- enabled) is in effect because the legacy ABE mechanism does not need
3570 -- to carry out this action.
3572 if Legacy_Elaboration_Checks
then
3575 -- Nothing to do when the call is being preanalyzed as the marker will
3576 -- be inserted in the wrong place.
3578 elsif Preanalysis_Active
then
3581 -- Nothing to do when the elaboration phase of the compiler is not
3584 elsif not Elaboration_Phase_Active
then
3587 -- Nothing to do when the input does not denote a call or a requeue
3589 elsif Nkind
(N
) not in N_Entry_Call_Statement
3591 | N_Procedure_Call_Statement
3592 | N_Requeue_Statement
3596 -- Nothing to do when the input denotes entry call or requeue statement,
3597 -- and switch -gnatd_e (ignore entry calls and requeue statements for
3598 -- elaboration) is in effect.
3600 elsif Debug_Flag_Underscore_E
3601 and then Nkind
(N
) in N_Entry_Call_Statement | N_Requeue_Statement
3605 -- Nothing to do when the call is analyzed/resolved too early within an
3606 -- intermediate context. This check is saved for last because it incurs
3607 -- a performance penalty.
3609 elsif In_Premature_Context
(N
) then
3613 Call_Nam
:= Call_Name
(N
);
3615 -- Nothing to do when the call is erroneous or left in a bad state
3617 if not (Is_Entity_Name
(Call_Nam
)
3618 and then Present
(Entity
(Call_Nam
))
3619 and then Is_Subprogram_Or_Entry
(Entity
(Call_Nam
)))
3624 Subp_Id
:= Canonical_Subprogram
(Entity
(Call_Nam
));
3626 -- Nothing to do when the call invokes a generic formal subprogram and
3627 -- switch -gnatd.G (ignore calls through generic formal parameters for
3628 -- elaboration) is in effect. This check must be performed with the
3629 -- direct target of the call to avoid the side effects of mapping
3630 -- actuals to formals using renamings.
3632 if Debug_Flag_Dot_GG
3633 and then Is_Generic_Formal_Subp
(Entity
(Call_Nam
))
3637 -- Nothing to do when the call appears within the expanded spec or
3638 -- body of an instantiated generic, the call does not invoke a generic
3639 -- formal subprogram, the target is external to the instance, and switch
3640 -- -gnatdL (ignore external calls from instances for elaboration) is in
3641 -- effect. This check must be performed with the direct target of the
3642 -- call to avoid the side effects of mapping actuals to formals using
3646 and then not Is_Generic_Formal_Subp
(Entity
(Call_Nam
))
3647 and then In_External_Context
3653 -- Nothing to do when the call invokes an assertion pragma procedure
3654 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is
3657 elsif Debug_Flag_Underscore_P
3658 and then Is_Assertion_Pragma_Target
(Subp_Id
)
3662 -- Static expression functions require no ABE processing
3664 elsif Is_Static_Function
(Subp_Id
) then
3667 -- Source calls to source targets are always considered because they
3668 -- reflect the original call graph.
3670 elsif Comes_From_Source
(N
) and then Comes_From_Source
(Subp_Id
) then
3673 -- A call to a source function which acts as the default expression in
3674 -- another call requires special detection.
3676 elsif Comes_From_Source
(Subp_Id
)
3677 and then Nkind
(N
) = N_Function_Call
3678 and then Is_Default_Expression
(N
)
3682 -- The target emulates Ada semantics
3684 elsif Is_Ada_Semantic_Target
(Subp_Id
) then
3687 -- The target acts as a link between scenarios
3689 elsif Is_Bridge_Target
(Subp_Id
) then
3692 -- The target emulates SPARK semantics
3694 elsif Is_SPARK_Semantic_Target
(Subp_Id
) then
3697 -- Otherwise the call is not suitable for ABE processing. This prevents
3698 -- the generation of call markers which will never play a role in ABE
3705 -- At this point it is known that the call will play some role in ABE
3706 -- checks and diagnostics. Create a corresponding call marker in case
3707 -- the original call is heavily transformed by expansion later on.
3709 Marker
:= Make_Call_Marker
(Sloc
(N
));
3711 -- Inherit the attributes of the original call
3713 Set_Is_Declaration_Level_Node
3714 (Marker
, Find_Enclosing_Level
(N
) = Declaration_Level
);
3716 Set_Is_Dispatching_Call
3718 Nkind
(N
) in N_Subprogram_Call
3719 and then Present
(Controlling_Argument
(N
)));
3721 Set_Is_Elaboration_Checks_OK_Node
3722 (Marker
, Is_Elaboration_Checks_OK_Node
(N
));
3724 Set_Is_Elaboration_Warnings_OK_Node
3725 (Marker
, Is_Elaboration_Warnings_OK_Node
(N
));
3727 Set_Is_Ignored_Ghost_Node
(Marker
, Is_Ignored_Ghost_Node
(N
));
3728 Set_Is_Source_Call
(Marker
, Comes_From_Source
(N
));
3729 Set_Is_SPARK_Mode_On_Node
(Marker
, Is_SPARK_Mode_On_Node
(N
));
3730 Set_Target
(Marker
, Subp_Id
);
3732 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
3733 -- unchecked conversions are preelaborable.
3735 if Ada_Version
>= Ada_2022
then
3736 Set_Is_Preelaborable_Call
(Marker
, Is_Preelaborable_Construct
(N
));
3738 Set_Is_Preelaborable_Call
(Marker
, False);
3741 -- The marker is inserted prior to the original call. This placement has
3742 -- several desirable effects:
3744 -- 1) The marker appears in the same context, in close proximity to
3750 -- 2) Inserting the marker prior to the call ensures that an ABE check
3751 -- will take effect prior to the call.
3757 -- 3) The above two properties are preserved even when the call is a
3758 -- function which is subsequently relocated in order to capture its
3759 -- result. Note that if the call is relocated to a new context, the
3760 -- relocated call will receive a marker of its own.
3764 -- Temp : ... := Func_Call ...;
3767 -- The insertion must take place even when the call does not occur in
3768 -- the main unit to keep the tree symmetric. This ensures that internal
3769 -- name serialization is consistent in case the call marker causes the
3770 -- tree to transform in some way.
3772 Insert_Action
(N
, Marker
);
3774 -- The marker becomes the "corresponding" scenario for the call. Save
3775 -- the marker for later processing by the ABE phase.
3777 Record_Elaboration_Scenario
(Marker
);
3778 end Build_Call_Marker
;
3780 -------------------------------------
3781 -- Build_Variable_Reference_Marker --
3782 -------------------------------------
3784 procedure Build_Variable_Reference_Marker
3789 function Ultimate_Variable
(Var_Id
: Entity_Id
) return Entity_Id
;
3790 pragma Inline
(Ultimate_Variable
);
3791 -- Obtain the ultimate renamed variable of variable Var_Id
3793 -----------------------
3794 -- Ultimate_Variable --
3795 -----------------------
3797 function Ultimate_Variable
(Var_Id
: Entity_Id
) return Entity_Id
is
3798 pragma Assert
(Ekind
(Var_Id
) = E_Variable
);
3802 while Present
(Renamed_Object
(Ren_Id
))
3803 and then Nkind
(Renamed_Object
(Ren_Id
)) in N_Entity
3805 Ren_Id
:= Renamed_Object
(Ren_Id
);
3809 end Ultimate_Variable
;
3813 Var_Id
: constant Entity_Id
:= Ultimate_Variable
(Entity
(N
));
3816 -- Start of processing for Build_Variable_Reference_Marker
3819 -- Nothing to do when the elaboration phase of the compiler is not
3822 if not Elaboration_Phase_Active
then
3826 Marker
:= Make_Variable_Reference_Marker
(Sloc
(N
));
3828 -- Inherit the attributes of the original variable reference
3830 Set_Is_Elaboration_Checks_OK_Node
3831 (Marker
, Is_Elaboration_Checks_OK_Node
(N
));
3833 Set_Is_Elaboration_Warnings_OK_Node
3834 (Marker
, Is_Elaboration_Warnings_OK_Node
(N
));
3836 Set_Is_Read
(Marker
, Read
);
3837 Set_Is_SPARK_Mode_On_Node
(Marker
, Is_SPARK_Mode_On_Node
(N
));
3838 Set_Is_Write
(Marker
, Write
);
3839 Set_Target
(Marker
, Var_Id
);
3841 -- The marker is inserted prior to the original variable reference. The
3842 -- insertion must take place even when the reference does not occur in
3843 -- the main unit to keep the tree symmetric. This ensures that internal
3844 -- name serialization is consistent in case the variable marker causes
3845 -- the tree to transform in some way.
3847 Insert_Action
(N
, Marker
);
3849 -- The marker becomes the "corresponding" scenario for the reference.
3850 -- Save the marker for later processing for the ABE phase.
3852 Record_Elaboration_Scenario
(Marker
);
3853 end Build_Variable_Reference_Marker
;
3859 function Call_Name
(Call
: Node_Id
) return Node_Id
is
3865 -- When the call invokes an entry family, the name appears as an indexed
3868 if Nkind
(Nam
) = N_Indexed_Component
then
3869 Nam
:= Prefix
(Nam
);
3872 -- When the call employs the object.operation form, the name appears as
3873 -- a selected component.
3875 if Nkind
(Nam
) = N_Selected_Component
then
3876 Nam
:= Selector_Name
(Nam
);
3882 --------------------------
3883 -- Canonical_Subprogram --
3884 --------------------------
3886 function Canonical_Subprogram
(Subp_Id
: Entity_Id
) return Entity_Id
is
3887 Canon_Id
: Entity_Id
;
3890 Canon_Id
:= Subp_Id
;
3892 -- Use the original protected subprogram when dealing with one of the
3893 -- specialized lock-manipulating versions.
3895 if Is_Protected_Body_Subp
(Canon_Id
) then
3896 Canon_Id
:= Protected_Subprogram
(Canon_Id
);
3899 -- Obtain the original subprogram except when the subprogram is also
3900 -- an instantiation. In this case the alias is the internally generated
3901 -- subprogram which appears within the anonymous package created for the
3902 -- instantiation, making it unuitable.
3904 if not Is_Generic_Instance
(Canon_Id
) then
3905 Canon_Id
:= Get_Renamed_Entity
(Canon_Id
);
3909 end Canonical_Subprogram
;
3911 ---------------------------------
3912 -- Check_Elaboration_Scenarios --
3913 ---------------------------------
3915 procedure Check_Elaboration_Scenarios
is
3916 Iter
: NE_Set
.Iterator
;
3919 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
3920 -- enabled) is in effect because the legacy ABE mechanism does not need
3921 -- to carry out this action.
3923 if Legacy_Elaboration_Checks
then
3924 Finalize_All_Data_Structures
;
3927 -- Nothing to do when the elaboration phase of the compiler is not
3930 elsif not Elaboration_Phase_Active
then
3931 Finalize_All_Data_Structures
;
3935 -- Restore the original elaboration model which was in effect when the
3936 -- scenarios were first recorded. The model may be specified by pragma
3937 -- Elaboration_Checks which appears on the initial declaration of the
3940 Install_Elaboration_Model
(Unit_Entity
(Main_Unit_Entity
));
3942 -- Examine the context of the main unit and record all units with prior
3943 -- elaboration with respect to it.
3945 Collect_Elaborated_Units
;
3947 -- Examine all scenarios saved during the Recording phase applying the
3948 -- Ada or SPARK elaboration rules in order to detect and diagnose ABE
3949 -- issues, install conditional ABE checks, and ensure the elaboration
3952 Iter
:= Iterate_Declaration_Scenarios
;
3953 Check_Conditional_ABE_Scenarios
(Iter
);
3955 Iter
:= Iterate_Library_Body_Scenarios
;
3956 Check_Conditional_ABE_Scenarios
(Iter
);
3958 Iter
:= Iterate_Library_Spec_Scenarios
;
3959 Check_Conditional_ABE_Scenarios
(Iter
);
3961 -- Examine each SPARK scenario saved during the Recording phase which
3962 -- is not necessarily executable during elaboration, but still requires
3963 -- elaboration-related checks.
3965 Check_SPARK_Scenarios
;
3967 -- Add conditional ABE checks for all scenarios that require one when
3968 -- the dynamic model is in effect.
3970 Install_Dynamic_ABE_Checks
;
3972 -- Examine all scenarios saved during the Recording phase along with
3973 -- invocation constructs within the spec and body of the main unit.
3974 -- Record the declarations and paths that reach into an external unit
3975 -- in the ALI file of the main unit.
3977 Record_Invocation_Graph
;
3979 -- Destroy all internal data structures and complete the elaboration
3980 -- phase of the compiler.
3982 Finalize_All_Data_Structures
;
3983 Set_Elaboration_Phase
(Completed
);
3984 end Check_Elaboration_Scenarios
;
3986 ---------------------
3987 -- Check_Installer --
3988 ---------------------
3990 package body Check_Installer
is
3992 -----------------------
3993 -- Local subprograms --
3994 -----------------------
3996 function ABE_Check_Or_Failure_OK
3998 Targ_Id
: Entity_Id
;
3999 Unit_Id
: Entity_Id
) return Boolean;
4000 pragma Inline
(ABE_Check_Or_Failure_OK
);
4001 -- Determine whether a conditional ABE check or guaranteed ABE failure
4002 -- can be installed for scenario N with target Targ_Id which resides in
4005 function Insertion_Node
(N
: Node_Id
) return Node_Id
;
4006 pragma Inline
(Insertion_Node
);
4007 -- Obtain the proper insertion node of an ABE check or failure for
4010 procedure Insert_ABE_Check_Or_Failure
(N
: Node_Id
; Check
: Node_Id
);
4011 pragma Inline
(Insert_ABE_Check_Or_Failure
);
4012 -- Insert conditional ABE check or guaranteed ABE failure Check prior to
4015 procedure Install_Scenario_ABE_Check_Common
4017 Targ_Id
: Entity_Id
;
4018 Targ_Rep
: Target_Rep_Id
);
4019 pragma Inline
(Install_Scenario_ABE_Check_Common
);
4020 -- Install a conditional ABE check for scenario N to ensure that target
4021 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
4024 procedure Install_Scenario_ABE_Failure_Common
(N
: Node_Id
);
4025 pragma Inline
(Install_Scenario_ABE_Failure_Common
);
4026 -- Install a guaranteed ABE failure for scenario N
4028 procedure Install_Unit_ABE_Check_Common
4030 Unit_Id
: Entity_Id
);
4031 pragma Inline
(Install_Unit_ABE_Check_Common
);
4032 -- Install a conditional ABE check for scenario N to ensure that unit
4033 -- Unit_Id is properly elaborated.
4035 -----------------------------
4036 -- ABE_Check_Or_Failure_OK --
4037 -----------------------------
4039 function ABE_Check_Or_Failure_OK
4041 Targ_Id
: Entity_Id
;
4042 Unit_Id
: Entity_Id
) return Boolean
4044 pragma Unreferenced
(Targ_Id
);
4046 Ins_Node
: constant Node_Id
:= Insertion_Node
(N
);
4049 if not Check_Or_Failure_Generation_OK
then
4052 -- Nothing to do when the scenario denots a compilation unit because
4053 -- there is no executable environment at that level.
4055 elsif Nkind
(Parent
(Ins_Node
)) = N_Compilation_Unit
then
4058 -- An ABE check or failure is not needed when the target is defined
4059 -- in a unit which is elaborated prior to the main unit. This check
4060 -- must also consider the following cases:
4062 -- * The unit of the target appears in the context of the main unit
4064 -- * The unit of the target is subject to pragma Elaborate_Body. An
4065 -- ABE check MUST NOT be generated because the unit is always
4066 -- elaborated prior to the main unit.
4068 -- * The unit of the target is the main unit. An ABE check MUST be
4069 -- added in this case because a conditional ABE may be raised
4070 -- depending on the flow of execution within the main unit (flag
4071 -- Same_Unit_OK is False).
4073 elsif Has_Prior_Elaboration
4074 (Unit_Id
=> Unit_Id
,
4076 Elab_Body_OK
=> True)
4082 end ABE_Check_Or_Failure_OK
;
4084 ------------------------------------
4085 -- Check_Or_Failure_Generation_OK --
4086 ------------------------------------
4088 function Check_Or_Failure_Generation_OK
return Boolean is
4090 -- An ABE check or failure is not needed when the compilation will
4091 -- not produce an executable.
4093 if Serious_Errors_Detected
> 0 then
4096 -- An ABE check or failure must not be installed when compiling for
4097 -- GNATprove because raise statements are not supported.
4099 elsif GNATprove_Mode
then
4104 end Check_Or_Failure_Generation_OK
;
4106 --------------------
4107 -- Insertion_Node --
4108 --------------------
4110 function Insertion_Node
(N
: Node_Id
) return Node_Id
is
4112 -- When the scenario denotes an instantiation, the proper insertion
4113 -- node is the instance spec. This ensures that the generic actuals
4114 -- will not be evaluated prior to a potential ABE.
4116 if Nkind
(N
) in N_Generic_Instantiation
4117 and then Present
(Instance_Spec
(N
))
4119 return Instance_Spec
(N
);
4121 -- Otherwise the proper insertion node is the scenario itself
4128 ---------------------------------
4129 -- Insert_ABE_Check_Or_Failure --
4130 ---------------------------------
4132 procedure Insert_ABE_Check_Or_Failure
(N
: Node_Id
; Check
: Node_Id
) is
4133 Ins_Nod
: constant Node_Id
:= Insertion_Node
(N
);
4134 Scop_Id
: constant Entity_Id
:= Find_Enclosing_Scope
(Ins_Nod
);
4137 -- Install the nearest enclosing scope of the scenario as there must
4138 -- be something on the scope stack.
4140 Push_Scope
(Scop_Id
);
4142 Insert_Action
(Ins_Nod
, Check
);
4145 end Insert_ABE_Check_Or_Failure
;
4147 --------------------------------
4148 -- Install_Dynamic_ABE_Checks --
4149 --------------------------------
4151 procedure Install_Dynamic_ABE_Checks
is
4152 Iter
: NE_Set
.Iterator
;
4156 if not Check_Or_Failure_Generation_OK
then
4159 -- Nothing to do if the dynamic model is not in effect
4161 elsif not Dynamic_Elaboration_Checks
then
4165 -- Install a conditional ABE check for each saved scenario
4167 Iter
:= Iterate_Dynamic_ABE_Check_Scenarios
;
4168 while NE_Set
.Has_Next
(Iter
) loop
4169 NE_Set
.Next
(Iter
, N
);
4171 Process_Conditional_ABE
4173 In_State
=> Dynamic_Model_State
);
4175 end Install_Dynamic_ABE_Checks
;
4177 --------------------------------
4178 -- Install_Scenario_ABE_Check --
4179 --------------------------------
4181 procedure Install_Scenario_ABE_Check
4183 Targ_Id
: Entity_Id
;
4184 Targ_Rep
: Target_Rep_Id
;
4185 Disable
: Scenario_Rep_Id
)
4188 -- Nothing to do when the scenario does not need an ABE check
4190 if not ABE_Check_Or_Failure_OK
4193 Unit_Id
=> Unit
(Targ_Rep
))
4198 -- Prevent multiple attempts to install the same ABE check
4200 Disable_Elaboration_Checks
(Disable
);
4202 Install_Scenario_ABE_Check_Common
4205 Targ_Rep
=> Targ_Rep
);
4206 end Install_Scenario_ABE_Check
;
4208 --------------------------------
4209 -- Install_Scenario_ABE_Check --
4210 --------------------------------
4212 procedure Install_Scenario_ABE_Check
4214 Targ_Id
: Entity_Id
;
4215 Targ_Rep
: Target_Rep_Id
;
4216 Disable
: Target_Rep_Id
)
4219 -- Nothing to do when the scenario does not need an ABE check
4221 if not ABE_Check_Or_Failure_OK
4224 Unit_Id
=> Unit
(Targ_Rep
))
4229 -- Prevent multiple attempts to install the same ABE check
4231 Disable_Elaboration_Checks
(Disable
);
4233 Install_Scenario_ABE_Check_Common
4236 Targ_Rep
=> Targ_Rep
);
4237 end Install_Scenario_ABE_Check
;
4239 ---------------------------------------
4240 -- Install_Scenario_ABE_Check_Common --
4241 ---------------------------------------
4243 procedure Install_Scenario_ABE_Check_Common
4245 Targ_Id
: Entity_Id
;
4246 Targ_Rep
: Target_Rep_Id
)
4248 Targ_Body
: constant Node_Id
:= Body_Declaration
(Targ_Rep
);
4249 Targ_Decl
: constant Node_Id
:= Spec_Declaration
(Targ_Rep
);
4251 pragma Assert
(Present
(Targ_Body
));
4252 pragma Assert
(Present
(Targ_Decl
));
4254 procedure Build_Elaboration_Entity
;
4255 pragma Inline
(Build_Elaboration_Entity
);
4256 -- Create a new elaboration flag for Targ_Id, insert it prior to
4257 -- Targ_Decl, and set it after Targ_Body.
4259 ------------------------------
4260 -- Build_Elaboration_Entity --
4261 ------------------------------
4263 procedure Build_Elaboration_Entity
is
4264 Loc
: constant Source_Ptr
:= Sloc
(Targ_Id
);
4265 Flag_Id
: Entity_Id
;
4268 -- Nothing to do if the target has an elaboration flag
4270 if Present
(Elaboration_Entity
(Targ_Id
)) then
4274 -- Create the declaration of the elaboration flag. The name
4275 -- carries a unique counter in case the name is overloaded.
4278 Make_Defining_Identifier
(Loc
,
4279 Chars
=> New_External_Name
(Chars
(Targ_Id
), 'E', -1));
4281 Set_Elaboration_Entity
(Targ_Id
, Flag_Id
);
4282 Set_Elaboration_Entity_Required
(Targ_Id
);
4284 Push_Scope
(Scope
(Targ_Id
));
4287 -- Enn : Short_Integer := 0;
4289 Insert_Action
(Targ_Decl
,
4290 Make_Object_Declaration
(Loc
,
4291 Defining_Identifier
=> Flag_Id
,
4292 Object_Definition
=>
4293 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
4294 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
)));
4299 Set_Elaboration_Flag
(Targ_Body
, Targ_Id
);
4302 end Build_Elaboration_Entity
;
4306 Loc
: constant Source_Ptr
:= Sloc
(N
);
4308 -- Start for processing for Install_Scenario_ABE_Check_Common
4311 -- Create an elaboration flag for the target when it does not have
4314 Build_Elaboration_Entity
;
4317 -- if not Targ_Id'Elaborated then
4318 -- raise Program_Error with "access before elaboration";
4321 Insert_ABE_Check_Or_Failure
4324 Make_Raise_Program_Error
(Loc
,
4328 Make_Attribute_Reference
(Loc
,
4329 Prefix
=> New_Occurrence_Of
(Targ_Id
, Loc
),
4330 Attribute_Name
=> Name_Elaborated
)),
4331 Reason
=> PE_Access_Before_Elaboration
));
4332 end Install_Scenario_ABE_Check_Common
;
4334 ----------------------------------
4335 -- Install_Scenario_ABE_Failure --
4336 ----------------------------------
4338 procedure Install_Scenario_ABE_Failure
4340 Targ_Id
: Entity_Id
;
4341 Targ_Rep
: Target_Rep_Id
;
4342 Disable
: Scenario_Rep_Id
)
4345 -- Nothing to do when the scenario does not require an ABE failure
4347 if not ABE_Check_Or_Failure_OK
4350 Unit_Id
=> Unit
(Targ_Rep
))
4355 -- Prevent multiple attempts to install the same ABE check
4357 Disable_Elaboration_Checks
(Disable
);
4359 Install_Scenario_ABE_Failure_Common
(N
);
4360 end Install_Scenario_ABE_Failure
;
4362 ----------------------------------
4363 -- Install_Scenario_ABE_Failure --
4364 ----------------------------------
4366 procedure Install_Scenario_ABE_Failure
4368 Targ_Id
: Entity_Id
;
4369 Targ_Rep
: Target_Rep_Id
;
4370 Disable
: Target_Rep_Id
)
4373 -- Nothing to do when the scenario does not require an ABE failure
4375 if not ABE_Check_Or_Failure_OK
4378 Unit_Id
=> Unit
(Targ_Rep
))
4383 -- Prevent multiple attempts to install the same ABE check
4385 Disable_Elaboration_Checks
(Disable
);
4387 Install_Scenario_ABE_Failure_Common
(N
);
4388 end Install_Scenario_ABE_Failure
;
4390 -----------------------------------------
4391 -- Install_Scenario_ABE_Failure_Common --
4392 -----------------------------------------
4394 procedure Install_Scenario_ABE_Failure_Common
(N
: Node_Id
) is
4395 Loc
: constant Source_Ptr
:= Sloc
(N
);
4399 -- raise Program_Error with "access before elaboration";
4401 Insert_ABE_Check_Or_Failure
4404 Make_Raise_Program_Error
(Loc
,
4405 Reason
=> PE_Access_Before_Elaboration
));
4406 end Install_Scenario_ABE_Failure_Common
;
4408 ----------------------------
4409 -- Install_Unit_ABE_Check --
4410 ----------------------------
4412 procedure Install_Unit_ABE_Check
4414 Unit_Id
: Entity_Id
;
4415 Disable
: Scenario_Rep_Id
)
4417 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Unit_Id
);
4420 -- Nothing to do when the scenario does not require an ABE check
4422 if not ABE_Check_Or_Failure_OK
4430 -- Prevent multiple attempts to install the same ABE check
4432 Disable_Elaboration_Checks
(Disable
);
4434 Install_Unit_ABE_Check_Common
4436 Unit_Id
=> Unit_Id
);
4437 end Install_Unit_ABE_Check
;
4439 ----------------------------
4440 -- Install_Unit_ABE_Check --
4441 ----------------------------
4443 procedure Install_Unit_ABE_Check
4445 Unit_Id
: Entity_Id
;
4446 Disable
: Target_Rep_Id
)
4448 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Unit_Id
);
4451 -- Nothing to do when the scenario does not require an ABE check
4453 if not ABE_Check_Or_Failure_OK
4461 -- Prevent multiple attempts to install the same ABE check
4463 Disable_Elaboration_Checks
(Disable
);
4465 Install_Unit_ABE_Check_Common
4467 Unit_Id
=> Unit_Id
);
4468 end Install_Unit_ABE_Check
;
4470 -----------------------------------
4471 -- Install_Unit_ABE_Check_Common --
4472 -----------------------------------
4474 procedure Install_Unit_ABE_Check_Common
4476 Unit_Id
: Entity_Id
)
4478 Loc
: constant Source_Ptr
:= Sloc
(N
);
4479 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Unit_Id
);
4483 -- if not Spec_Id'Elaborated then
4484 -- raise Program_Error with "access before elaboration";
4487 Insert_ABE_Check_Or_Failure
4490 Make_Raise_Program_Error
(Loc
,
4494 Make_Attribute_Reference
(Loc
,
4495 Prefix
=> New_Occurrence_Of
(Spec_Id
, Loc
),
4496 Attribute_Name
=> Name_Elaborated
)),
4497 Reason
=> PE_Access_Before_Elaboration
));
4498 end Install_Unit_ABE_Check_Common
;
4499 end Check_Installer
;
4501 ----------------------
4502 -- Compilation_Unit --
4503 ----------------------
4505 function Compilation_Unit
(Unit_Id
: Entity_Id
) return Node_Id
is
4506 Comp_Unit
: Node_Id
;
4509 Comp_Unit
:= Parent
(Unit_Id
);
4511 -- Handle the case where a concurrent subunit is rewritten as a null
4512 -- statement due to expansion activities.
4514 if Nkind
(Comp_Unit
) = N_Null_Statement
4515 and then Nkind
(Original_Node
(Comp_Unit
)) in
4516 N_Protected_Body | N_Task_Body
4518 Comp_Unit
:= Parent
(Comp_Unit
);
4519 pragma Assert
(Nkind
(Comp_Unit
) = N_Subunit
);
4521 -- Otherwise use the declaration node of the unit
4524 Comp_Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
4527 -- Handle the case where a subprogram instantiation which acts as a
4528 -- compilation unit is expanded into an anonymous package that wraps
4529 -- the instantiated subprogram.
4531 if Nkind
(Comp_Unit
) = N_Package_Specification
4532 and then Nkind
(Original_Node
(Parent
(Comp_Unit
))) in
4533 N_Function_Instantiation | N_Procedure_Instantiation
4535 Comp_Unit
:= Parent
(Parent
(Comp_Unit
));
4537 -- Handle the case where the compilation unit is a subunit
4539 elsif Nkind
(Comp_Unit
) = N_Subunit
then
4540 Comp_Unit
:= Parent
(Comp_Unit
);
4543 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
4546 end Compilation_Unit
;
4548 -------------------------------
4549 -- Conditional_ABE_Processor --
4550 -------------------------------
4552 package body Conditional_ABE_Processor
is
4554 -----------------------
4555 -- Local subprograms --
4556 -----------------------
4558 function Is_Conditional_ABE_Scenario
(N
: Node_Id
) return Boolean;
4559 pragma Inline
(Is_Conditional_ABE_Scenario
);
4560 -- Determine whether node N is a suitable scenario for conditional ABE
4561 -- checks and diagnostics.
4563 procedure Process_Conditional_ABE_Access_Taken
4565 Attr_Rep
: Scenario_Rep_Id
;
4566 In_State
: Processing_In_State
);
4567 pragma Inline
(Process_Conditional_ABE_Access_Taken
);
4568 -- Perform ABE checks and diagnostics for attribute reference Attr with
4569 -- representation Attr_Rep which takes 'Access of an entry, operator, or
4570 -- subprogram. In_State is the current state of the Processing phase.
4572 procedure Process_Conditional_ABE_Activation
4574 Call_Rep
: Scenario_Rep_Id
;
4576 Obj_Rep
: Target_Rep_Id
;
4577 Task_Typ
: Entity_Id
;
4578 Task_Rep
: Target_Rep_Id
;
4579 In_State
: Processing_In_State
);
4580 pragma Inline
(Process_Conditional_ABE_Activation
);
4581 -- Perform common conditional ABE checks and diagnostics for activation
4582 -- call Call which activates object Obj_Id of task type Task_Typ. Formal
4583 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the
4584 -- representation of the object. Task_Rep denotes the representation of
4585 -- the task type. In_State is the current state of the Processing phase.
4587 procedure Process_Conditional_ABE_Call
4589 Call_Rep
: Scenario_Rep_Id
;
4590 In_State
: Processing_In_State
);
4591 pragma Inline
(Process_Conditional_ABE_Call
);
4592 -- Top-level dispatcher for processing of calls. Perform ABE checks and
4593 -- diagnostics for call Call with representation Call_Rep. In_State is
4594 -- the current state of the Processing phase.
4596 procedure Process_Conditional_ABE_Call_Ada
4598 Call_Rep
: Scenario_Rep_Id
;
4599 Subp_Id
: Entity_Id
;
4600 Subp_Rep
: Target_Rep_Id
;
4601 In_State
: Processing_In_State
);
4602 pragma Inline
(Process_Conditional_ABE_Call_Ada
);
4603 -- Perform ABE checks and diagnostics for call Call which invokes entry,
4604 -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes
4605 -- the representation of the call. Subp_Rep denotes the representation
4606 -- of the subprogram. In_State is the current state of the Processing
4609 procedure Process_Conditional_ABE_Call_SPARK
4611 Call_Rep
: Scenario_Rep_Id
;
4612 Subp_Id
: Entity_Id
;
4613 Subp_Rep
: Target_Rep_Id
;
4614 In_State
: Processing_In_State
);
4615 pragma Inline
(Process_Conditional_ABE_Call_SPARK
);
4616 -- Perform ABE checks and diagnostics for call Call which invokes entry,
4617 -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is
4618 -- the representation of the call. Subp_Rep denotes the representation
4619 -- of the subprogram. In_State is the current state of the Processing
4622 procedure Process_Conditional_ABE_Instantiation
4624 Inst_Rep
: Scenario_Rep_Id
;
4625 In_State
: Processing_In_State
);
4626 pragma Inline
(Process_Conditional_ABE_Instantiation
);
4627 -- Top-level dispatcher for processing of instantiations. Perform ABE
4628 -- checks and diagnostics for instantiation Inst with representation
4629 -- Inst_Rep. In_State is the current state of the Processing phase.
4631 procedure Process_Conditional_ABE_Instantiation_Ada
4633 Inst_Rep
: Scenario_Rep_Id
;
4635 Gen_Rep
: Target_Rep_Id
;
4636 In_State
: Processing_In_State
);
4637 pragma Inline
(Process_Conditional_ABE_Instantiation_Ada
);
4638 -- Perform ABE checks and diagnostics for instantiation Inst of generic
4639 -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of
4640 -- the instnace. Gen_Rep is the representation of the generic. In_State
4641 -- is the current state of the Processing phase.
4643 procedure Process_Conditional_ABE_Instantiation_SPARK
4645 Inst_Rep
: Scenario_Rep_Id
;
4647 Gen_Rep
: Target_Rep_Id
;
4648 In_State
: Processing_In_State
);
4649 pragma Inline
(Process_Conditional_ABE_Instantiation_SPARK
);
4650 -- Perform ABE checks and diagnostics for instantiation Inst of generic
4651 -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of
4652 -- the instnace. Gen_Rep is the representation of the generic. In_State
4653 -- is the current state of the Processing phase.
4655 procedure Process_Conditional_ABE_Variable_Assignment
4657 Asmt_Rep
: Scenario_Rep_Id
;
4658 In_State
: Processing_In_State
);
4659 pragma Inline
(Process_Conditional_ABE_Variable_Assignment
);
4660 -- Top-level dispatcher for processing of variable assignments. Perform
4661 -- ABE checks and diagnostics for assignment Asmt with representation
4662 -- Asmt_Rep. In_State denotes the current state of the Processing phase.
4664 procedure Process_Conditional_ABE_Variable_Assignment_Ada
4666 Asmt_Rep
: Scenario_Rep_Id
;
4668 Var_Rep
: Target_Rep_Id
;
4669 In_State
: Processing_In_State
);
4670 pragma Inline
(Process_Conditional_ABE_Variable_Assignment_Ada
);
4671 -- Perform ABE checks and diagnostics for assignment statement Asmt that
4672 -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep
4673 -- denotes the representation of the assignment. Var_Rep denotes the
4674 -- representation of the variable. In_State is the current state of the
4675 -- Processing phase.
4677 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
4679 Asmt_Rep
: Scenario_Rep_Id
;
4681 Var_Rep
: Target_Rep_Id
;
4682 In_State
: Processing_In_State
);
4683 pragma Inline
(Process_Conditional_ABE_Variable_Assignment_SPARK
);
4684 -- Perform ABE checks and diagnostics for assignment statement Asmt that
4685 -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep
4686 -- denotes the representation of the assignment. Var_Rep denotes the
4687 -- representation of the variable. In_State is the current state of the
4688 -- Processing phase.
4690 procedure Process_Conditional_ABE_Variable_Reference
4692 Ref_Rep
: Scenario_Rep_Id
;
4693 In_State
: Processing_In_State
);
4694 pragma Inline
(Process_Conditional_ABE_Variable_Reference
);
4695 -- Perform ABE checks and diagnostics for variable reference Ref with
4696 -- representation Ref_Rep. In_State denotes the current state of the
4697 -- Processing phase.
4699 procedure Traverse_Conditional_ABE_Body
4701 In_State
: Processing_In_State
);
4702 pragma Inline
(Traverse_Conditional_ABE_Body
);
4703 -- Traverse subprogram body N looking for suitable scenarios that need
4704 -- to be processed for conditional ABE checks and diagnostics. In_State
4705 -- is the current state of the Processing phase.
4707 -------------------------------------
4708 -- Check_Conditional_ABE_Scenarios --
4709 -------------------------------------
4711 procedure Check_Conditional_ABE_Scenarios
4712 (Iter
: in out NE_Set
.Iterator
)
4717 while NE_Set
.Has_Next
(Iter
) loop
4718 NE_Set
.Next
(Iter
, N
);
4720 -- Reset the traversed status of all subprogram bodies because the
4721 -- current conditional scenario acts as a new DFS traversal root.
4723 Reset_Traversed_Bodies
;
4725 Process_Conditional_ABE
4727 In_State
=> Conditional_ABE_State
);
4729 end Check_Conditional_ABE_Scenarios
;
4731 ---------------------------------
4732 -- Is_Conditional_ABE_Scenario --
4733 ---------------------------------
4735 function Is_Conditional_ABE_Scenario
(N
: Node_Id
) return Boolean is
4738 Is_Suitable_Access_Taken
(N
)
4739 or else Is_Suitable_Call
(N
)
4740 or else Is_Suitable_Instantiation
(N
)
4741 or else Is_Suitable_Variable_Assignment
(N
)
4742 or else Is_Suitable_Variable_Reference
(N
);
4743 end Is_Conditional_ABE_Scenario
;
4745 -----------------------------
4746 -- Process_Conditional_ABE --
4747 -----------------------------
4749 procedure Process_Conditional_ABE
4751 In_State
: Processing_In_State
)
4753 Scen
: constant Node_Id
:= Scenario
(N
);
4754 Scen_Rep
: Scenario_Rep_Id
;
4757 -- Add the current scenario to the stack of active scenarios
4759 Push_Active_Scenario
(Scen
);
4763 if Is_Suitable_Access_Taken
(Scen
) then
4764 Process_Conditional_ABE_Access_Taken
4766 Attr_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
4767 In_State
=> In_State
);
4769 -- Call or task activation
4771 elsif Is_Suitable_Call
(Scen
) then
4772 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
4774 -- Routine Build_Call_Marker creates call markers regardless of
4775 -- whether the call occurs within the main unit or not. This way
4776 -- the serialization of internal names is kept consistent. Only
4777 -- call markers found within the main unit must be processed.
4779 if In_Main_Context
(Scen
) then
4780 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
4782 if Kind
(Scen_Rep
) = Call_Scenario
then
4783 Process_Conditional_ABE_Call
4785 Call_Rep
=> Scen_Rep
,
4786 In_State
=> In_State
);
4789 pragma Assert
(Kind
(Scen_Rep
) = Task_Activation_Scenario
);
4793 Call_Rep
=> Scen_Rep
,
4794 Processor
=> Process_Conditional_ABE_Activation
'Access,
4795 In_State
=> In_State
);
4801 elsif Is_Suitable_Instantiation
(Scen
) then
4802 Process_Conditional_ABE_Instantiation
4804 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
4805 In_State
=> In_State
);
4807 -- Variable assignments
4809 elsif Is_Suitable_Variable_Assignment
(Scen
) then
4810 Process_Conditional_ABE_Variable_Assignment
4812 Asmt_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
4813 In_State
=> In_State
);
4815 -- Variable references
4817 elsif Is_Suitable_Variable_Reference
(Scen
) then
4819 -- Routine Build_Variable_Reference_Marker makes variable markers
4820 -- regardless of whether the reference occurs within the main unit
4821 -- or not. This way the serialization of internal names is kept
4822 -- consistent. Only variable markers within the main unit must be
4825 if In_Main_Context
(Scen
) then
4826 Process_Conditional_ABE_Variable_Reference
4828 Ref_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
4829 In_State
=> In_State
);
4833 -- Remove the current scenario from the stack of active scenarios
4834 -- once all ABE diagnostics and checks have been performed.
4836 Pop_Active_Scenario
(Scen
);
4837 end Process_Conditional_ABE
;
4839 ------------------------------------------
4840 -- Process_Conditional_ABE_Access_Taken --
4841 ------------------------------------------
4843 procedure Process_Conditional_ABE_Access_Taken
4845 Attr_Rep
: Scenario_Rep_Id
;
4846 In_State
: Processing_In_State
)
4848 function Build_Access_Marker
(Subp_Id
: Entity_Id
) return Node_Id
;
4849 pragma Inline
(Build_Access_Marker
);
4850 -- Create a suitable call marker which invokes subprogram Subp_Id
4852 -------------------------
4853 -- Build_Access_Marker --
4854 -------------------------
4856 function Build_Access_Marker
(Subp_Id
: Entity_Id
) return Node_Id
is
4860 Marker
:= Make_Call_Marker
(Sloc
(Attr
));
4862 -- Inherit relevant attributes from the attribute
4864 Set_Target
(Marker
, Subp_Id
);
4865 Set_Is_Declaration_Level_Node
4866 (Marker
, Level
(Attr_Rep
) = Declaration_Level
);
4867 Set_Is_Dispatching_Call
4869 Set_Is_Elaboration_Checks_OK_Node
4870 (Marker
, Elaboration_Checks_OK
(Attr_Rep
));
4871 Set_Is_Elaboration_Warnings_OK_Node
4872 (Marker
, Elaboration_Warnings_OK
(Attr_Rep
));
4873 Set_Is_Preelaborable_Call
4876 (Marker
, Comes_From_Source
(Attr
));
4877 Set_Is_SPARK_Mode_On_Node
4878 (Marker
, SPARK_Mode_Of
(Attr_Rep
) = Is_On
);
4880 -- Partially insert the call marker into the tree by setting its
4883 Set_Parent
(Marker
, Attr
);
4886 end Build_Access_Marker
;
4890 Root
: constant Node_Id
:= Root_Scenario
;
4891 Subp_Id
: constant Entity_Id
:= Target
(Attr_Rep
);
4892 Subp_Rep
: constant Target_Rep_Id
:=
4893 Target_Representation_Of
(Subp_Id
, In_State
);
4894 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
4896 New_In_State
: Processing_In_State
:= In_State
;
4897 -- Each step of the Processing phase constitutes a new state
4899 -- Start of processing for Process_Conditional_ABE_Access
4902 -- Output relevant information when switch -gnatel (info messages on
4903 -- implicit Elaborate[_All] pragmas) is in effect.
4905 if Elab_Info_Messages
4906 and then not New_In_State
.Suppress_Info_Messages
4909 ("info: access to & during elaboration?$?", Attr
, Subp_Id
);
4912 -- Warnings are suppressed when a prior scenario is already in that
4913 -- mode or when the attribute or the target have warnings suppressed.
4914 -- Update the state of the Processing phase to reflect this.
4916 New_In_State
.Suppress_Warnings
:=
4917 New_In_State
.Suppress_Warnings
4918 or else not Elaboration_Warnings_OK
(Attr_Rep
)
4919 or else not Elaboration_Warnings_OK
(Subp_Rep
);
4921 -- Do not emit any ABE diagnostics when the current or previous
4922 -- scenario in this traversal has suppressed elaboration warnings.
4924 if New_In_State
.Suppress_Warnings
then
4927 -- Both the attribute and the corresponding subprogram body are in
4928 -- the same unit. The body must appear prior to the root scenario
4929 -- which started the recursive search. If this is not the case, then
4930 -- there is a potential ABE if the access value is used to call the
4931 -- subprogram. Emit a warning only when switch -gnatw.f (warnings on
4932 -- suspicious 'Access) is in effect.
4934 elsif Warn_On_Elab_Access
4935 and then Present
(Body_Decl
)
4936 and then In_Extended_Main_Code_Unit
(Body_Decl
)
4937 and then Earlier_In_Extended_Unit
(Root
, Body_Decl
)
4939 Error_Msg_Name_1
:= Attribute_Name
(Attr
);
4941 ("?.f?% attribute of & before body seen", Attr
, Subp_Id
);
4942 Error_Msg_N
("\possible Program_Error on later references", Attr
);
4944 Output_Active_Scenarios
(Attr
, New_In_State
);
4947 -- Treat the attribute an immediate invocation of the target when
4948 -- switch -gnatd.o (conservative elaboration order for indirect
4949 -- calls) is in effect. This has the following desirable effects:
4951 -- * Ensure that the unit with the corresponding body is elaborated
4952 -- prior to the main unit.
4954 -- * Perform conditional ABE checks and diagnostics
4956 -- * Traverse the body of the target (if available)
4958 if Debug_Flag_Dot_O
then
4959 Process_Conditional_ABE
4960 (N
=> Build_Access_Marker
(Subp_Id
),
4961 In_State
=> New_In_State
);
4963 -- Otherwise ensure that the unit with the corresponding body is
4964 -- elaborated prior to the main unit.
4967 Ensure_Prior_Elaboration
4969 Unit_Id
=> Unit
(Subp_Rep
),
4970 Prag_Nam
=> Name_Elaborate_All
,
4971 In_State
=> New_In_State
);
4973 end Process_Conditional_ABE_Access_Taken
;
4975 ----------------------------------------
4976 -- Process_Conditional_ABE_Activation --
4977 ----------------------------------------
4979 procedure Process_Conditional_ABE_Activation
4981 Call_Rep
: Scenario_Rep_Id
;
4983 Obj_Rep
: Target_Rep_Id
;
4984 Task_Typ
: Entity_Id
;
4985 Task_Rep
: Target_Rep_Id
;
4986 In_State
: Processing_In_State
)
4988 pragma Unreferenced
(Task_Typ
);
4990 Body_Decl
: constant Node_Id
:= Body_Declaration
(Task_Rep
);
4991 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Task_Rep
);
4992 Root
: constant Node_Id
:= Root_Scenario
;
4993 Unit_Id
: constant Node_Id
:= Unit
(Task_Rep
);
4995 Check_OK
: constant Boolean :=
4996 not In_State
.Suppress_Checks
4997 and then Ghost_Mode_Of
(Obj_Rep
) /= Is_Ignored
4998 and then Ghost_Mode_Of
(Task_Rep
) /= Is_Ignored
4999 and then Elaboration_Checks_OK
(Obj_Rep
)
5000 and then Elaboration_Checks_OK
(Task_Rep
);
5001 -- A run-time ABE check may be installed only when the object and the
5002 -- task type have active elaboration checks, and both are not ignored
5003 -- Ghost constructs.
5005 New_In_State
: Processing_In_State
:= In_State
;
5006 -- Each step of the Processing phase constitutes a new state
5009 -- Output relevant information when switch -gnatel (info messages on
5010 -- implicit Elaborate[_All] pragmas) is in effect.
5012 if Elab_Info_Messages
5013 and then not New_In_State
.Suppress_Info_Messages
5016 ("info: activation of & during elaboration?$?", Call
, Obj_Id
);
5019 -- Nothing to do when the call activates a task whose type is defined
5020 -- within an instance and switch -gnatd_i (ignore activations and
5021 -- calls to instances for elaboration) is in effect.
5023 if Debug_Flag_Underscore_I
5024 and then In_External_Instance
5026 Target_Decl
=> Spec_Decl
)
5030 -- Nothing to do when the activation is a guaranteed ABE
5032 elsif Is_Known_Guaranteed_ABE
(Call
) then
5035 -- Nothing to do when the root scenario appears at the declaration
5036 -- level and the task is in the same unit, but outside this context.
5038 -- task type Task_Typ; -- task declaration
5040 -- procedure Proc is
5041 -- function A ... is
5043 -- if Some_Condition then
5047 -- <activation call> -- activation site
5052 -- X : ... := A; -- root scenario
5055 -- task body Task_Typ is
5059 -- In the example above, the context of X is the declarative list of
5060 -- Proc. The "elaboration" of X may reach the activation of T whose
5061 -- body is defined outside of X's context. The task body is relevant
5062 -- only when Proc is invoked, but this happens only during "normal"
5063 -- elaboration, therefore the task body must not be considered if
5064 -- this is not the case.
5066 elsif Is_Up_Level_Target
5067 (Targ_Decl
=> Spec_Decl
,
5068 In_State
=> New_In_State
)
5072 -- Nothing to do when the activation is ABE-safe
5076 -- task type Task_Typ;
5079 -- package body Gen is
5080 -- task body Task_Typ is
5087 -- procedure Main is
5088 -- package Nested is
5089 -- package Inst is new Gen;
5090 -- T : Inst.Task_Typ;
5091 -- <activation call> -- safe activation
5095 elsif Is_Safe_Activation
(Call
, Task_Rep
) then
5097 -- Note that the task body must still be examined for any nested
5102 -- The activation call and the task body are both in the main unit
5104 -- If the root scenario appears prior to the task body, then this is
5105 -- a possible ABE with respect to the root scenario.
5107 -- task type Task_Typ;
5109 -- function A ... is
5111 -- if Some_Condition then
5115 -- end Pack; -- activation of T
5119 -- X : ... := A; -- root scenario
5121 -- task body Task_Typ is -- task body
5125 -- Y : ... := A; -- root scenario
5127 -- IMPORTANT: The activation of T is a possible ABE for X, but
5128 -- not for Y. Intalling an unconditional ABE raise prior to the
5129 -- activation call would be wrong as it will fail for Y as well
5130 -- but in Y's case the activation of T is never an ABE.
5132 elsif Present
(Body_Decl
)
5133 and then In_Extended_Main_Code_Unit
(Body_Decl
)
5135 if Earlier_In_Extended_Unit
(Root
, Body_Decl
) then
5137 -- Do not emit any ABE diagnostics when a previous scenario in
5138 -- this traversal has suppressed elaboration warnings.
5140 if New_In_State
.Suppress_Warnings
then
5143 -- Do not emit any ABE diagnostics when the activation occurs
5144 -- in a partial finalization context because this action leads
5145 -- to confusing noise.
5147 elsif New_In_State
.Within_Partial_Finalization
then
5150 -- Otherwise emit the ABE disgnostic
5153 Error_Msg_Sloc
:= Sloc
(Call
);
5155 ("??task & will be activated # before elaboration of its "
5158 ("\Program_Error may be raised at run time", Obj_Id
);
5160 Output_Active_Scenarios
(Obj_Id
, New_In_State
);
5163 -- Install a conditional run-time ABE check to verify that the
5164 -- task body has been elaborated prior to the activation call.
5167 Install_Scenario_ABE_Check
5169 Targ_Id
=> Defining_Entity
(Spec_Decl
),
5170 Targ_Rep
=> Task_Rep
,
5171 Disable
=> Obj_Rep
);
5173 -- Update the state of the Processing phase to indicate that
5174 -- no implicit Elaborate[_All] pragma must be generated from
5177 -- task type Task_Typ;
5179 -- function A ... is
5181 -- if Some_Condition then
5186 -- end Pack; -- activation of T
5192 -- task body Task_Typ is
5194 -- External.Subp; -- imparts Elaborate_All
5197 -- If Some_Condition is True, then the ABE check will fail
5198 -- at runtime and the call to External.Subp will never take
5199 -- place, rendering the implicit Elaborate_All useless.
5201 -- If the value of Some_Condition is False, then the call
5202 -- to External.Subp will never take place, rendering the
5203 -- implicit Elaborate_All useless.
5205 New_In_State
.Suppress_Implicit_Pragmas
:= True;
5209 -- Otherwise the task body is not available in this compilation or
5210 -- it resides in an external unit. Install a run-time ABE check to
5211 -- verify that the task body has been elaborated prior to the
5212 -- activation call when the dynamic model is in effect.
5215 and then New_In_State
.Processing
= Dynamic_Model_Processing
5217 Install_Unit_ABE_Check
5220 Disable
=> Obj_Rep
);
5223 -- Both the activation call and task type are subject to SPARK_Mode
5224 -- On, this triggers the SPARK rules for task activation. Compared
5225 -- to calls and instantiations, task activation in SPARK does not
5226 -- require the presence of Elaborate[_All] pragmas in case the task
5227 -- type is defined outside the main unit. This is because SPARK uses
5228 -- a special policy which activates all tasks after the main unit has
5229 -- finished its elaboration.
5231 if SPARK_Mode_Of
(Call_Rep
) = Is_On
5232 and then SPARK_Mode_Of
(Task_Rep
) = Is_On
5236 -- Otherwise the Ada rules are in effect. Ensure that the unit with
5237 -- the task body is elaborated prior to the main unit.
5240 Ensure_Prior_Elaboration
5243 Prag_Nam
=> Name_Elaborate_All
,
5244 In_State
=> New_In_State
);
5247 Traverse_Conditional_ABE_Body
5249 In_State
=> New_In_State
);
5250 end Process_Conditional_ABE_Activation
;
5252 ----------------------------------
5253 -- Process_Conditional_ABE_Call --
5254 ----------------------------------
5256 procedure Process_Conditional_ABE_Call
5258 Call_Rep
: Scenario_Rep_Id
;
5259 In_State
: Processing_In_State
)
5261 function In_Initialization_Context
(N
: Node_Id
) return Boolean;
5262 pragma Inline
(In_Initialization_Context
);
5263 -- Determine whether arbitrary node N appears within a type init
5264 -- proc, primitive [Deep_]Initialize, or a block created for
5265 -- initialization purposes.
5267 function Is_Partial_Finalization_Proc
5268 (Subp_Id
: Entity_Id
) return Boolean;
5269 pragma Inline
(Is_Partial_Finalization_Proc
);
5270 -- Determine whether subprogram Subp_Id is a partial finalization
5273 -------------------------------
5274 -- In_Initialization_Context --
5275 -------------------------------
5277 function In_Initialization_Context
(N
: Node_Id
) return Boolean is
5279 Spec_Id
: Entity_Id
;
5282 -- Climb the parent chain looking for initialization actions
5285 while Present
(Par
) loop
5287 -- A block may be part of the initialization actions of a
5288 -- default initialized object.
5290 if Nkind
(Par
) = N_Block_Statement
5291 and then Is_Initialization_Block
(Par
)
5295 -- A subprogram body may denote an initialization routine
5297 elsif Nkind
(Par
) = N_Subprogram_Body
then
5298 Spec_Id
:= Unique_Defining_Entity
(Par
);
5300 -- The current subprogram body denotes a type init proc or
5301 -- primitive [Deep_]Initialize.
5303 if Is_Init_Proc
(Spec_Id
)
5304 or else Is_Controlled_Procedure
(Spec_Id
, Name_Initialize
)
5305 or else Is_TSS
(Spec_Id
, TSS_Deep_Initialize
)
5310 -- Prevent the search from going too far
5312 elsif Is_Body_Or_Package_Declaration
(Par
) then
5316 Par
:= Parent
(Par
);
5320 end In_Initialization_Context
;
5322 ----------------------------------
5323 -- Is_Partial_Finalization_Proc --
5324 ----------------------------------
5326 function Is_Partial_Finalization_Proc
5327 (Subp_Id
: Entity_Id
) return Boolean
5330 -- To qualify, the subprogram must denote a finalizer procedure
5331 -- or primitive [Deep_]Finalize, and the call must appear within
5332 -- an initialization context.
5335 (Is_Controlled_Procedure
(Subp_Id
, Name_Finalize
)
5336 or else Is_Finalizer
(Subp_Id
)
5337 or else Is_TSS
(Subp_Id
, TSS_Deep_Finalize
))
5338 and then In_Initialization_Context
(Call
);
5339 end Is_Partial_Finalization_Proc
;
5343 Subp_Id
: constant Entity_Id
:= Target
(Call_Rep
);
5344 Subp_Rep
: constant Target_Rep_Id
:=
5345 Target_Representation_Of
(Subp_Id
, In_State
);
5346 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
5347 Subp_Decl
: constant Node_Id
:= Spec_Declaration
(Subp_Rep
);
5349 SPARK_Rules_On
: constant Boolean :=
5350 SPARK_Mode_Of
(Call_Rep
) = Is_On
5351 and then SPARK_Mode_Of
(Subp_Rep
) = Is_On
;
5353 New_In_State
: Processing_In_State
:= In_State
;
5354 -- Each step of the Processing phase constitutes a new state
5356 -- Start of processing for Process_Conditional_ABE_Call
5359 -- Output relevant information when switch -gnatel (info messages on
5360 -- implicit Elaborate[_All] pragmas) is in effect.
5362 if Elab_Info_Messages
5363 and then not New_In_State
.Suppress_Info_Messages
5369 In_SPARK
=> SPARK_Rules_On
);
5372 -- Check whether the invocation of an entry clashes with an existing
5373 -- restriction. This check is relevant only when the processing was
5374 -- started from some library-level scenario.
5376 if Is_Protected_Entry
(Subp_Id
) then
5377 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
5379 elsif Is_Task_Entry
(Subp_Id
) then
5380 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
5382 -- Task entry calls are never processed because the entry being
5383 -- invoked does not have a corresponding "body", it has a select.
5388 -- Nothing to do when the call invokes a target defined within an
5389 -- instance and switch -gnatd_i (ignore activations and calls to
5390 -- instances for elaboration) is in effect.
5392 if Debug_Flag_Underscore_I
5393 and then In_External_Instance
5395 Target_Decl
=> Subp_Decl
)
5399 -- Nothing to do when the call is a guaranteed ABE
5401 elsif Is_Known_Guaranteed_ABE
(Call
) then
5404 -- Nothing to do when the root scenario appears at the declaration
5405 -- level and the target is in the same unit but outside this context.
5407 -- function B ...; -- target declaration
5409 -- procedure Proc is
5410 -- function A ... is
5412 -- if Some_Condition then
5413 -- return B; -- call site
5417 -- X : ... := A; -- root scenario
5420 -- function B ... is
5424 -- In the example above, the context of X is the declarative region
5425 -- of Proc. The "elaboration" of X may eventually reach B which is
5426 -- defined outside of X's context. B is relevant only when Proc is
5427 -- invoked, but this happens only by means of "normal" elaboration,
5428 -- therefore B must not be considered if this is not the case.
5430 elsif Is_Up_Level_Target
5431 (Targ_Decl
=> Subp_Decl
,
5432 In_State
=> New_In_State
)
5437 -- Warnings are suppressed when a prior scenario is already in that
5438 -- mode, or the call or target have warnings suppressed. Update the
5439 -- state of the Processing phase to reflect this.
5441 New_In_State
.Suppress_Warnings
:=
5442 New_In_State
.Suppress_Warnings
5443 or else not Elaboration_Warnings_OK
(Call_Rep
)
5444 or else not Elaboration_Warnings_OK
(Subp_Rep
);
5446 -- The call occurs in freezing actions context when a prior scenario
5447 -- is already in that mode, or when the target is a subprogram whose
5448 -- body has been generated as a freezing action. Update the state of
5449 -- the Processing phase to reflect this.
5451 New_In_State
.Within_Freezing_Actions
:=
5452 New_In_State
.Within_Freezing_Actions
5453 or else (Present
(Body_Decl
)
5454 and then Nkind
(Parent
(Body_Decl
)) = N_Freeze_Entity
);
5456 -- The call occurs in an initial condition context when a prior
5457 -- scenario is already in that mode, or when the target is an
5458 -- Initial_Condition procedure. Update the state of the Processing
5459 -- phase to reflect this.
5461 New_In_State
.Within_Initial_Condition
:=
5462 New_In_State
.Within_Initial_Condition
5463 or else Is_Initial_Condition_Proc
(Subp_Id
);
5465 -- The call occurs in a partial finalization context when a prior
5466 -- scenario is already in that mode, or when the target denotes a
5467 -- [Deep_]Finalize primitive or a finalizer within an initialization
5468 -- context. Update the state of the Processing phase to reflect this.
5470 New_In_State
.Within_Partial_Finalization
:=
5471 New_In_State
.Within_Partial_Finalization
5472 or else Is_Partial_Finalization_Proc
(Subp_Id
);
5474 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK
5475 -- elaboration rules in SPARK code) is intentionally not taken into
5476 -- account here because Process_Conditional_ABE_Call_SPARK has two
5477 -- separate modes of operation.
5479 if SPARK_Rules_On
then
5480 Process_Conditional_ABE_Call_SPARK
5482 Call_Rep
=> Call_Rep
,
5484 Subp_Rep
=> Subp_Rep
,
5485 In_State
=> New_In_State
);
5487 -- Otherwise the Ada rules are in effect
5490 Process_Conditional_ABE_Call_Ada
5492 Call_Rep
=> Call_Rep
,
5494 Subp_Rep
=> Subp_Rep
,
5495 In_State
=> New_In_State
);
5498 -- Inspect the target body (and barried function) for other suitable
5499 -- elaboration scenarios.
5501 Traverse_Conditional_ABE_Body
5502 (N
=> Barrier_Body_Declaration
(Subp_Rep
),
5503 In_State
=> New_In_State
);
5505 Traverse_Conditional_ABE_Body
5507 In_State
=> New_In_State
);
5508 end Process_Conditional_ABE_Call
;
5510 --------------------------------------
5511 -- Process_Conditional_ABE_Call_Ada --
5512 --------------------------------------
5514 procedure Process_Conditional_ABE_Call_Ada
5516 Call_Rep
: Scenario_Rep_Id
;
5517 Subp_Id
: Entity_Id
;
5518 Subp_Rep
: Target_Rep_Id
;
5519 In_State
: Processing_In_State
)
5521 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
5522 Root
: constant Node_Id
:= Root_Scenario
;
5523 Unit_Id
: constant Node_Id
:= Unit
(Subp_Rep
);
5525 Check_OK
: constant Boolean :=
5526 not In_State
.Suppress_Checks
5527 and then Ghost_Mode_Of
(Call_Rep
) /= Is_Ignored
5528 and then Ghost_Mode_Of
(Subp_Rep
) /= Is_Ignored
5529 and then Elaboration_Checks_OK
(Call_Rep
)
5530 and then Elaboration_Checks_OK
(Subp_Rep
);
5531 -- A run-time ABE check may be installed only when both the call
5532 -- and the target have active elaboration checks, and both are not
5533 -- ignored Ghost constructs.
5535 New_In_State
: Processing_In_State
:= In_State
;
5536 -- Each step of the Processing phase constitutes a new state
5539 -- Nothing to do for an Ada dispatching call because there are no
5540 -- ABE diagnostics for either models. ABE checks for the dynamic
5541 -- model are handled by Install_Primitive_Elaboration_Check.
5543 if Is_Dispatching_Call
(Call_Rep
) then
5546 -- Nothing to do when the call is ABE-safe
5549 -- function Gen ...;
5551 -- function Gen ... is
5557 -- procedure Main is
5558 -- function Inst is new Gen;
5559 -- X : ... := Inst; -- safe call
5562 elsif Is_Safe_Call
(Call
, Subp_Id
, Subp_Rep
) then
5565 -- The call and the target body are both in the main unit
5567 -- If the root scenario appears prior to the target body, then this
5568 -- is a possible ABE with respect to the root scenario.
5572 -- function A ... is
5574 -- if Some_Condition then
5575 -- return B; -- call site
5579 -- X : ... := A; -- root scenario
5581 -- function B ... is -- target body
5585 -- Y : ... := A; -- root scenario
5587 -- IMPORTANT: The call to B from A is a possible ABE for X, but
5588 -- not for Y. Installing an unconditional ABE raise prior to the
5589 -- call to B would be wrong as it will fail for Y as well, but in
5590 -- Y's case the call to B is never an ABE.
5592 elsif Present
(Body_Decl
)
5593 and then In_Extended_Main_Code_Unit
(Body_Decl
)
5595 if Earlier_In_Extended_Unit
(Root
, Body_Decl
) then
5597 -- Do not emit any ABE diagnostics when a previous scenario in
5598 -- this traversal has suppressed elaboration warnings.
5600 if New_In_State
.Suppress_Warnings
then
5603 -- Do not emit any ABE diagnostics when the call occurs in a
5604 -- partial finalization context because this leads to confusing
5607 elsif New_In_State
.Within_Partial_Finalization
then
5610 -- Otherwise emit the ABE diagnostic
5614 ("??cannot call & before body seen", Call
, Subp_Id
);
5616 ("\Program_Error may be raised at run time", Call
);
5618 Output_Active_Scenarios
(Call
, New_In_State
);
5621 -- Install a conditional run-time ABE check to verify that the
5622 -- target body has been elaborated prior to the call.
5625 Install_Scenario_ABE_Check
5628 Targ_Rep
=> Subp_Rep
,
5629 Disable
=> Call_Rep
);
5631 -- Update the state of the Processing phase to indicate that
5632 -- no implicit Elaborate[_All] pragma must be generated from
5637 -- function A ... is
5639 -- if Some_Condition then
5647 -- function B ... is
5648 -- External.Subp; -- imparts Elaborate_All
5651 -- If Some_Condition is True, then the ABE check will fail
5652 -- at runtime and the call to External.Subp will never take
5653 -- place, rendering the implicit Elaborate_All useless.
5655 -- If the value of Some_Condition is False, then the call
5656 -- to External.Subp will never take place, rendering the
5657 -- implicit Elaborate_All useless.
5659 New_In_State
.Suppress_Implicit_Pragmas
:= True;
5663 -- Otherwise the target body is not available in this compilation or
5664 -- it resides in an external unit. Install a run-time ABE check to
5665 -- verify that the target body has been elaborated prior to the call
5666 -- site when the dynamic model is in effect.
5669 and then New_In_State
.Processing
= Dynamic_Model_Processing
5671 Install_Unit_ABE_Check
5674 Disable
=> Call_Rep
);
5677 -- Ensure that the unit with the target body is elaborated prior to
5678 -- the main unit. The implicit Elaborate[_All] is generated only when
5679 -- the call has elaboration checks enabled. This behavior parallels
5680 -- that of the old ABE mechanism.
5682 if Elaboration_Checks_OK
(Call_Rep
) then
5683 Ensure_Prior_Elaboration
5686 Prag_Nam
=> Name_Elaborate_All
,
5687 In_State
=> New_In_State
);
5689 end Process_Conditional_ABE_Call_Ada
;
5691 ----------------------------------------
5692 -- Process_Conditional_ABE_Call_SPARK --
5693 ----------------------------------------
5695 procedure Process_Conditional_ABE_Call_SPARK
5697 Call_Rep
: Scenario_Rep_Id
;
5698 Subp_Id
: Entity_Id
;
5699 Subp_Rep
: Target_Rep_Id
;
5700 In_State
: Processing_In_State
)
5702 pragma Unreferenced
(Call_Rep
);
5704 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
5708 -- Ensure that a suitable elaboration model is in effect for SPARK
5709 -- rule verification.
5711 Check_SPARK_Model_In_Effect
;
5713 -- The call and the target body are both in the main unit
5715 if Present
(Body_Decl
)
5716 and then In_Extended_Main_Code_Unit
(Body_Decl
)
5717 and then Earlier_In_Extended_Unit
(Call
, Body_Decl
)
5719 -- Do not emit any ABE diagnostics when a previous scenario in
5720 -- this traversal has suppressed elaboration warnings.
5722 if In_State
.Suppress_Warnings
then
5725 -- Do not emit any ABE diagnostics when the call occurs in a
5726 -- freezing actions context because this leads to incorrect
5729 elsif In_State
.Within_Freezing_Actions
then
5732 -- Do not emit any ABE diagnostics when the call occurs in an
5733 -- initial condition context because this leads to incorrect
5736 elsif In_State
.Within_Initial_Condition
then
5739 -- Do not emit any ABE diagnostics when the call occurs in a
5740 -- partial finalization context because this leads to confusing
5743 elsif In_State
.Within_Partial_Finalization
then
5746 -- Ensure that a call that textually precedes the subprogram body
5747 -- it invokes appears within the early call region of the body.
5749 -- IMPORTANT: This check must always be performed even when switch
5750 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
5751 -- specified because the static model cannot guarantee the absence
5752 -- of elaboration issues when dispatching calls are involved.
5755 Region
:= Find_Early_Call_Region
(Body_Decl
);
5757 if Earlier_In_Extended_Unit
(Call
, Region
) then
5759 ("call must appear within early call region of subprogram "
5760 & "body & (SPARK RM 7.7(3))",
5763 Error_Msg_Sloc
:= Sloc
(Region
);
5764 Error_Msg_N
("\region starts #", Call
);
5766 Error_Msg_Sloc
:= Sloc
(Body_Decl
);
5767 Error_Msg_N
("\region ends #", Call
);
5769 Output_Active_Scenarios
(Call
, In_State
);
5774 -- A call to a source target or to a target which emulates Ada
5775 -- or SPARK semantics imposes an Elaborate_All requirement on the
5776 -- context of the main unit. Determine whether the context has a
5777 -- pragma strong enough to meet the requirement.
5779 -- IMPORTANT: This check must be performed only when switch -gnatd.v
5780 -- (enforce SPARK elaboration rules in SPARK code) is active because
5781 -- the static model can ensure the prior elaboration of the unit
5782 -- which contains a body by installing an implicit Elaborate[_All]
5785 if Debug_Flag_Dot_V
then
5786 if Comes_From_Source
(Subp_Id
)
5787 or else Is_Ada_Semantic_Target
(Subp_Id
)
5788 or else Is_SPARK_Semantic_Target
(Subp_Id
)
5790 Meet_Elaboration_Requirement
5793 Req_Nam
=> Name_Elaborate_All
,
5794 In_State
=> In_State
);
5797 -- Otherwise ensure that the unit with the target body is elaborated
5798 -- prior to the main unit.
5801 Ensure_Prior_Elaboration
5803 Unit_Id
=> Unit
(Subp_Rep
),
5804 Prag_Nam
=> Name_Elaborate_All
,
5805 In_State
=> In_State
);
5807 end Process_Conditional_ABE_Call_SPARK
;
5809 -------------------------------------------
5810 -- Process_Conditional_ABE_Instantiation --
5811 -------------------------------------------
5813 procedure Process_Conditional_ABE_Instantiation
5815 Inst_Rep
: Scenario_Rep_Id
;
5816 In_State
: Processing_In_State
)
5818 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
5819 Gen_Rep
: constant Target_Rep_Id
:=
5820 Target_Representation_Of
(Gen_Id
, In_State
);
5822 SPARK_Rules_On
: constant Boolean :=
5823 SPARK_Mode_Of
(Inst_Rep
) = Is_On
5824 and then SPARK_Mode_Of
(Gen_Rep
) = Is_On
;
5826 New_In_State
: Processing_In_State
:= In_State
;
5827 -- Each step of the Processing phase constitutes a new state
5830 -- Output relevant information when switch -gnatel (info messages on
5831 -- implicit Elaborate[_All] pragmas) is in effect.
5833 if Elab_Info_Messages
5834 and then not New_In_State
.Suppress_Info_Messages
5840 In_SPARK
=> SPARK_Rules_On
);
5843 -- Nothing to do when the instantiation is a guaranteed ABE
5845 if Is_Known_Guaranteed_ABE
(Inst
) then
5848 -- Nothing to do when the root scenario appears at the declaration
5849 -- level and the generic is in the same unit, but outside this
5853 -- procedure Gen is ...; -- generic declaration
5855 -- procedure Proc is
5856 -- function A ... is
5858 -- if Some_Condition then
5860 -- procedure I is new Gen; -- instantiation site
5865 -- X : ... := A; -- root scenario
5872 -- In the example above, the context of X is the declarative region
5873 -- of Proc. The "elaboration" of X may eventually reach Gen which
5874 -- appears outside of X's context. Gen is relevant only when Proc is
5875 -- invoked, but this happens only by means of "normal" elaboration,
5876 -- therefore Gen must not be considered if this is not the case.
5878 elsif Is_Up_Level_Target
5879 (Targ_Decl
=> Spec_Declaration
(Gen_Rep
),
5880 In_State
=> New_In_State
)
5885 -- Warnings are suppressed when a prior scenario is already in that
5886 -- mode, or when the instantiation has warnings suppressed. Update
5887 -- the state of the processing phase to reflect this.
5889 New_In_State
.Suppress_Warnings
:=
5890 New_In_State
.Suppress_Warnings
5891 or else not Elaboration_Warnings_OK
(Inst_Rep
);
5893 -- The SPARK rules are in effect
5895 if SPARK_Rules_On
then
5896 Process_Conditional_ABE_Instantiation_SPARK
5898 Inst_Rep
=> Inst_Rep
,
5901 In_State
=> New_In_State
);
5903 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
5904 -- violate the SPARK rules.
5907 Process_Conditional_ABE_Instantiation_Ada
5909 Inst_Rep
=> Inst_Rep
,
5912 In_State
=> New_In_State
);
5914 end Process_Conditional_ABE_Instantiation
;
5916 -----------------------------------------------
5917 -- Process_Conditional_ABE_Instantiation_Ada --
5918 -----------------------------------------------
5920 procedure Process_Conditional_ABE_Instantiation_Ada
5922 Inst_Rep
: Scenario_Rep_Id
;
5924 Gen_Rep
: Target_Rep_Id
;
5925 In_State
: Processing_In_State
)
5927 Body_Decl
: constant Node_Id
:= Body_Declaration
(Gen_Rep
);
5928 Root
: constant Node_Id
:= Root_Scenario
;
5929 Unit_Id
: constant Entity_Id
:= Unit
(Gen_Rep
);
5931 Check_OK
: constant Boolean :=
5932 not In_State
.Suppress_Checks
5933 and then Ghost_Mode_Of
(Inst_Rep
) /= Is_Ignored
5934 and then Ghost_Mode_Of
(Gen_Rep
) /= Is_Ignored
5935 and then Elaboration_Checks_OK
(Inst_Rep
)
5936 and then Elaboration_Checks_OK
(Gen_Rep
);
5937 -- A run-time ABE check may be installed only when both the instance
5938 -- and the generic have active elaboration checks and both are not
5939 -- ignored Ghost constructs.
5941 New_In_State
: Processing_In_State
:= In_State
;
5942 -- Each step of the Processing phase constitutes a new state
5945 -- Nothing to do when the instantiation is ABE-safe
5952 -- package body Gen is
5957 -- procedure Main is
5958 -- package Inst is new Gen (ABE); -- safe instantiation
5961 if Is_Safe_Instantiation
(Inst
, Gen_Id
, Gen_Rep
) then
5964 -- The instantiation and the generic body are both in the main unit
5966 -- If the root scenario appears prior to the generic body, then this
5967 -- is a possible ABE with respect to the root scenario.
5974 -- function A ... is
5976 -- if Some_Condition then
5978 -- package Inst is new Gen; -- instantiation site
5982 -- X : ... := A; -- root scenario
5984 -- package body Gen is -- generic body
5988 -- Y : ... := A; -- root scenario
5990 -- IMPORTANT: The instantiation of Gen is a possible ABE for X,
5991 -- but not for Y. Installing an unconditional ABE raise prior to
5992 -- the instance site would be wrong as it will fail for Y as well,
5993 -- but in Y's case the instantiation of Gen is never an ABE.
5995 elsif Present
(Body_Decl
)
5996 and then In_Extended_Main_Code_Unit
(Body_Decl
)
5998 if Earlier_In_Extended_Unit
(Root
, Body_Decl
) then
6000 -- Do not emit any ABE diagnostics when a previous scenario in
6001 -- this traversal has suppressed elaboration warnings.
6003 if New_In_State
.Suppress_Warnings
then
6006 -- Do not emit any ABE diagnostics when the instantiation
6007 -- occurs in partial finalization context because this leads
6008 -- to unwanted noise.
6010 elsif New_In_State
.Within_Partial_Finalization
then
6013 -- Otherwise output the diagnostic
6017 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
6019 ("\Program_Error may be raised at run time", Inst
);
6021 Output_Active_Scenarios
(Inst
, New_In_State
);
6024 -- Install a conditional run-time ABE check to verify that the
6025 -- generic body has been elaborated prior to the instantiation.
6028 Install_Scenario_ABE_Check
6031 Targ_Rep
=> Gen_Rep
,
6032 Disable
=> Inst_Rep
);
6034 -- Update the state of the Processing phase to indicate that
6035 -- no implicit Elaborate[_All] pragma must be generated from
6043 -- function A ... is
6045 -- if Some_Condition then
6047 -- declare Inst is new Gen;
6053 -- package body Gen is
6055 -- External.Subp; -- imparts Elaborate_All
6058 -- If Some_Condition is True, then the ABE check will fail
6059 -- at runtime and the call to External.Subp will never take
6060 -- place, rendering the implicit Elaborate_All useless.
6062 -- If the value of Some_Condition is False, then the call
6063 -- to External.Subp will never take place, rendering the
6064 -- implicit Elaborate_All useless.
6066 New_In_State
.Suppress_Implicit_Pragmas
:= True;
6070 -- Otherwise the generic body is not available in this compilation
6071 -- or it resides in an external unit. Install a run-time ABE check
6072 -- to verify that the generic body has been elaborated prior to the
6073 -- instantiation when the dynamic model is in effect.
6076 and then New_In_State
.Processing
= Dynamic_Model_Processing
6078 Install_Unit_ABE_Check
6081 Disable
=> Inst_Rep
);
6084 -- Ensure that the unit with the generic body is elaborated prior
6085 -- to the main unit. No implicit pragma has to be generated if the
6086 -- instantiation has elaboration checks suppressed. This behavior
6087 -- parallels that of the old ABE mechanism.
6089 if Elaboration_Checks_OK
(Inst_Rep
) then
6090 Ensure_Prior_Elaboration
6093 Prag_Nam
=> Name_Elaborate
,
6094 In_State
=> New_In_State
);
6096 end Process_Conditional_ABE_Instantiation_Ada
;
6098 -------------------------------------------------
6099 -- Process_Conditional_ABE_Instantiation_SPARK --
6100 -------------------------------------------------
6102 procedure Process_Conditional_ABE_Instantiation_SPARK
6104 Inst_Rep
: Scenario_Rep_Id
;
6106 Gen_Rep
: Target_Rep_Id
;
6107 In_State
: Processing_In_State
)
6109 pragma Unreferenced
(Inst_Rep
);
6114 -- Ensure that a suitable elaboration model is in effect for SPARK
6115 -- rule verification.
6117 Check_SPARK_Model_In_Effect
;
6119 -- A source instantiation imposes an Elaborate[_All] requirement
6120 -- on the context of the main unit. Determine whether the context
6121 -- has a pragma strong enough to meet the requirement. The check
6122 -- is orthogonal to the ABE ramifications of the instantiation.
6124 -- IMPORTANT: This check must be performed only when switch -gnatd.v
6125 -- (enforce SPARK elaboration rules in SPARK code) is active because
6126 -- the static model can ensure the prior elaboration of the unit
6127 -- which contains a body by installing an implicit Elaborate[_All]
6130 if Debug_Flag_Dot_V
then
6131 if Nkind
(Inst
) = N_Package_Instantiation
then
6132 Req_Nam
:= Name_Elaborate_All
;
6134 Req_Nam
:= Name_Elaborate
;
6137 Meet_Elaboration_Requirement
6141 In_State
=> In_State
);
6143 -- Otherwise ensure that the unit with the target body is elaborated
6144 -- prior to the main unit.
6147 Ensure_Prior_Elaboration
6149 Unit_Id
=> Unit
(Gen_Rep
),
6150 Prag_Nam
=> Name_Elaborate
,
6151 In_State
=> In_State
);
6153 end Process_Conditional_ABE_Instantiation_SPARK
;
6155 -------------------------------------------------
6156 -- Process_Conditional_ABE_Variable_Assignment --
6157 -------------------------------------------------
6159 procedure Process_Conditional_ABE_Variable_Assignment
6161 Asmt_Rep
: Scenario_Rep_Id
;
6162 In_State
: Processing_In_State
)
6165 Var_Id
: constant Entity_Id
:= Target
(Asmt_Rep
);
6166 Var_Rep
: constant Target_Rep_Id
:=
6167 Target_Representation_Of
(Var_Id
, In_State
);
6169 SPARK_Rules_On
: constant Boolean :=
6170 SPARK_Mode_Of
(Asmt_Rep
) = Is_On
6171 and then SPARK_Mode_Of
(Var_Rep
) = Is_On
;
6174 -- Output relevant information when switch -gnatel (info messages on
6175 -- implicit Elaborate[_All] pragmas) is in effect.
6177 if Elab_Info_Messages
6178 and then not In_State
.Suppress_Info_Messages
6181 (Msg
=> "assignment to & during elaboration",
6185 In_SPARK
=> SPARK_Rules_On
);
6188 -- The SPARK rules are in effect. These rules are applied regardless
6189 -- of whether switch -gnatd.v (enforce SPARK elaboration rules in
6190 -- SPARK code) is in effect because the static model cannot ensure
6191 -- safe assignment of variables.
6193 if SPARK_Rules_On
then
6194 Process_Conditional_ABE_Variable_Assignment_SPARK
6196 Asmt_Rep
=> Asmt_Rep
,
6199 In_State
=> In_State
);
6201 -- Otherwise the Ada rules are in effect
6204 Process_Conditional_ABE_Variable_Assignment_Ada
6206 Asmt_Rep
=> Asmt_Rep
,
6209 In_State
=> In_State
);
6211 end Process_Conditional_ABE_Variable_Assignment
;
6213 -----------------------------------------------------
6214 -- Process_Conditional_ABE_Variable_Assignment_Ada --
6215 -----------------------------------------------------
6217 procedure Process_Conditional_ABE_Variable_Assignment_Ada
6219 Asmt_Rep
: Scenario_Rep_Id
;
6221 Var_Rep
: Target_Rep_Id
;
6222 In_State
: Processing_In_State
)
6224 pragma Unreferenced
(Asmt_Rep
);
6226 Var_Decl
: constant Node_Id
:= Variable_Declaration
(Var_Rep
);
6227 Unit_Id
: constant Entity_Id
:= Unit
(Var_Rep
);
6230 -- Emit a warning when an uninitialized variable declared in a
6231 -- package spec without a pragma Elaborate_Body is initialized
6232 -- by elaboration code within the corresponding body.
6234 if Is_Elaboration_Warnings_OK_Id
(Var_Id
)
6235 and then not Is_Initialized
(Var_Decl
)
6236 and then not Has_Pragma_Elaborate_Body
(Unit_Id
)
6238 -- Do not emit any ABE diagnostics when a previous scenario in
6239 -- this traversal has suppressed elaboration warnings.
6241 if not In_State
.Suppress_Warnings
then
6243 ("??variable & can be accessed by clients before this "
6244 & "initialization", Asmt
, Var_Id
);
6247 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
6248 & "initialization", Asmt
, Unit_Id
);
6250 Output_Active_Scenarios
(Asmt
, In_State
);
6253 -- Generate an implicit Elaborate_Body in the spec
6255 Set_Elaborate_Body_Desirable
(Unit_Id
);
6257 end Process_Conditional_ABE_Variable_Assignment_Ada
;
6259 -------------------------------------------------------
6260 -- Process_Conditional_ABE_Variable_Assignment_SPARK --
6261 -------------------------------------------------------
6263 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
6265 Asmt_Rep
: Scenario_Rep_Id
;
6267 Var_Rep
: Target_Rep_Id
;
6268 In_State
: Processing_In_State
)
6270 pragma Unreferenced
(Asmt_Rep
);
6272 Var_Decl
: constant Node_Id
:= Variable_Declaration
(Var_Rep
);
6273 Unit_Id
: constant Entity_Id
:= Unit
(Var_Rep
);
6276 -- Ensure that a suitable elaboration model is in effect for SPARK
6277 -- rule verification.
6279 Check_SPARK_Model_In_Effect
;
6281 -- Do not emit any ABE diagnostics when a previous scenario in this
6282 -- traversal has suppressed elaboration warnings.
6284 if In_State
.Suppress_Warnings
then
6287 -- Emit an error when an initialized variable declared in a package
6288 -- spec that is missing pragma Elaborate_Body is further modified by
6289 -- elaboration code within the corresponding body.
6291 elsif Is_Elaboration_Warnings_OK_Id
(Var_Id
)
6292 and then Is_Initialized
(Var_Decl
)
6293 and then not Has_Pragma_Elaborate_Body
(Unit_Id
)
6296 ("variable & modified by elaboration code in package body",
6300 ("\add pragma ""Elaborate_Body"" to spec & to ensure full "
6301 & "initialization", Asmt
, Unit_Id
);
6303 Output_Active_Scenarios
(Asmt
, In_State
);
6305 end Process_Conditional_ABE_Variable_Assignment_SPARK
;
6307 ------------------------------------------------
6308 -- Process_Conditional_ABE_Variable_Reference --
6309 ------------------------------------------------
6311 procedure Process_Conditional_ABE_Variable_Reference
6313 Ref_Rep
: Scenario_Rep_Id
;
6314 In_State
: Processing_In_State
)
6316 Var_Id
: constant Entity_Id
:= Target
(Ref
);
6317 Var_Rep
: Target_Rep_Id
;
6318 Unit_Id
: Entity_Id
;
6321 -- Nothing to do when the variable reference is not a read
6323 if not Is_Read_Reference
(Ref_Rep
) then
6327 Var_Rep
:= Target_Representation_Of
(Var_Id
, In_State
);
6328 Unit_Id
:= Unit
(Var_Rep
);
6330 -- Output relevant information when switch -gnatel (info messages on
6331 -- implicit Elaborate[_All] pragmas) is in effect.
6333 if Elab_Info_Messages
6334 and then not In_State
.Suppress_Info_Messages
6337 (Msg
=> "read of variable & during elaboration",
6344 -- Nothing to do when the variable appears within the main unit
6345 -- because diagnostics on reads are relevant only for external
6348 if Is_Same_Unit
(Unit_Id
, Main_Unit_Entity
) then
6351 -- Nothing to do when the variable is already initialized. Note that
6352 -- the variable may be further modified by the external unit.
6354 elsif Is_Initialized
(Variable_Declaration
(Var_Rep
)) then
6357 -- Nothing to do when the external unit guarantees the initialization
6358 -- of the variable by means of pragma Elaborate_Body.
6360 elsif Has_Pragma_Elaborate_Body
(Unit_Id
) then
6363 -- A variable read imposes an Elaborate requirement on the context of
6364 -- the main unit. Determine whether the context has a pragma strong
6365 -- enough to meet the requirement.
6368 Meet_Elaboration_Requirement
6371 Req_Nam
=> Name_Elaborate
,
6372 In_State
=> In_State
);
6374 end Process_Conditional_ABE_Variable_Reference
;
6376 -----------------------------------
6377 -- Traverse_Conditional_ABE_Body --
6378 -----------------------------------
6380 procedure Traverse_Conditional_ABE_Body
6382 In_State
: Processing_In_State
)
6387 Requires_Processing
=> Is_Conditional_ABE_Scenario
'Access,
6388 Processor
=> Process_Conditional_ABE
'Access,
6389 In_State
=> In_State
);
6390 end Traverse_Conditional_ABE_Body
;
6391 end Conditional_ABE_Processor
;
6397 procedure Destroy
(NE
: in out Node_Or_Entity_Id
) is
6398 pragma Unreferenced
(NE
);
6407 package body Diagnostics
is
6413 procedure Elab_Msg_NE
6420 function Prefix
return String;
6421 pragma Inline
(Prefix
);
6422 -- Obtain the prefix of the message
6424 function Suffix
return String;
6425 pragma Inline
(Suffix
);
6426 -- Obtain the suffix of the message
6432 function Prefix
return String is
6445 function Suffix
return String is
6454 -- Start of processing for Elab_Msg_NE
6457 Error_Msg_NE
(Prefix
& Msg
& Suffix
, N
, Id
);
6466 Subp_Id
: Entity_Id
;
6470 procedure Info_Accept_Alternative
;
6471 pragma Inline
(Info_Accept_Alternative
);
6472 -- Output information concerning an accept alternative
6474 procedure Info_Simple_Call
;
6475 pragma Inline
(Info_Simple_Call
);
6476 -- Output information concerning the call
6478 procedure Info_Type_Actions
(Action
: String);
6479 pragma Inline
(Info_Type_Actions
);
6480 -- Output information concerning action Action of a type
6482 procedure Info_Verification_Call
6486 pragma Inline
(Info_Verification_Call
);
6487 -- Output information concerning the verification of predicate Pred
6488 -- applied to related entity Id with kind Id_Kind.
6490 -----------------------------
6491 -- Info_Accept_Alternative --
6492 -----------------------------
6494 procedure Info_Accept_Alternative
is
6495 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Subp_Id
);
6496 pragma Assert
(Present
(Entry_Id
));
6500 (Msg
=> "accept for entry & during elaboration",
6503 Info_Msg
=> Info_Msg
,
6504 In_SPARK
=> In_SPARK
);
6505 end Info_Accept_Alternative
;
6507 ----------------------
6508 -- Info_Simple_Call --
6509 ----------------------
6511 procedure Info_Simple_Call
is
6514 (Msg
=> "call to & during elaboration",
6517 Info_Msg
=> Info_Msg
,
6518 In_SPARK
=> In_SPARK
);
6519 end Info_Simple_Call
;
6521 -----------------------
6522 -- Info_Type_Actions --
6523 -----------------------
6525 procedure Info_Type_Actions
(Action
: String) is
6526 Typ
: constant Entity_Id
:= First_Formal_Type
(Subp_Id
);
6527 pragma Assert
(Present
(Typ
));
6531 (Msg
=> Action
& " actions for type & during elaboration",
6534 Info_Msg
=> Info_Msg
,
6535 In_SPARK
=> In_SPARK
);
6536 end Info_Type_Actions
;
6538 ----------------------------
6539 -- Info_Verification_Call --
6540 ----------------------------
6542 procedure Info_Verification_Call
6547 pragma Assert
(Present
(Id
));
6552 "verification of " & Pred
& " of " & Id_Kind
& " & during "
6556 Info_Msg
=> Info_Msg
,
6557 In_SPARK
=> In_SPARK
);
6558 end Info_Verification_Call
;
6560 -- Start of processing for Info_Call
6563 -- Do not output anything for targets defined in internal units
6564 -- because this creates noise.
6566 if not In_Internal_Unit
(Subp_Id
) then
6568 -- Accept alternative
6570 if Is_Accept_Alternative_Proc
(Subp_Id
) then
6571 Info_Accept_Alternative
;
6575 elsif Is_TSS
(Subp_Id
, TSS_Deep_Adjust
) then
6576 Info_Type_Actions
("adjustment");
6578 -- Default_Initial_Condition
6580 elsif Is_Default_Initial_Condition_Proc
(Subp_Id
) then
6581 Info_Verification_Call
6582 (Pred
=> "Default_Initial_Condition",
6583 Id
=> First_Formal_Type
(Subp_Id
),
6588 elsif Is_Protected_Entry
(Subp_Id
) then
6591 -- Task entry calls are never processed because the entry being
6592 -- invoked does not have a corresponding "body", it has a select.
6594 elsif Is_Task_Entry
(Subp_Id
) then
6599 elsif Is_TSS
(Subp_Id
, TSS_Deep_Finalize
) then
6600 Info_Type_Actions
("finalization");
6602 -- Calls to _Finalizer procedures must not appear in the output
6603 -- because this creates confusing noise.
6605 elsif Is_Finalizer
(Subp_Id
) then
6608 -- Initial_Condition
6610 elsif Is_Initial_Condition_Proc
(Subp_Id
) then
6611 Info_Verification_Call
6612 (Pred
=> "Initial_Condition",
6613 Id
=> Find_Enclosing_Scope
(Call
),
6614 Id_Kind
=> "package");
6618 elsif Is_Init_Proc
(Subp_Id
)
6619 or else Is_TSS
(Subp_Id
, TSS_Deep_Initialize
)
6621 Info_Type_Actions
("initialization");
6625 elsif Is_Invariant_Proc
(Subp_Id
) then
6626 Info_Verification_Call
6627 (Pred
=> "invariants",
6628 Id
=> First_Formal_Type
(Subp_Id
),
6631 -- Partial invariant calls must not appear in the output because
6632 -- this creates confusing noise.
6634 elsif Is_Partial_Invariant_Proc
(Subp_Id
) then
6637 -- Subprograms must come last because some of the previous cases
6638 -- fall under this category.
6640 elsif Ekind
(Subp_Id
) = E_Function
then
6643 elsif Ekind
(Subp_Id
) = E_Procedure
then
6647 pragma Assert
(False);
6653 ------------------------
6654 -- Info_Instantiation --
6655 ------------------------
6657 procedure Info_Instantiation
6665 (Msg
=> "instantiation of & during elaboration",
6668 Info_Msg
=> Info_Msg
,
6669 In_SPARK
=> In_SPARK
);
6670 end Info_Instantiation
;
6672 -----------------------------
6673 -- Info_Variable_Reference --
6674 -----------------------------
6676 procedure Info_Variable_Reference
6681 if Is_Read
(Ref
) then
6683 (Msg
=> "read of variable & during elaboration",
6689 end Info_Variable_Reference
;
6692 ---------------------------------
6693 -- Early_Call_Region_Processor --
6694 ---------------------------------
6696 package body Early_Call_Region_Processor
is
6698 ---------------------
6699 -- Data structures --
6700 ---------------------
6702 -- The following map relates early call regions to subprogram bodies
6704 procedure Destroy
(N
: in out Node_Id
);
6707 package ECR_Map
is new Dynamic_Hash_Tables
6708 (Key_Type
=> Entity_Id
,
6709 Value_Type
=> Node_Id
,
6711 Expansion_Threshold
=> 1.5,
6712 Expansion_Factor
=> 2,
6713 Compression_Threshold
=> 0.3,
6714 Compression_Factor
=> 2,
6716 Destroy_Value
=> Destroy
,
6719 Early_Call_Regions_Map
: ECR_Map
.Dynamic_Hash_Table
:= ECR_Map
.Nil
;
6721 -----------------------
6722 -- Local subprograms --
6723 -----------------------
6725 function Early_Call_Region
(Body_Id
: Entity_Id
) return Node_Id
;
6726 pragma Inline
(Early_Call_Region
);
6727 -- Obtain the early call region associated with entry or subprogram body
6730 procedure Set_Early_Call_Region
(Body_Id
: Entity_Id
; Start
: Node_Id
);
6731 pragma Inline
(Set_Early_Call_Region
);
6732 -- Associate an early call region with begins at construct Start with
6733 -- entry or subprogram body Body_Id.
6739 procedure Destroy
(N
: in out Node_Id
) is
6740 pragma Unreferenced
(N
);
6745 -----------------------
6746 -- Early_Call_Region --
6747 -----------------------
6749 function Early_Call_Region
(Body_Id
: Entity_Id
) return Node_Id
is
6750 pragma Assert
(Present
(Body_Id
));
6752 return ECR_Map
.Get
(Early_Call_Regions_Map
, Body_Id
);
6753 end Early_Call_Region
;
6755 ------------------------------------------
6756 -- Finalize_Early_Call_Region_Processor --
6757 ------------------------------------------
6759 procedure Finalize_Early_Call_Region_Processor
is
6761 ECR_Map
.Destroy
(Early_Call_Regions_Map
);
6762 end Finalize_Early_Call_Region_Processor
;
6764 ----------------------------
6765 -- Find_Early_Call_Region --
6766 ----------------------------
6768 function Find_Early_Call_Region
6769 (Body_Decl
: Node_Id
;
6770 Assume_Elab_Body
: Boolean := False;
6771 Skip_Memoization
: Boolean := False) return Node_Id
6773 -- NOTE: The routines within Find_Early_Call_Region are intentionally
6774 -- unnested to avoid deep indentation of code.
6776 ECR_Found
: exception;
6777 -- This exception is raised when the early call region has been found
6779 Start
: Node_Id
:= Empty
;
6780 -- The start of the early call region. This variable is updated by
6781 -- the various nested routines. Due to the use of exceptions, the
6782 -- variable must be global to the nested routines.
6784 -- The algorithm implemented in this routine attempts to find the
6785 -- early call region of a subprogram body by inspecting constructs
6786 -- in reverse declarative order, while navigating the tree. The
6787 -- algorithm consists of an Inspection phase and Advancement phase.
6788 -- The pseudocode is as follows:
6792 -- advancement phase
6795 -- The infinite loop is terminated by raising exception ECR_Found.
6796 -- The algorithm utilizes two pointers, Curr and Start, to represent
6797 -- the current construct to inspect and the start of the early call
6800 -- IMPORTANT: The algorithm must maintain the following invariant at
6801 -- all time for it to function properly:
6803 -- A nested construct is entered only when it contains suitable
6806 -- This guarantees that leaving a nested or encapsulating construct
6807 -- functions properly.
6809 -- The Inspection phase determines whether the current construct is
6810 -- non-preelaborable, and if it is, the algorithm terminates.
6812 -- The Advancement phase walks the tree in reverse declarative order,
6813 -- while entering and leaving nested and encapsulating constructs. It
6814 -- may also terminate the elaborithm. There are several special cases
6821 -- <construct N-1> <- Curr
6822 -- <construct N> <- Start
6823 -- <subprogram body>
6825 -- In the general case, a declarative or statement list is traversed
6826 -- in reverse order where Curr is the lead pointer, and Start is the
6827 -- last preelaborable construct.
6829 -- 2) Entering handled bodies
6831 -- package body Nested is <- Curr (2.3)
6832 -- <declarations> <- Curr (2.2)
6834 -- <statements> <- Curr (2.1)
6836 -- <construct> <- Start
6838 -- In this case, the algorithm enters a handled body by starting from
6839 -- the last statement (2.1), or the last declaration (2.2), or the
6840 -- body is consumed (2.3) because it is empty and thus preelaborable.
6842 -- 3) Entering package declarations
6844 -- package Nested is <- Curr (2.3)
6845 -- <visible declarations> <- Curr (2.2)
6847 -- <private declarations> <- Curr (2.1)
6849 -- <construct> <- Start
6851 -- In this case, the algorithm enters a package declaration by
6852 -- starting from the last private declaration (2.1), the last visible
6853 -- declaration (2.2), or the package is consumed (2.3) because it is
6854 -- empty and thus preelaborable.
6856 -- 4) Transitioning from list to list of the same construct
6858 -- Certain constructs have two eligible lists. The algorithm must
6859 -- thus transition from the second to the first list when the second
6860 -- list is exhausted.
6862 -- declare <- Curr (4.2)
6863 -- <declarations> <- Curr (4.1)
6865 -- <statements> <- Start
6868 -- In this case, the algorithm has exhausted the second list (the
6869 -- statements in the example above), and continues with the last
6870 -- declaration (4.1) or the construct is consumed (4.2) because it
6871 -- contains only preelaborable code.
6873 -- 5) Transitioning from list to construct
6875 -- tack body Task is <- Curr (5.1)
6877 -- <construct 1> <- Start
6879 -- In this case, the algorithm has exhausted a list, Curr is Empty,
6880 -- and the owner of the list is consumed (5.1).
6882 -- 6) Transitioning from unit to unit
6884 -- A package body with a spec subject to pragma Elaborate_Body
6885 -- extends the possible range of the early call region to the package
6888 -- package Pack is <- Curr (6.3)
6889 -- pragma Elaborate_Body; <- Curr (6.2)
6890 -- <visible declarations> <- Curr (6.2)
6892 -- <private declarations> <- Curr (6.1)
6895 -- package body Pack is <- Curr, Start
6897 -- In this case, the algorithm has reached a package body compilation
6898 -- unit whose spec is subject to pragma Elaborate_Body, or the caller
6899 -- of the algorithm has specified this behavior. This transition is
6900 -- equivalent to 3).
6902 -- 7) Transitioning from unit to termination
6904 -- Reaching a compilation unit always terminates the algorithm as
6905 -- there are no more lists to examine. This must take case 6) into
6908 -- 8) Transitioning from subunit to stub
6910 -- package body Pack is separate; <- Curr (8.1)
6913 -- package body Pack is <- Curr, Start
6915 -- Reaching a subunit continues the search from the corresponding
6918 procedure Advance
(Curr
: in out Node_Id
);
6919 pragma Inline
(Advance
);
6920 -- Update the Curr and Start pointers depending on their location
6921 -- in the tree to the next eligible construct. This routine raises
6924 procedure Enter_Handled_Body
(Curr
: in out Node_Id
);
6925 pragma Inline
(Enter_Handled_Body
);
6926 -- Update the Curr and Start pointers to enter a nested handled body
6927 -- if applicable. This routine raises ECR_Found.
6929 procedure Enter_Package_Declaration
(Curr
: in out Node_Id
);
6930 pragma Inline
(Enter_Package_Declaration
);
6931 -- Update the Curr and Start pointers to enter a nested package spec
6932 -- if applicable. This routine raises ECR_Found.
6934 function Find_ECR
(N
: Node_Id
) return Node_Id
;
6935 pragma Inline
(Find_ECR
);
6936 -- Find an early call region starting from arbitrary node N
6938 function Has_Suitable_Construct
(List
: List_Id
) return Boolean;
6939 pragma Inline
(Has_Suitable_Construct
);
6940 -- Determine whether list List contains a suitable construct for
6941 -- inclusion into an early call region.
6943 procedure Include
(N
: Node_Id
; Curr
: out Node_Id
);
6944 pragma Inline
(Include
);
6945 -- Update the Curr and Start pointers to include arbitrary construct
6946 -- N in the early call region. This routine raises ECR_Found.
6948 function Is_OK_Preelaborable_Construct
(N
: Node_Id
) return Boolean;
6949 pragma Inline
(Is_OK_Preelaborable_Construct
);
6950 -- Determine whether arbitrary node N denotes a preelaboration-safe
6953 function Is_Suitable_Construct
(N
: Node_Id
) return Boolean;
6954 pragma Inline
(Is_Suitable_Construct
);
6955 -- Determine whether arbitrary node N denotes a suitable construct
6956 -- for inclusion into the early call region.
6958 function Previous_Suitable_Construct
(N
: Node_Id
) return Node_Id
;
6959 pragma Inline
(Previous_Suitable_Construct
);
6960 -- Return the previous node suitable for inclusion into the early
6963 procedure Transition_Body_Declarations
6965 Curr
: out Node_Id
);
6966 pragma Inline
(Transition_Body_Declarations
);
6967 -- Update the Curr and Start pointers when construct Bod denotes a
6968 -- block statement or a suitable body. This routine raises ECR_Found.
6970 procedure Transition_Handled_Statements
6972 Curr
: out Node_Id
);
6973 pragma Inline
(Transition_Handled_Statements
);
6974 -- Update the Curr and Start pointers when node HSS denotes a handled
6975 -- sequence of statements. This routine raises ECR_Found.
6977 procedure Transition_Spec_Declarations
6979 Curr
: out Node_Id
);
6980 pragma Inline
(Transition_Spec_Declarations
);
6981 -- Update the Curr and Start pointers when construct Spec denotes
6982 -- a concurrent definition or a package spec. This routine raises
6985 procedure Transition_Unit
(Unit
: Node_Id
; Curr
: out Node_Id
);
6986 pragma Inline
(Transition_Unit
);
6987 -- Update the Curr and Start pointers when node Unit denotes a
6988 -- potential compilation unit. This routine raises ECR_Found.
6994 procedure Advance
(Curr
: in out Node_Id
) is
6998 -- Curr denotes one of the following cases upon entry into this
7001 -- * Empty - There is no current construct when a declarative or
7002 -- a statement list has been exhausted. This does not indicate
7003 -- that the early call region has been computed as it is still
7004 -- possible to transition to another list.
7006 -- * Encapsulator - The current construct wraps declarations
7007 -- and/or statements. This indicates that the early call
7008 -- region may extend within the nested construct.
7010 -- * Preelaborable - The current construct is preelaborable
7011 -- because Find_ECR would not invoke Advance if this was not
7014 -- The current construct is an encapsulator or is preelaborable
7016 if Present
(Curr
) then
7018 -- Enter encapsulators by inspecting their declarations and/or
7021 if Nkind
(Curr
) in N_Block_Statement | N_Package_Body
then
7022 Enter_Handled_Body
(Curr
);
7024 elsif Nkind
(Curr
) = N_Package_Declaration
then
7025 Enter_Package_Declaration
(Curr
);
7027 -- Early call regions have a property which can be exploited to
7028 -- optimize the algorithm.
7030 -- <preceding subprogram body>
7031 -- <preelaborable construct 1>
7033 -- <preelaborable construct N>
7034 -- <initiating subprogram body>
7036 -- If a traversal initiated from a subprogram body reaches a
7037 -- preceding subprogram body, then both bodies share the same
7038 -- early call region.
7040 -- The property results in the following desirable effects:
7042 -- * If the preceding body already has an early call region,
7043 -- then the initiating body can reuse it. This minimizes the
7044 -- amount of processing performed by the algorithm.
7046 -- * If the preceding body lack an early call region, then the
7047 -- algorithm can compute the early call region, and reuse it
7048 -- for the initiating body. This processing performs the same
7049 -- amount of work, but has the beneficial effect of computing
7050 -- the early call regions of all preceding bodies.
7052 elsif Nkind
(Curr
) in N_Entry_Body | N_Subprogram_Body
then
7054 Find_Early_Call_Region
7056 Assume_Elab_Body
=> Assume_Elab_Body
,
7057 Skip_Memoization
=> Skip_Memoization
);
7061 -- Otherwise current construct is preelaborable. Unpdate the
7062 -- early call region to include it.
7065 Include
(Curr
, Curr
);
7068 -- Otherwise the current construct is missing, indicating that the
7069 -- current list has been exhausted. Depending on the context of
7070 -- the list, several transitions are possible.
7073 -- The invariant of the algorithm ensures that Curr and Start
7074 -- are at the same level of nesting at the point of transition.
7075 -- The algorithm can determine which list the traversal came
7076 -- from by examining Start.
7078 Context
:= Parent
(Start
);
7080 -- Attempt the following transitions:
7082 -- private declarations -> visible declarations
7083 -- private declarations -> upper level
7084 -- private declarations -> terminate
7085 -- visible declarations -> upper level
7086 -- visible declarations -> terminate
7088 if Nkind
(Context
) in N_Package_Specification
7089 | N_Protected_Definition
7092 Transition_Spec_Declarations
(Context
, Curr
);
7094 -- Attempt the following transitions:
7096 -- statements -> declarations
7097 -- statements -> upper level
7098 -- statements -> corresponding package spec (Elab_Body)
7099 -- statements -> terminate
7101 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
7102 Transition_Handled_Statements
(Context
, Curr
);
7104 -- Attempt the following transitions:
7106 -- declarations -> upper level
7107 -- declarations -> corresponding package spec (Elab_Body)
7108 -- declarations -> terminate
7110 elsif Nkind
(Context
) in N_Block_Statement
7117 Transition_Body_Declarations
(Context
, Curr
);
7119 -- Otherwise it is not possible to transition. Stop the search
7120 -- because there are no more declarations or statements to
7129 --------------------------
7130 -- Enter_Handled_Body --
7131 --------------------------
7133 procedure Enter_Handled_Body
(Curr
: in out Node_Id
) is
7134 Decls
: constant List_Id
:= Declarations
(Curr
);
7135 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Curr
);
7136 Stmts
: List_Id
:= No_List
;
7139 if Present
(HSS
) then
7140 Stmts
:= Statements
(HSS
);
7143 -- The handled body has a non-empty statement sequence. The
7144 -- construct to inspect is the last statement.
7146 if Has_Suitable_Construct
(Stmts
) then
7147 Curr
:= Last
(Stmts
);
7149 -- The handled body lacks statements, but has non-empty
7150 -- declarations. The construct to inspect is the last declaration.
7152 elsif Has_Suitable_Construct
(Decls
) then
7153 Curr
:= Last
(Decls
);
7155 -- Otherwise the handled body lacks both declarations and
7156 -- statements. The construct to inspect is the node which precedes
7157 -- the handled body. Update the early call region to include the
7161 Include
(Curr
, Curr
);
7163 end Enter_Handled_Body
;
7165 -------------------------------
7166 -- Enter_Package_Declaration --
7167 -------------------------------
7169 procedure Enter_Package_Declaration
(Curr
: in out Node_Id
) is
7170 Pack_Spec
: constant Node_Id
:= Specification
(Curr
);
7171 Prv_Decls
: constant List_Id
:= Private_Declarations
(Pack_Spec
);
7172 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Pack_Spec
);
7175 -- The package has a non-empty private declarations. The construct
7176 -- to inspect is the last private declaration.
7178 if Has_Suitable_Construct
(Prv_Decls
) then
7179 Curr
:= Last
(Prv_Decls
);
7181 -- The package lacks private declarations, but has non-empty
7182 -- visible declarations. In this case the construct to inspect
7183 -- is the last visible declaration.
7185 elsif Has_Suitable_Construct
(Vis_Decls
) then
7186 Curr
:= Last
(Vis_Decls
);
7188 -- Otherwise the package lacks any declarations. The construct
7189 -- to inspect is the node which precedes the package. Update the
7190 -- early call region to include the package declaration.
7193 Include
(Curr
, Curr
);
7195 end Enter_Package_Declaration
;
7201 function Find_ECR
(N
: Node_Id
) return Node_Id
is
7205 -- The early call region starts at N
7207 Curr
:= Previous_Suitable_Construct
(N
);
7210 -- Inspect each node in reverse declarative order while going in
7211 -- and out of nested and enclosing constructs. Note that the only
7212 -- way to terminate this infinite loop is to raise ECR_Found.
7215 -- The current construct is not preelaboration-safe. Terminate
7219 and then not Is_OK_Preelaborable_Construct
(Curr
)
7224 -- Advance to the next suitable construct. This may terminate
7225 -- the traversal by raising ECR_Found.
7235 ----------------------------
7236 -- Has_Suitable_Construct --
7237 ----------------------------
7239 function Has_Suitable_Construct
(List
: List_Id
) return Boolean is
7243 -- Examine the list in reverse declarative order, looking for a
7244 -- suitable construct.
7246 if Present
(List
) then
7247 Item
:= Last
(List
);
7248 while Present
(Item
) loop
7249 if Is_Suitable_Construct
(Item
) then
7258 end Has_Suitable_Construct
;
7264 procedure Include
(N
: Node_Id
; Curr
: out Node_Id
) is
7268 -- The input node is a compilation unit. This terminates the
7269 -- search because there are no more lists to inspect and there are
7270 -- no more enclosing constructs to climb up to. The transitions
7273 -- private declarations -> terminate
7274 -- visible declarations -> terminate
7275 -- statements -> terminate
7276 -- declarations -> terminate
7278 if Nkind
(Parent
(Start
)) = N_Compilation_Unit
then
7281 -- Otherwise the input node is still within some list
7284 Curr
:= Previous_Suitable_Construct
(Start
);
7288 -----------------------------------
7289 -- Is_OK_Preelaborable_Construct --
7290 -----------------------------------
7292 function Is_OK_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
7294 -- Assignment statements are acceptable as long as they were
7295 -- produced by the ABE mechanism to update elaboration flags.
7297 if Nkind
(N
) = N_Assignment_Statement
then
7298 return Is_Elaboration_Code
(N
);
7300 -- Block statements are acceptable even though they directly
7301 -- violate preelaborability. The intention is not to penalize
7302 -- the early call region when a block contains only preelaborable
7306 -- Val : constant Integer := 1;
7308 -- pragma Assert (Val = 1);
7312 -- Note that the Advancement phase does enter blocks, and will
7313 -- detect any non-preelaborable declarations or statements within.
7315 elsif Nkind
(N
) = N_Block_Statement
then
7319 -- Otherwise the construct must be preelaborable. The check must
7320 -- take the syntactic and semantic structure of the construct. DO
7321 -- NOT use Is_Preelaborable_Construct here.
7323 return not Is_Non_Preelaborable_Construct
(N
);
7324 end Is_OK_Preelaborable_Construct
;
7326 ---------------------------
7327 -- Is_Suitable_Construct --
7328 ---------------------------
7330 function Is_Suitable_Construct
(N
: Node_Id
) return Boolean is
7331 Context
: constant Node_Id
:= Parent
(N
);
7334 -- An internally-generated statement sequence which contains only
7335 -- a single null statement is not a suitable construct because it
7336 -- is a byproduct of the parser. Such a null statement should be
7337 -- excluded from the early call region because it carries the
7338 -- source location of the "end" keyword, and may lead to confusing
7341 if Nkind
(N
) = N_Null_Statement
7342 and then not Comes_From_Source
(N
)
7343 and then Present
(Context
)
7344 and then Nkind
(Context
) = N_Handled_Sequence_Of_Statements
7348 -- Similarly, internally-generated objects and types may have
7349 -- out-of-order source locations that confuse diagnostics, e.g.
7350 -- source locations in the body for objects/types generated in
7353 elsif Nkind
(N
) in N_Full_Type_Declaration | N_Object_Declaration
7354 and then not Comes_From_Source
(N
)
7359 -- Otherwise only constructs which correspond to pure Ada
7360 -- constructs are considered suitable.
7365 | N_Freeze_Generic_Entity
7366 | N_Implicit_Label_Declaration
7368 | N_Pop_Constraint_Error_Label
7369 | N_Pop_Program_Error_Label
7370 | N_Pop_Storage_Error_Label
7371 | N_Push_Constraint_Error_Label
7372 | N_Push_Program_Error_Label
7373 | N_Push_Storage_Error_Label
7374 | N_SCIL_Dispatch_Table_Tag_Init
7375 | N_SCIL_Dispatching_Call
7376 | N_SCIL_Membership_Test
7377 | N_Variable_Reference_Marker
7384 end Is_Suitable_Construct
;
7386 ---------------------------------
7387 -- Previous_Suitable_Construct --
7388 ---------------------------------
7390 function Previous_Suitable_Construct
(N
: Node_Id
) return Node_Id
is
7396 while Present
(P
) and then not Is_Suitable_Construct
(P
) loop
7401 end Previous_Suitable_Construct
;
7403 ----------------------------------
7404 -- Transition_Body_Declarations --
7405 ----------------------------------
7407 procedure Transition_Body_Declarations
7411 Decls
: constant List_Id
:= Declarations
(Bod
);
7414 -- The search must come from the declarations of the body
7417 (Is_Non_Empty_List
(Decls
)
7418 and then List_Containing
(Start
) = Decls
);
7420 -- The search finished inspecting the declarations. The construct
7421 -- to inspect is the node which precedes the handled body, unless
7422 -- the body is a compilation unit. The transitions are:
7424 -- declarations -> upper level
7425 -- declarations -> corresponding package spec (Elab_Body)
7426 -- declarations -> terminate
7428 Transition_Unit
(Bod
, Curr
);
7429 end Transition_Body_Declarations
;
7431 -----------------------------------
7432 -- Transition_Handled_Statements --
7433 -----------------------------------
7435 procedure Transition_Handled_Statements
7439 Bod
: constant Node_Id
:= Parent
(HSS
);
7440 Decls
: constant List_Id
:= Declarations
(Bod
);
7441 Stmts
: constant List_Id
:= Statements
(HSS
);
7444 -- The search must come from the statements of certain bodies or
7456 -- The search must come from the statements of the handled
7460 (Is_Non_Empty_List
(Stmts
)
7461 and then List_Containing
(Start
) = Stmts
);
7463 -- The search finished inspecting the statements. The handled body
7464 -- has non-empty declarations. The construct to inspect is the
7465 -- last declaration. The transitions are:
7467 -- statements -> declarations
7469 if Has_Suitable_Construct
(Decls
) then
7470 Curr
:= Last
(Decls
);
7472 -- Otherwise the handled body lacks declarations. The construct to
7473 -- inspect is the node which precedes the handled body, unless the
7474 -- body is a compilation unit. The transitions are:
7476 -- statements -> upper level
7477 -- statements -> corresponding package spec (Elab_Body)
7478 -- statements -> terminate
7481 Transition_Unit
(Bod
, Curr
);
7483 end Transition_Handled_Statements
;
7485 ----------------------------------
7486 -- Transition_Spec_Declarations --
7487 ----------------------------------
7489 procedure Transition_Spec_Declarations
7493 Prv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
7494 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
7497 pragma Assert
(Present
(Start
) and then Is_List_Member
(Start
));
7499 -- The search came from the private declarations and finished
7500 -- their inspection.
7502 if Has_Suitable_Construct
(Prv_Decls
)
7503 and then List_Containing
(Start
) = Prv_Decls
7505 -- The context has non-empty visible declarations. The node to
7506 -- inspect is the last visible declaration. The transitions
7509 -- private declarations -> visible declarations
7511 if Has_Suitable_Construct
(Vis_Decls
) then
7512 Curr
:= Last
(Vis_Decls
);
7514 -- Otherwise the context lacks visible declarations. The
7515 -- construct to inspect is the node which precedes the context
7516 -- unless the context is a compilation unit. The transitions
7519 -- private declarations -> upper level
7520 -- private declarations -> terminate
7523 Transition_Unit
(Parent
(Spec
), Curr
);
7526 -- The search came from the visible declarations and finished
7527 -- their inspections. The construct to inspect is the node which
7528 -- precedes the context, unless the context is a compilaton unit.
7529 -- The transitions are:
7531 -- visible declarations -> upper level
7532 -- visible declarations -> terminate
7534 elsif Has_Suitable_Construct
(Vis_Decls
)
7535 and then List_Containing
(Start
) = Vis_Decls
7537 Transition_Unit
(Parent
(Spec
), Curr
);
7539 -- At this point both declarative lists are empty, but the
7540 -- traversal still came from within the spec. This indicates
7541 -- that the invariant of the algorithm has been violated.
7544 pragma Assert
(False);
7547 end Transition_Spec_Declarations
;
7549 ---------------------
7550 -- Transition_Unit --
7551 ---------------------
7553 procedure Transition_Unit
7557 Context
: constant Node_Id
:= Parent
(Unit
);
7560 -- The unit is a compilation unit. This terminates the search
7561 -- because there are no more lists to inspect and there are no
7562 -- more enclosing constructs to climb up to.
7564 if Nkind
(Context
) = N_Compilation_Unit
then
7566 -- A package body with a corresponding spec subject to pragma
7567 -- Elaborate_Body is an exception to the above. The annotation
7568 -- allows the search to continue into the package declaration.
7569 -- The transitions are:
7571 -- statements -> corresponding package spec (Elab_Body)
7572 -- declarations -> corresponding package spec (Elab_Body)
7574 if Nkind
(Unit
) = N_Package_Body
7575 and then (Assume_Elab_Body
7576 or else Has_Pragma_Elaborate_Body
7577 (Corresponding_Spec
(Unit
)))
7579 Curr
:= Unit_Declaration_Node
(Corresponding_Spec
(Unit
));
7580 Enter_Package_Declaration
(Curr
);
7582 -- Otherwise terminate the search. The transitions are:
7584 -- private declarations -> terminate
7585 -- visible declarations -> terminate
7586 -- statements -> terminate
7587 -- declarations -> terminate
7593 -- The unit is a subunit. The construct to inspect is the node
7594 -- which precedes the corresponding stub. Update the early call
7595 -- region to include the unit.
7597 elsif Nkind
(Context
) = N_Subunit
then
7599 Curr
:= Corresponding_Stub
(Context
);
7601 -- Otherwise the unit is nested. The construct to inspect is the
7602 -- node which precedes the unit. Update the early call region to
7603 -- include the unit.
7606 Include
(Unit
, Curr
);
7608 end Transition_Unit
;
7612 Body_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Body_Decl
);
7615 -- Start of processing for Find_Early_Call_Region
7618 -- The caller demands the start of the early call region without
7619 -- saving or retrieving it to/from internal data structures.
7621 if Skip_Memoization
then
7622 Region
:= Find_ECR
(Body_Decl
);
7627 -- Check whether the early call region of the subprogram body is
7630 Region
:= Early_Call_Region
(Body_Id
);
7633 Region
:= Find_ECR
(Body_Decl
);
7635 -- Associate the early call region with the subprogram body in
7636 -- case other scenarios need it.
7638 Set_Early_Call_Region
(Body_Id
, Region
);
7642 -- A subprogram body must always have an early call region
7644 pragma Assert
(Present
(Region
));
7647 end Find_Early_Call_Region
;
7649 --------------------------------------------
7650 -- Initialize_Early_Call_Region_Processor --
7651 --------------------------------------------
7653 procedure Initialize_Early_Call_Region_Processor
is
7655 Early_Call_Regions_Map
:= ECR_Map
.Create
(100);
7656 end Initialize_Early_Call_Region_Processor
;
7658 ---------------------------
7659 -- Set_Early_Call_Region --
7660 ---------------------------
7662 procedure Set_Early_Call_Region
(Body_Id
: Entity_Id
; Start
: Node_Id
) is
7663 pragma Assert
(Present
(Body_Id
));
7664 pragma Assert
(Present
(Start
));
7667 ECR_Map
.Put
(Early_Call_Regions_Map
, Body_Id
, Start
);
7668 end Set_Early_Call_Region
;
7669 end Early_Call_Region_Processor
;
7671 ----------------------
7672 -- Elaborated_Units --
7673 ----------------------
7675 package body Elaborated_Units
is
7681 -- The following type idenfities the elaboration attributes of a unit
7683 type Elaboration_Attributes_Id
is new Natural;
7685 No_Elaboration_Attributes
: constant Elaboration_Attributes_Id
:=
7686 Elaboration_Attributes_Id
'First;
7687 First_Elaboration_Attributes
: constant Elaboration_Attributes_Id
:=
7688 No_Elaboration_Attributes
+ 1;
7690 -- The following type represents the elaboration attributes of a unit
7692 type Elaboration_Attributes_Record
is record
7693 Elab_Pragma
: Node_Id
:= Empty
;
7694 -- This attribute denotes a source Elaborate or Elaborate_All pragma
7695 -- which guarantees the prior elaboration of some unit with respect
7696 -- to the main unit. The pragma may come from the following contexts:
7699 -- * The spec of the main unit (if applicable)
7700 -- * Any parent spec of the main unit (if applicable)
7701 -- * Any parent subunit of the main unit (if applicable)
7703 -- The attribute remains Empty if no such pragma is available. Source
7704 -- pragmas play a role in satisfying SPARK elaboration requirements.
7706 With_Clause
: Node_Id
:= Empty
;
7707 -- This attribute denotes an internally-generated or a source with
7708 -- clause for some unit withed by the main unit. With clauses carry
7709 -- flags which represent implicit Elaborate or Elaborate_All pragmas.
7710 -- These clauses play a role in supplying elaboration dependencies to
7714 ---------------------
7715 -- Data structures --
7716 ---------------------
7718 -- The following table stores all elaboration attributes
7720 package Elaboration_Attributes
is new Table
.Table
7721 (Table_Index_Type
=> Elaboration_Attributes_Id
,
7722 Table_Component_Type
=> Elaboration_Attributes_Record
,
7723 Table_Low_Bound
=> First_Elaboration_Attributes
,
7724 Table_Initial
=> 250,
7725 Table_Increment
=> 200,
7726 Table_Name
=> "Elaboration_Attributes");
7728 procedure Destroy
(EA_Id
: in out Elaboration_Attributes_Id
);
7729 -- Destroy elaboration attributes EA_Id
7731 package UA_Map
is new Dynamic_Hash_Tables
7732 (Key_Type
=> Entity_Id
,
7733 Value_Type
=> Elaboration_Attributes_Id
,
7734 No_Value
=> No_Elaboration_Attributes
,
7735 Expansion_Threshold
=> 1.5,
7736 Expansion_Factor
=> 2,
7737 Compression_Threshold
=> 0.3,
7738 Compression_Factor
=> 2,
7740 Destroy_Value
=> Destroy
,
7743 -- The following map relates an elaboration attributes of a unit to the
7746 Unit_To_Attributes_Map
: UA_Map
.Dynamic_Hash_Table
:= UA_Map
.Nil
;
7752 function Elaboration_Attributes_Of
7753 (Unit_Id
: Entity_Id
) return Elaboration_Attributes_Id
;
7754 pragma Inline
(Elaboration_Attributes_Of
);
7755 -- Obtain the elaboration attributes of unit Unit_Id
7757 -----------------------
7758 -- Local subprograms --
7759 -----------------------
7761 function Elab_Pragma
(EA_Id
: Elaboration_Attributes_Id
) return Node_Id
;
7762 pragma Inline
(Elab_Pragma
);
7763 -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id
7765 procedure Ensure_Prior_Elaboration_Dynamic
7767 Unit_Id
: Entity_Id
;
7769 In_State
: Processing_In_State
);
7770 pragma Inline
(Ensure_Prior_Elaboration_Dynamic
);
7771 -- Guarantee the elaboration of unit Unit_Id with respect to the main
7772 -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N
7773 -- denotes the related scenario. In_State is the current state of the
7774 -- Processing phase.
7776 procedure Ensure_Prior_Elaboration_Static
7778 Unit_Id
: Entity_Id
;
7780 In_State
: Processing_In_State
);
7781 pragma Inline
(Ensure_Prior_Elaboration_Static
);
7782 -- Guarantee the elaboration of unit Unit_Id with respect to the main
7783 -- unit by installing an implicit Elaborate[_All] pragma with name
7784 -- Prag_Nam. N denotes the related scenario. In_State is the current
7785 -- state of the Processing phase.
7787 function Present
(EA_Id
: Elaboration_Attributes_Id
) return Boolean;
7788 pragma Inline
(Present
);
7789 -- Determine whether elaboration attributes UA_Id exist
7791 procedure Set_Elab_Pragma
7792 (EA_Id
: Elaboration_Attributes_Id
;
7794 pragma Inline
(Set_Elab_Pragma
);
7795 -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to
7798 procedure Set_With_Clause
7799 (EA_Id
: Elaboration_Attributes_Id
;
7801 pragma Inline
(Set_With_Clause
);
7802 -- Set the with clause of elaboration attributes EA_Id to Clause
7804 function With_Clause
(EA_Id
: Elaboration_Attributes_Id
) return Node_Id
;
7805 pragma Inline
(With_Clause
);
7806 -- Obtain the implicit or source with clause of elaboration attributes
7809 ------------------------------
7810 -- Collect_Elaborated_Units --
7811 ------------------------------
7813 procedure Collect_Elaborated_Units
is
7814 procedure Add_Pragma
(Prag
: Node_Id
);
7815 pragma Inline
(Add_Pragma
);
7816 -- Determine whether pragma Prag denotes a legal Elaborate[_All]
7817 -- pragma. If this is the case, add the related unit to the context.
7818 -- For pragma Elaborate_All, include recursively all units withed by
7819 -- the related unit.
7822 (Unit_Id
: Entity_Id
;
7824 Full_Context
: Boolean);
7825 pragma Inline
(Add_Unit
);
7826 -- Add unit Unit_Id to the elaboration context. Prag denotes the
7827 -- pragma which prompted the inclusion of the unit to the context.
7828 -- If flag Full_Context is set, examine the nonlimited clauses of
7829 -- unit Unit_Id and add each withed unit to the context.
7831 procedure Find_Elaboration_Context
(Comp_Unit
: Node_Id
);
7832 pragma Inline
(Find_Elaboration_Context
);
7833 -- Examine the context items of compilation unit Comp_Unit for
7834 -- suitable elaboration-related pragmas and add all related units
7841 procedure Add_Pragma
(Prag
: Node_Id
) is
7842 Prag_Args
: constant List_Id
:=
7843 Pragma_Argument_Associations
(Prag
);
7844 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
7848 -- Nothing to do if the pragma is not related to elaboration
7850 if Prag_Nam
not in Name_Elaborate | Name_Elaborate_All
then
7853 -- Nothing to do when the pragma is illegal
7855 elsif Error_Posted
(Prag
) then
7859 Unit_Arg
:= Get_Pragma_Arg
(First
(Prag_Args
));
7861 -- The argument of the pragma may appear in package.package form
7863 if Nkind
(Unit_Arg
) = N_Selected_Component
then
7864 Unit_Arg
:= Selector_Name
(Unit_Arg
);
7868 (Unit_Id
=> Entity
(Unit_Arg
),
7870 Full_Context
=> Prag_Nam
= Name_Elaborate_All
);
7878 (Unit_Id
: Entity_Id
;
7880 Full_Context
: Boolean)
7883 EA_Id
: Elaboration_Attributes_Id
;
7884 Unit_Prag
: Node_Id
;
7887 -- Nothing to do when some previous error left a with clause or a
7888 -- pragma in a bad state.
7890 if No
(Unit_Id
) then
7894 EA_Id
:= Elaboration_Attributes_Of
(Unit_Id
);
7895 Unit_Prag
:= Elab_Pragma
(EA_Id
);
7897 -- The unit is already included in the context by means of pragma
7900 if Present
(Unit_Prag
) then
7902 -- Upgrade an existing pragma Elaborate when the unit is
7903 -- subject to Elaborate_All because the new pragma covers a
7904 -- larger set of units.
7906 if Pragma_Name
(Unit_Prag
) = Name_Elaborate
7907 and then Pragma_Name
(Prag
) = Name_Elaborate_All
7909 Set_Elab_Pragma
(EA_Id
, Prag
);
7911 -- Otherwise the unit retains its existing pragma and does not
7912 -- need to be included in the context again.
7918 -- Otherwise the current unit is not included in the context
7921 Set_Elab_Pragma
(EA_Id
, Prag
);
7924 -- Includes all units withed by the current one when computing the
7927 if Full_Context
then
7929 -- Process all nonlimited with clauses found in the context of
7930 -- the current unit. Note that limited clauses do not impose an
7931 -- elaboration order.
7933 Clause
:= First
(Context_Items
(Compilation_Unit
(Unit_Id
)));
7934 while Present
(Clause
) loop
7935 if Nkind
(Clause
) = N_With_Clause
7936 and then not Error_Posted
(Clause
)
7937 and then not Limited_Present
(Clause
)
7940 (Unit_Id
=> Entity
(Name
(Clause
)),
7942 Full_Context
=> Full_Context
);
7950 ------------------------------
7951 -- Find_Elaboration_Context --
7952 ------------------------------
7954 procedure Find_Elaboration_Context
(Comp_Unit
: Node_Id
) is
7955 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
7960 -- Process all elaboration-related pragmas found in the context of
7961 -- the compilation unit.
7963 Prag
:= First
(Context_Items
(Comp_Unit
));
7964 while Present
(Prag
) loop
7965 if Nkind
(Prag
) = N_Pragma
then
7971 end Find_Elaboration_Context
;
7978 -- Start of processing for Collect_Elaborated_Units
7981 -- Perform a traversal to examines the context of the main unit. The
7982 -- traversal performs the following jumps:
7984 -- subunit -> parent subunit
7985 -- parent subunit -> body
7987 -- spec -> parent spec
7988 -- parent spec -> grandparent spec and so on
7990 -- The traversal relies on units rather than scopes because the scope
7991 -- of a subunit is some spec, while this traversal must process the
7992 -- body as well. Given that protected and task bodies can also be
7993 -- subunits, this complicates the scope approach even further.
7995 Unit_Id
:= Unit
(Cunit
(Main_Unit
));
7997 -- Perform the following traversals when the main unit is a subunit
7999 -- subunit -> parent subunit
8000 -- parent subunit -> body
8002 while Present
(Unit_Id
) and then Nkind
(Unit_Id
) = N_Subunit
loop
8003 Find_Elaboration_Context
(Parent
(Unit_Id
));
8005 -- Continue the traversal by going to the unit which contains the
8006 -- corresponding stub.
8008 if Present
(Corresponding_Stub
(Unit_Id
)) then
8010 Unit
(Cunit
(Get_Source_Unit
(Corresponding_Stub
(Unit_Id
))));
8012 -- Otherwise the subunit may be erroneous or left in a bad state
8019 -- Perform the following traversal now that subunits have been taken
8020 -- care of, or the main unit is a body.
8024 if Present
(Unit_Id
)
8025 and then Nkind
(Unit_Id
) in N_Package_Body | N_Subprogram_Body
8027 Find_Elaboration_Context
(Parent
(Unit_Id
));
8029 -- Continue the traversal by going to the unit which contains the
8030 -- corresponding spec.
8032 if Present
(Corresponding_Spec
(Unit_Id
)) then
8034 Unit
(Cunit
(Get_Source_Unit
(Corresponding_Spec
(Unit_Id
))));
8038 -- Perform the following traversals now that the body has been taken
8039 -- care of, or the main unit is a spec.
8041 -- spec -> parent spec
8042 -- parent spec -> grandparent spec and so on
8044 if Present
(Unit_Id
)
8045 and then Nkind
(Unit_Id
) in N_Generic_Package_Declaration
8046 | N_Generic_Subprogram_Declaration
8047 | N_Package_Declaration
8048 | N_Subprogram_Declaration
8050 Find_Elaboration_Context
(Parent
(Unit_Id
));
8052 -- Process a potential chain of parent units which ends with the
8053 -- main unit spec. The traversal can now safely rely on the scope
8056 Par_Id
:= Scope
(Defining_Entity
(Unit_Id
));
8057 while Present
(Par_Id
) and then Par_Id
/= Standard_Standard
loop
8058 Find_Elaboration_Context
(Compilation_Unit
(Par_Id
));
8060 Par_Id
:= Scope
(Par_Id
);
8063 end Collect_Elaborated_Units
;
8069 procedure Destroy
(EA_Id
: in out Elaboration_Attributes_Id
) is
8070 pragma Unreferenced
(EA_Id
);
8079 function Elab_Pragma
8080 (EA_Id
: Elaboration_Attributes_Id
) return Node_Id
8082 pragma Assert
(Present
(EA_Id
));
8084 return Elaboration_Attributes
.Table
(EA_Id
).Elab_Pragma
;
8087 -------------------------------
8088 -- Elaboration_Attributes_Of --
8089 -------------------------------
8091 function Elaboration_Attributes_Of
8092 (Unit_Id
: Entity_Id
) return Elaboration_Attributes_Id
8094 EA_Id
: Elaboration_Attributes_Id
;
8097 EA_Id
:= UA_Map
.Get
(Unit_To_Attributes_Map
, Unit_Id
);
8099 -- The unit lacks elaboration attributes. This indicates that the
8100 -- unit is encountered for the first time. Create the elaboration
8101 -- attributes for it.
8103 if not Present
(EA_Id
) then
8104 Elaboration_Attributes
.Append
8105 ((Elab_Pragma
=> Empty
,
8106 With_Clause
=> Empty
));
8107 EA_Id
:= Elaboration_Attributes
.Last
;
8109 -- Associate the elaboration attributes with the unit
8111 UA_Map
.Put
(Unit_To_Attributes_Map
, Unit_Id
, EA_Id
);
8114 pragma Assert
(Present
(EA_Id
));
8117 end Elaboration_Attributes_Of
;
8119 ------------------------------
8120 -- Ensure_Prior_Elaboration --
8121 ------------------------------
8123 procedure Ensure_Prior_Elaboration
8125 Unit_Id
: Entity_Id
;
8127 In_State
: Processing_In_State
)
8129 pragma Assert
(Prag_Nam
in Name_Elaborate | Name_Elaborate_All
);
8132 -- Nothing to do when the need for prior elaboration came from a
8133 -- partial finalization routine which occurs in an initialization
8134 -- context. This behavior parallels that of the old ABE mechanism.
8136 if In_State
.Within_Partial_Finalization
then
8139 -- Nothing to do when the need for prior elaboration came from a task
8140 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on
8141 -- task bodies) is in effect.
8143 elsif Debug_Flag_Dot_Y
and then In_State
.Within_Task_Body
then
8146 -- Nothing to do when the unit is elaborated prior to the main unit.
8147 -- This check must also consider the following cases:
8149 -- * No check is made against the context of the main unit because
8150 -- this is specific to the elaboration model in effect and requires
8151 -- custom handling (see Ensure_xxx_Prior_Elaboration).
8153 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
8154 -- Elaborate[_All] MUST be generated even though Unit_Id is always
8155 -- elaborated prior to the main unit. This conservative strategy
8156 -- ensures that other units withed by Unit_Id will not lead to an
8159 -- package A is package body A is
8160 -- procedure ABE; procedure ABE is ... end ABE;
8164 -- package B is package body B is
8165 -- pragma Elaborate_Body; procedure Proc is
8167 -- procedure Proc; A.ABE;
8168 -- package B; end Proc;
8172 -- package C is package body C is
8178 -- In the example above, the elaboration of C invokes B.Proc. B is
8179 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All]
8180 -- is gnerated for B in C, then the following elaboratio order will
8183 -- spec of A elaborated
8184 -- spec of B elaborated
8185 -- body of B elaborated
8186 -- spec of C elaborated
8187 -- body of C elaborated <-- calls B.Proc which calls A.ABE
8188 -- body of A elaborated <-- problem
8190 -- The generation of an implicit pragma Elaborate_All (B) ensures
8191 -- that the elaboration-order mechanism will not pick the above
8194 -- An implicit Elaborate is NOT generated when the unit is subject
8195 -- to Elaborate_Body because both pragmas have the same effect.
8197 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All]
8198 -- MUST NOT be generated in this case because a unit cannot depend
8199 -- on its own elaboration. This case is therefore treated as valid
8200 -- prior elaboration.
8202 elsif Has_Prior_Elaboration
8203 (Unit_Id
=> Unit_Id
,
8204 Same_Unit_OK
=> True,
8205 Elab_Body_OK
=> Prag_Nam
= Name_Elaborate
)
8210 -- Suggest the use of pragma Prag_Nam when the dynamic model is in
8213 if Dynamic_Elaboration_Checks
then
8214 Ensure_Prior_Elaboration_Dynamic
8217 Prag_Nam
=> Prag_Nam
,
8218 In_State
=> In_State
);
8220 -- Install an implicit pragma Prag_Nam when the static model is in
8224 pragma Assert
(Static_Elaboration_Checks
);
8226 Ensure_Prior_Elaboration_Static
8229 Prag_Nam
=> Prag_Nam
,
8230 In_State
=> In_State
);
8232 end Ensure_Prior_Elaboration
;
8234 --------------------------------------
8235 -- Ensure_Prior_Elaboration_Dynamic --
8236 --------------------------------------
8238 procedure Ensure_Prior_Elaboration_Dynamic
8240 Unit_Id
: Entity_Id
;
8242 In_State
: Processing_In_State
)
8244 procedure Info_Missing_Pragma
;
8245 pragma Inline
(Info_Missing_Pragma
);
8246 -- Output information concerning missing Elaborate or Elaborate_All
8247 -- pragma with name Prag_Nam for scenario N, which would ensure the
8248 -- prior elaboration of Unit_Id.
8250 -------------------------
8251 -- Info_Missing_Pragma --
8252 -------------------------
8254 procedure Info_Missing_Pragma
is
8256 -- Internal units are ignored as they cause unnecessary noise
8258 if not In_Internal_Unit
(Unit_Id
) then
8260 -- The name of the unit subjected to the elaboration pragma is
8261 -- fully qualified to improve the clarity of the info message.
8263 Error_Msg_Name_1
:= Prag_Nam
;
8264 Error_Msg_Qual_Level
:= Nat
'Last;
8267 ("info: missing pragma % for unit &?$?", N
,
8269 Error_Msg_Qual_Level
:= 0;
8271 end Info_Missing_Pragma
;
8275 EA_Id
: constant Elaboration_Attributes_Id
:=
8276 Elaboration_Attributes_Of
(Unit_Id
);
8277 N_Lvl
: Enclosing_Level_Kind
;
8278 N_Rep
: Scenario_Rep_Id
;
8280 -- Start of processing for Ensure_Prior_Elaboration_Dynamic
8283 -- Nothing to do when the unit is guaranteed prior elaboration by
8284 -- means of a source Elaborate[_All] pragma.
8286 if Present
(Elab_Pragma
(EA_Id
)) then
8290 -- Output extra information on a missing Elaborate[_All] pragma when
8291 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
8294 if Elab_Info_Messages
8295 and then not In_State
.Suppress_Info_Messages
8297 N_Rep
:= Scenario_Representation_Of
(N
, In_State
);
8298 N_Lvl
:= Level
(N_Rep
);
8300 -- Declaration-level scenario
8302 if (Is_Suitable_Call
(N
) or else Is_Suitable_Instantiation
(N
))
8303 and then N_Lvl
= Declaration_Level
8307 -- Library-level scenario
8309 elsif N_Lvl
in Library_Level
then
8312 -- Instantiation library-level scenario
8314 elsif N_Lvl
= Instantiation_Level
then
8317 -- Otherwise the scenario does not appear at the proper level
8323 Info_Missing_Pragma
;
8325 end Ensure_Prior_Elaboration_Dynamic
;
8327 -------------------------------------
8328 -- Ensure_Prior_Elaboration_Static --
8329 -------------------------------------
8331 procedure Ensure_Prior_Elaboration_Static
8333 Unit_Id
: Entity_Id
;
8335 In_State
: Processing_In_State
)
8337 function Find_With_Clause
8339 Withed_Id
: Entity_Id
) return Node_Id
;
8340 pragma Inline
(Find_With_Clause
);
8341 -- Find a nonlimited with clause in the list of context items Items
8342 -- that withs unit Withed_Id. Return Empty if no such clause exists.
8344 procedure Info_Implicit_Pragma
;
8345 pragma Inline
(Info_Implicit_Pragma
);
8346 -- Output information concerning an implicitly generated Elaborate
8347 -- or Elaborate_All pragma with name Prag_Nam for scenario N which
8348 -- ensures the prior elaboration of unit Unit_Id.
8350 ----------------------
8351 -- Find_With_Clause --
8352 ----------------------
8354 function Find_With_Clause
8356 Withed_Id
: Entity_Id
) return Node_Id
8361 -- Examine the context clauses looking for a suitable with. Note
8362 -- that limited clauses do not affect the elaboration order.
8364 Item
:= First
(Items
);
8365 while Present
(Item
) loop
8366 if Nkind
(Item
) = N_With_Clause
8367 and then not Error_Posted
(Item
)
8368 and then not Limited_Present
(Item
)
8369 and then Entity
(Name
(Item
)) = Withed_Id
8378 end Find_With_Clause
;
8380 --------------------------
8381 -- Info_Implicit_Pragma --
8382 --------------------------
8384 procedure Info_Implicit_Pragma
is
8386 -- Internal units are ignored as they cause unnecessary noise
8388 if not In_Internal_Unit
(Unit_Id
) then
8390 -- The name of the unit subjected to the elaboration pragma is
8391 -- fully qualified to improve the clarity of the info message.
8393 Error_Msg_Name_1
:= Prag_Nam
;
8394 Error_Msg_Qual_Level
:= Nat
'Last;
8397 ("info: implicit pragma % generated for unit &?$?",
8400 Error_Msg_Qual_Level
:= 0;
8401 Output_Active_Scenarios
(N
, In_State
);
8403 end Info_Implicit_Pragma
;
8407 EA_Id
: constant Elaboration_Attributes_Id
:=
8408 Elaboration_Attributes_Of
(Unit_Id
);
8410 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
8411 Loc
: constant Source_Ptr
:= Sloc
(Main_Cunit
);
8412 Unit_Cunit
: constant Node_Id
:= Compilation_Unit
(Unit_Id
);
8413 Unit_Prag
: constant Node_Id
:= Elab_Pragma
(EA_Id
);
8414 Unit_With
: constant Node_Id
:= With_Clause
(EA_Id
);
8419 -- Start of processing for Ensure_Prior_Elaboration_Static
8422 -- Nothing to do when the caller has suppressed the generation of
8423 -- implicit Elaborate[_All] pragmas.
8425 if In_State
.Suppress_Implicit_Pragmas
then
8428 -- Nothing to do when the unit is guaranteed prior elaboration by
8429 -- means of a source Elaborate[_All] pragma.
8431 elsif Present
(Unit_Prag
) then
8434 -- Nothing to do when the unit has an existing implicit Elaborate or
8435 -- Elaborate_All pragma installed by a previous scenario.
8437 elsif Present
(Unit_With
) then
8439 -- The unit is already guaranteed prior elaboration by means of an
8440 -- implicit Elaborate pragma, however the current scenario imposes
8441 -- a stronger requirement of Elaborate_All. "Upgrade" the existing
8442 -- pragma to match this new requirement.
8444 if Elaborate_Desirable
(Unit_With
)
8445 and then Prag_Nam
= Name_Elaborate_All
8447 Set_Elaborate_All_Desirable
(Unit_With
);
8448 Set_Elaborate_Desirable
(Unit_With
, False);
8454 -- At this point it is known that the unit has no prior elaboration
8455 -- according to pragmas and hierarchical relationships.
8457 Items
:= Context_Items
(Main_Cunit
);
8461 Set_Context_Items
(Main_Cunit
, Items
);
8464 -- Locate the with clause for the unit. Note that there may not be a
8465 -- clause if the unit is visible through a subunit-body, body-spec,
8466 -- or spec-parent relationship.
8471 Withed_Id
=> Unit_Id
);
8476 -- Note that adding implicit with clauses is safe because analysis,
8477 -- resolution, and expansion have already taken place and it is not
8478 -- possible to interfere with visibility.
8482 Make_With_Clause
(Loc
,
8483 Name
=> New_Occurrence_Of
(Unit_Id
, Loc
));
8485 Set_Implicit_With
(Clause
);
8486 Set_Library_Unit
(Clause
, Unit_Cunit
);
8488 Append_To
(Items
, Clause
);
8491 -- Mark the with clause depending on the pragma required
8493 if Prag_Nam
= Name_Elaborate
then
8494 Set_Elaborate_Desirable
(Clause
);
8496 Set_Elaborate_All_Desirable
(Clause
);
8499 -- The implicit Elaborate[_All] ensures the prior elaboration of
8500 -- the unit. Include the unit in the elaboration context of the
8503 Set_With_Clause
(EA_Id
, Clause
);
8505 -- Output extra information on an implicit Elaborate[_All] pragma
8506 -- when switch -gnatel (info messages on implicit Elaborate[_All]
8507 -- pragmas is in effect.
8509 if Elab_Info_Messages
then
8510 Info_Implicit_Pragma
;
8512 end Ensure_Prior_Elaboration_Static
;
8514 -------------------------------
8515 -- Finalize_Elaborated_Units --
8516 -------------------------------
8518 procedure Finalize_Elaborated_Units
is
8520 UA_Map
.Destroy
(Unit_To_Attributes_Map
);
8521 end Finalize_Elaborated_Units
;
8523 ---------------------------
8524 -- Has_Prior_Elaboration --
8525 ---------------------------
8527 function Has_Prior_Elaboration
8528 (Unit_Id
: Entity_Id
;
8529 Context_OK
: Boolean := False;
8530 Elab_Body_OK
: Boolean := False;
8531 Same_Unit_OK
: Boolean := False) return Boolean
8533 EA_Id
: constant Elaboration_Attributes_Id
:=
8534 Elaboration_Attributes_Of
(Unit_Id
);
8535 Main_Id
: constant Entity_Id
:= Main_Unit_Entity
;
8536 Unit_Prag
: constant Node_Id
:= Elab_Pragma
(EA_Id
);
8537 Unit_With
: constant Node_Id
:= With_Clause
(EA_Id
);
8540 -- A preelaborated unit is always elaborated prior to the main unit
8542 if Is_Preelaborated_Unit
(Unit_Id
) then
8545 -- An internal unit is always elaborated prior to a non-internal main
8548 elsif In_Internal_Unit
(Unit_Id
)
8549 and then not In_Internal_Unit
(Main_Id
)
8553 -- A unit has prior elaboration if it appears within the context
8554 -- of the main unit. Consider this case only when requested by the
8558 and then (Present
(Unit_Prag
) or else Present
(Unit_With
))
8562 -- A unit whose body is elaborated together with its spec has prior
8563 -- elaboration except with respect to itself. Consider this case only
8564 -- when requested by the caller.
8567 and then Has_Pragma_Elaborate_Body
(Unit_Id
)
8568 and then not Is_Same_Unit
(Unit_Id
, Main_Id
)
8572 -- A unit has no prior elaboration with respect to itself, but does
8573 -- not require any means of ensuring its own elaboration either.
8574 -- Treat this case as valid prior elaboration only when requested by
8577 elsif Same_Unit_OK
and then Is_Same_Unit
(Unit_Id
, Main_Id
) then
8582 end Has_Prior_Elaboration
;
8584 ---------------------------------
8585 -- Initialize_Elaborated_Units --
8586 ---------------------------------
8588 procedure Initialize_Elaborated_Units
is
8590 Unit_To_Attributes_Map
:= UA_Map
.Create
(250);
8591 end Initialize_Elaborated_Units
;
8593 ----------------------------------
8594 -- Meet_Elaboration_Requirement --
8595 ----------------------------------
8597 procedure Meet_Elaboration_Requirement
8599 Targ_Id
: Entity_Id
;
8601 In_State
: Processing_In_State
)
8603 pragma Assert
(Req_Nam
in Name_Elaborate | Name_Elaborate_All
);
8605 Main_Id
: constant Entity_Id
:= Main_Unit_Entity
;
8606 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Targ_Id
);
8608 procedure Elaboration_Requirement_Error
;
8609 pragma Inline
(Elaboration_Requirement_Error
);
8610 -- Emit an error concerning scenario N which has failed to meet the
8611 -- elaboration requirement.
8613 function Find_Preelaboration_Pragma
8614 (Prag_Nam
: Name_Id
) return Node_Id
;
8615 pragma Inline
(Find_Preelaboration_Pragma
);
8616 -- Traverse the visible declarations of unit Unit_Id and locate a
8617 -- source preelaboration-related pragma with name Prag_Nam.
8619 procedure Info_Requirement_Met
(Prag
: Node_Id
);
8620 pragma Inline
(Info_Requirement_Met
);
8621 -- Output information concerning pragma Prag which meets requirement
8624 -----------------------------------
8625 -- Elaboration_Requirement_Error --
8626 -----------------------------------
8628 procedure Elaboration_Requirement_Error
is
8630 if Is_Suitable_Call
(N
) then
8637 elsif Is_Suitable_Instantiation
(N
) then
8644 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
8646 ("read of refinement constituents during elaboration in "
8649 elsif Is_Suitable_Variable_Reference
(N
) then
8650 Info_Variable_Reference
8654 -- No other scenario may impose a requirement on the context of
8658 pragma Assert
(False);
8662 Error_Msg_Name_1
:= Req_Nam
;
8663 Error_Msg_Node_2
:= Unit_Id
;
8664 Error_Msg_NE
("\\unit & requires pragma % for &", N
, Main_Id
);
8666 Output_Active_Scenarios
(N
, In_State
);
8667 end Elaboration_Requirement_Error
;
8669 --------------------------------
8670 -- Find_Preelaboration_Pragma --
8671 --------------------------------
8673 function Find_Preelaboration_Pragma
8674 (Prag_Nam
: Name_Id
) return Node_Id
8676 Spec
: constant Node_Id
:= Parent
(Unit_Id
);
8680 -- A preelaboration-related pragma comes from source and appears
8681 -- at the top of the visible declarations of a package.
8683 if Nkind
(Spec
) = N_Package_Specification
then
8684 Decl
:= First
(Visible_Declarations
(Spec
));
8685 while Present
(Decl
) loop
8686 if Comes_From_Source
(Decl
) then
8687 if Nkind
(Decl
) = N_Pragma
8688 and then Pragma_Name
(Decl
) = Prag_Nam
8692 -- Otherwise the construct terminates the region where
8693 -- the preelaboration-related pragma may appear.
8705 end Find_Preelaboration_Pragma
;
8707 --------------------------
8708 -- Info_Requirement_Met --
8709 --------------------------
8711 procedure Info_Requirement_Met
(Prag
: Node_Id
) is
8712 pragma Assert
(Present
(Prag
));
8715 Error_Msg_Name_1
:= Req_Nam
;
8716 Error_Msg_Sloc
:= Sloc
(Prag
);
8718 ("\\% requirement for unit & met by pragma #", N
, Unit_Id
);
8719 end Info_Requirement_Met
;
8723 EA_Id
: Elaboration_Attributes_Id
;
8726 Unit_Prag
: Node_Id
;
8728 -- Start of processing for Meet_Elaboration_Requirement
8731 -- Assume that the requirement has not been met
8735 -- If the target is within the main unit, either at the source level
8736 -- or through an instantiation, then there is no real requirement to
8737 -- meet because the main unit cannot force its own elaboration by
8738 -- means of an Elaborate[_All] pragma. Treat this case as valid
8741 if In_Extended_Main_Code_Unit
(Targ_Id
) then
8744 -- Otherwise the target resides in an external unit
8746 -- The requirement is met when the target comes from an internal unit
8747 -- because such a unit is elaborated prior to a non-internal unit.
8749 elsif In_Internal_Unit
(Unit_Id
)
8750 and then not In_Internal_Unit
(Main_Id
)
8754 -- The requirement is met when the target comes from a preelaborated
8755 -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
8757 elsif Is_Preelaborated_Unit
(Unit_Id
) then
8760 -- Output extra information when switch -gnatel (info messages on
8761 -- implicit Elaborate[_All] pragmas.
8763 if Elab_Info_Messages
8764 and then not In_State
.Suppress_Info_Messages
8766 if Is_Preelaborated
(Unit_Id
) then
8767 Elab_Nam
:= Name_Preelaborate
;
8769 elsif Is_Pure
(Unit_Id
) then
8770 Elab_Nam
:= Name_Pure
;
8772 elsif Is_Remote_Call_Interface
(Unit_Id
) then
8773 Elab_Nam
:= Name_Remote_Call_Interface
;
8775 elsif Is_Remote_Types
(Unit_Id
) then
8776 Elab_Nam
:= Name_Remote_Types
;
8779 pragma Assert
(Is_Shared_Passive
(Unit_Id
));
8780 Elab_Nam
:= Name_Shared_Passive
;
8783 Info_Requirement_Met
(Find_Preelaboration_Pragma
(Elab_Nam
));
8786 -- Determine whether the context of the main unit has a pragma strong
8787 -- enough to meet the requirement.
8790 EA_Id
:= Elaboration_Attributes_Of
(Unit_Id
);
8791 Unit_Prag
:= Elab_Pragma
(EA_Id
);
8793 -- The pragma must be either Elaborate_All or be as strong as the
8796 if Present
(Unit_Prag
)
8797 and then Pragma_Name
(Unit_Prag
) in Name_Elaborate_All | Req_Nam
8801 -- Output extra information when switch -gnatel (info messages
8802 -- on implicit Elaborate[_All] pragmas.
8804 if Elab_Info_Messages
8805 and then not In_State
.Suppress_Info_Messages
8807 Info_Requirement_Met
(Unit_Prag
);
8812 -- The requirement was not met by the context of the main unit, issue
8816 Elaboration_Requirement_Error
;
8818 end Meet_Elaboration_Requirement
;
8824 function Present
(EA_Id
: Elaboration_Attributes_Id
) return Boolean is
8826 return EA_Id
/= No_Elaboration_Attributes
;
8829 ---------------------
8830 -- Set_Elab_Pragma --
8831 ---------------------
8833 procedure Set_Elab_Pragma
8834 (EA_Id
: Elaboration_Attributes_Id
;
8837 pragma Assert
(Present
(EA_Id
));
8839 Elaboration_Attributes
.Table
(EA_Id
).Elab_Pragma
:= Prag
;
8840 end Set_Elab_Pragma
;
8842 ---------------------
8843 -- Set_With_Clause --
8844 ---------------------
8846 procedure Set_With_Clause
8847 (EA_Id
: Elaboration_Attributes_Id
;
8850 pragma Assert
(Present
(EA_Id
));
8852 Elaboration_Attributes
.Table
(EA_Id
).With_Clause
:= Clause
;
8853 end Set_With_Clause
;
8859 function With_Clause
8860 (EA_Id
: Elaboration_Attributes_Id
) return Node_Id
8862 pragma Assert
(Present
(EA_Id
));
8864 return Elaboration_Attributes
.Table
(EA_Id
).With_Clause
;
8866 end Elaborated_Units
;
8868 ------------------------------
8869 -- Elaboration_Phase_Active --
8870 ------------------------------
8872 function Elaboration_Phase_Active
return Boolean is
8874 return Elaboration_Phase
= Active
;
8875 end Elaboration_Phase_Active
;
8877 ------------------------------
8878 -- Error_Preelaborated_Call --
8879 ------------------------------
8881 procedure Error_Preelaborated_Call
(N
: Node_Id
) is
8883 -- This is a warning in GNAT mode allowing such calls to be used in the
8884 -- predefined library units with appropriate care.
8886 Error_Msg_Warn
:= GNAT_Mode
;
8888 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
8889 -- unchecked conversions are preelaborable.
8891 if Ada_Version
>= Ada_2022
then
8893 ("<<non-preelaborable call not allowed in preelaborated unit", N
);
8896 ("<<non-static call not allowed in preelaborated unit", N
);
8898 end Error_Preelaborated_Call
;
8900 ----------------------------------
8901 -- Finalize_All_Data_Structures --
8902 ----------------------------------
8904 procedure Finalize_All_Data_Structures
is
8906 Finalize_Body_Processor
;
8907 Finalize_Early_Call_Region_Processor
;
8908 Finalize_Elaborated_Units
;
8909 Finalize_Internal_Representation
;
8910 Finalize_Invocation_Graph
;
8911 Finalize_Scenario_Storage
;
8912 end Finalize_All_Data_Structures
;
8914 -----------------------------
8915 -- Find_Enclosing_Instance --
8916 -----------------------------
8918 function Find_Enclosing_Instance
(N
: Node_Id
) return Node_Id
is
8922 -- Climb the parent chain looking for an enclosing instance spec or body
8925 while Present
(Par
) loop
8926 if Nkind
(Par
) in N_Package_Body
8927 | N_Package_Declaration
8929 | N_Subprogram_Declaration
8930 and then Is_Generic_Instance
(Unique_Defining_Entity
(Par
))
8935 Par
:= Parent
(Par
);
8939 end Find_Enclosing_Instance
;
8941 --------------------------
8942 -- Find_Enclosing_Level --
8943 --------------------------
8945 function Find_Enclosing_Level
(N
: Node_Id
) return Enclosing_Level_Kind
is
8946 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
;
8947 pragma Inline
(Level_Of
);
8948 -- Obtain the corresponding level of unit Unit
8954 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
is
8955 Spec_Id
: Entity_Id
;
8958 if Nkind
(Unit
) in N_Generic_Instantiation
then
8959 return Instantiation_Level
;
8961 elsif Nkind
(Unit
) = N_Generic_Package_Declaration
then
8962 return Generic_Spec_Level
;
8964 elsif Nkind
(Unit
) = N_Package_Declaration
then
8965 return Library_Spec_Level
;
8967 elsif Nkind
(Unit
) = N_Package_Body
then
8968 Spec_Id
:= Corresponding_Spec
(Unit
);
8970 -- The body belongs to a generic package
8972 if Present
(Spec_Id
)
8973 and then Ekind
(Spec_Id
) = E_Generic_Package
8975 return Generic_Body_Level
;
8977 -- Otherwise the body belongs to a non-generic package. This also
8978 -- treats an illegal package body without a corresponding spec as
8979 -- a non-generic package body.
8982 return Library_Body_Level
;
8995 -- Start of processing for Find_Enclosing_Level
8998 -- Call markers and instantiations which appear at the declaration level
8999 -- but are later relocated in a different context retain their original
9000 -- declaration level.
9002 if Nkind
(N
) in N_Call_Marker
9003 | N_Function_Instantiation
9004 | N_Package_Instantiation
9005 | N_Procedure_Instantiation
9006 and then Is_Declaration_Level_Node
(N
)
9008 return Declaration_Level
;
9011 -- Climb the parent chain looking at the enclosing levels
9014 Curr
:= Parent
(Prev
);
9015 while Present
(Curr
) loop
9017 -- A traversal from a subunit continues via the corresponding stub
9019 if Nkind
(Curr
) = N_Subunit
then
9020 Curr
:= Corresponding_Stub
(Curr
);
9022 -- The current construct is a package. Packages are ignored because
9023 -- they are always elaborated when the enclosing context is invoked
9026 elsif Nkind
(Curr
) in N_Package_Body | N_Package_Declaration
then
9029 -- The current construct is a block statement
9031 elsif Nkind
(Curr
) = N_Block_Statement
then
9033 -- Ignore internally generated blocks created by the expander for
9034 -- various purposes such as abort defer/undefer.
9036 if not Comes_From_Source
(Curr
) then
9039 -- If the traversal came from the handled sequence of statements,
9040 -- then the node appears at the level of the enclosing construct.
9041 -- This is a more reliable test because transients scopes within
9042 -- the declarative region of the encapsulator are hard to detect.
9044 elsif Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
9045 and then Handled_Statement_Sequence
(Curr
) = Prev
9047 return Find_Enclosing_Level
(Parent
(Curr
));
9049 -- Otherwise the traversal came from the declarations, the node is
9050 -- at the declaration level.
9053 return Declaration_Level
;
9056 -- The current construct is a declaration-level encapsulator
9058 elsif Nkind
(Curr
) in
9059 N_Entry_Body | N_Subprogram_Body | N_Task_Body
9061 -- If the traversal came from the handled sequence of statements,
9062 -- then the node cannot possibly appear at any level. This is
9063 -- a more reliable test because transients scopes within the
9064 -- declarative region of the encapsulator are hard to detect.
9066 if Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
9067 and then Handled_Statement_Sequence
(Curr
) = Prev
9071 -- Otherwise the traversal came from the declarations, the node is
9072 -- at the declaration level.
9075 return Declaration_Level
;
9078 -- The current construct is a non-library-level encapsulator which
9079 -- indicates that the node cannot possibly appear at any level. Note
9080 -- that the check must come after the declaration-level check because
9081 -- both predicates share certain nodes.
9083 elsif Is_Non_Library_Level_Encapsulator
(Curr
) then
9084 Context
:= Parent
(Curr
);
9086 -- The sole exception is when the encapsulator is the compilation
9087 -- utit itself because the compilation unit node requires special
9088 -- processing (see below).
9090 if Present
(Context
)
9091 and then Nkind
(Context
) = N_Compilation_Unit
9095 -- Otherwise the node is not at any level
9101 -- The current construct is a compilation unit. The node appears at
9102 -- the [generic] library level when the unit is a [generic] package.
9104 elsif Nkind
(Curr
) = N_Compilation_Unit
then
9105 return Level_Of
(Unit
(Curr
));
9109 Curr
:= Parent
(Prev
);
9113 end Find_Enclosing_Level
;
9119 function Find_Top_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
is
9121 return Find_Unit_Entity
(Unit
(Cunit
(Get_Top_Level_Code_Unit
(N
))));
9124 ----------------------
9125 -- Find_Unit_Entity --
9126 ----------------------
9128 function Find_Unit_Entity
(N
: Node_Id
) return Entity_Id
is
9129 Context
: constant Node_Id
:= Parent
(N
);
9130 Orig_N
: constant Node_Id
:= Original_Node
(N
);
9133 -- The unit denotes a package body of an instantiation which acts as
9134 -- a compilation unit. The proper entity is that of the package spec.
9136 if Nkind
(N
) = N_Package_Body
9137 and then Nkind
(Orig_N
) = N_Package_Instantiation
9138 and then Nkind
(Context
) = N_Compilation_Unit
9140 return Corresponding_Spec
(N
);
9142 -- The unit denotes an anonymous package created to wrap a subprogram
9143 -- instantiation which acts as a compilation unit. The proper entity is
9144 -- that of the "related instance".
9146 elsif Nkind
(N
) = N_Package_Declaration
9147 and then Nkind
(Orig_N
) in
9148 N_Function_Instantiation | N_Procedure_Instantiation
9149 and then Nkind
(Context
) = N_Compilation_Unit
9151 return Related_Instance
(Defining_Entity
(N
));
9153 -- The unit denotes a concurrent body acting as a subunit. Such bodies
9154 -- are generally rewritten into null statements. The proper entity is
9155 -- that of the "original node".
9157 elsif Nkind
(N
) = N_Subunit
9158 and then Nkind
(Proper_Body
(N
)) = N_Null_Statement
9159 and then Nkind
(Original_Node
(Proper_Body
(N
))) in
9160 N_Protected_Body | N_Task_Body
9162 return Defining_Entity
(Original_Node
(Proper_Body
(N
)));
9164 -- Otherwise the proper entity is the defining entity
9167 return Defining_Entity
(N
);
9169 end Find_Unit_Entity
;
9171 -----------------------
9172 -- First_Formal_Type --
9173 -----------------------
9175 function First_Formal_Type
(Subp_Id
: Entity_Id
) return Entity_Id
is
9176 Formal_Id
: constant Entity_Id
:= First_Formal
(Subp_Id
);
9180 if Present
(Formal_Id
) then
9181 Typ
:= Etype
(Formal_Id
);
9183 -- Handle various combinations of concurrent and private types
9186 if Ekind
(Typ
) in E_Protected_Type | E_Task_Type
9187 and then Present
(Anonymous_Object
(Typ
))
9189 Typ
:= Anonymous_Object
(Typ
);
9191 elsif Is_Concurrent_Record_Type
(Typ
) then
9192 Typ
:= Corresponding_Concurrent_Type
(Typ
);
9194 elsif Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
9195 Typ
:= Full_View
(Typ
);
9206 end First_Formal_Type
;
9208 ------------------------------
9209 -- Guaranteed_ABE_Processor --
9210 ------------------------------
9212 package body Guaranteed_ABE_Processor
is
9213 function Is_Guaranteed_ABE
9215 Target_Decl
: Node_Id
;
9216 Target_Body
: Node_Id
) return Boolean;
9217 pragma Inline
(Is_Guaranteed_ABE
);
9218 -- Determine whether scenario N with a target described by its initial
9219 -- declaration Target_Decl and body Target_Decl results in a guaranteed
9222 procedure Process_Guaranteed_ABE_Activation
9224 Call_Rep
: Scenario_Rep_Id
;
9226 Obj_Rep
: Target_Rep_Id
;
9227 Task_Typ
: Entity_Id
;
9228 Task_Rep
: Target_Rep_Id
;
9229 In_State
: Processing_In_State
);
9230 pragma Inline
(Process_Guaranteed_ABE_Activation
);
9231 -- Perform common guaranteed ABE checks and diagnostics for activation
9232 -- call Call which activates object Obj_Id of task type Task_Typ. Formal
9233 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the
9234 -- representation of the object. Task_Rep denotes the representation of
9235 -- the task type. In_State is the current state of the Processing phase.
9237 procedure Process_Guaranteed_ABE_Call
9239 Call_Rep
: Scenario_Rep_Id
;
9240 In_State
: Processing_In_State
);
9241 pragma Inline
(Process_Guaranteed_ABE_Call
);
9242 -- Perform common guaranteed ABE checks and diagnostics for call Call
9243 -- with representation Call_Rep. In_State denotes the current state of
9244 -- the Processing phase.
9246 procedure Process_Guaranteed_ABE_Instantiation
9248 Inst_Rep
: Scenario_Rep_Id
;
9249 In_State
: Processing_In_State
);
9250 pragma Inline
(Process_Guaranteed_ABE_Instantiation
);
9251 -- Perform common guaranteed ABE checks and diagnostics for instance
9252 -- Inst with representation Inst_Rep. In_State is the current state of
9253 -- the Processing phase.
9255 -----------------------
9256 -- Is_Guaranteed_ABE --
9257 -----------------------
9259 function Is_Guaranteed_ABE
9261 Target_Decl
: Node_Id
;
9262 Target_Body
: Node_Id
) return Boolean
9266 -- Avoid cascaded errors if there were previous serious infractions.
9267 -- As a result the scenario will not be treated as a guaranteed ABE.
9268 -- This behavior parallels that of the old ABE mechanism.
9270 if Serious_Errors_Detected
> 0 then
9273 -- The scenario and the target appear in the same context ignoring
9274 -- enclosing library levels.
9276 elsif In_Same_Context
(N
, Target_Decl
) then
9278 -- The target body has already been encountered. The scenario
9279 -- results in a guaranteed ABE if it appears prior to the body.
9281 if Present
(Target_Body
) then
9282 return Earlier_In_Extended_Unit
(N
, Target_Body
);
9284 -- Otherwise the body has not been encountered yet. The scenario
9285 -- is a guaranteed ABE since the body will appear later, unless
9286 -- this is a null specification, which can occur if expansion is
9287 -- disabled (e.g. -gnatc or GNATprove mode). It is assumed that
9288 -- the caller has already ensured that the scenario is ABE-safe
9289 -- because optional bodies are not considered here.
9292 Spec
:= Specification
(Target_Decl
);
9294 if Nkind
(Spec
) /= N_Procedure_Specification
9295 or else not Null_Present
(Spec
)
9303 end Is_Guaranteed_ABE
;
9305 ----------------------------
9306 -- Process_Guaranteed_ABE --
9307 ----------------------------
9309 procedure Process_Guaranteed_ABE
9311 In_State
: Processing_In_State
)
9313 Scen
: constant Node_Id
:= Scenario
(N
);
9314 Scen_Rep
: Scenario_Rep_Id
;
9317 -- Add the current scenario to the stack of active scenarios
9319 Push_Active_Scenario
(Scen
);
9321 -- Only calls, instantiations, and task activations may result in a
9324 -- Call or task activation
9326 if Is_Suitable_Call
(Scen
) then
9327 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
9329 if Kind
(Scen_Rep
) = Call_Scenario
then
9330 Process_Guaranteed_ABE_Call
9332 Call_Rep
=> Scen_Rep
,
9333 In_State
=> In_State
);
9336 pragma Assert
(Kind
(Scen_Rep
) = Task_Activation_Scenario
);
9340 Call_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
9341 Processor
=> Process_Guaranteed_ABE_Activation
'Access,
9342 In_State
=> In_State
);
9347 elsif Is_Suitable_Instantiation
(Scen
) then
9348 Process_Guaranteed_ABE_Instantiation
9350 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
9351 In_State
=> In_State
);
9354 -- Remove the current scenario from the stack of active scenarios
9355 -- once all ABE diagnostics and checks have been performed.
9357 Pop_Active_Scenario
(Scen
);
9358 end Process_Guaranteed_ABE
;
9360 ---------------------------------------
9361 -- Process_Guaranteed_ABE_Activation --
9362 ---------------------------------------
9364 procedure Process_Guaranteed_ABE_Activation
9366 Call_Rep
: Scenario_Rep_Id
;
9368 Obj_Rep
: Target_Rep_Id
;
9369 Task_Typ
: Entity_Id
;
9370 Task_Rep
: Target_Rep_Id
;
9371 In_State
: Processing_In_State
)
9373 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Task_Rep
);
9375 Check_OK
: constant Boolean :=
9376 not In_State
.Suppress_Checks
9377 and then Ghost_Mode_Of
(Obj_Rep
) /= Is_Ignored
9378 and then Ghost_Mode_Of
(Task_Rep
) /= Is_Ignored
9379 and then Elaboration_Checks_OK
(Obj_Rep
)
9380 and then Elaboration_Checks_OK
(Task_Rep
);
9381 -- A run-time ABE check may be installed only when the object and the
9382 -- task type have active elaboration checks, and both are not ignored
9383 -- Ghost constructs.
9386 -- Nothing to do when the root scenario appears at the declaration
9387 -- level and the task is in the same unit, but outside this context.
9389 -- task type Task_Typ; -- task declaration
9391 -- procedure Proc is
9392 -- function A ... is
9394 -- if Some_Condition then
9398 -- <activation call> -- activation site
9403 -- X : ... := A; -- root scenario
9406 -- task body Task_Typ is
9410 -- In the example above, the context of X is the declarative list
9411 -- of Proc. The "elaboration" of X may reach the activation of T
9412 -- whose body is defined outside of X's context. The task body is
9413 -- relevant only when Proc is invoked, but this happens only in
9414 -- "normal" elaboration, therefore the task body must not be
9415 -- considered if this is not the case.
9417 if Is_Up_Level_Target
9418 (Targ_Decl
=> Spec_Decl
,
9419 In_State
=> In_State
)
9423 -- Nothing to do when the activation is ABE-safe
9427 -- task type Task_Typ;
9430 -- package body Gen is
9431 -- task body Task_Typ is
9438 -- procedure Main is
9439 -- package Nested is
9440 -- package Inst is new Gen;
9441 -- T : Inst.Task_Typ;
9442 -- end Nested; -- safe activation
9445 elsif Is_Safe_Activation
(Call
, Task_Rep
) then
9448 -- An activation call leads to a guaranteed ABE when the activation
9449 -- call and the task appear within the same context ignoring library
9450 -- levels, and the body of the task has not been seen yet or appears
9451 -- after the activation call.
9453 -- procedure Guaranteed_ABE is
9454 -- task type Task_Typ;
9456 -- package Nested is
9458 -- <activation call> -- guaranteed ABE
9461 -- task body Task_Typ is
9466 elsif Is_Guaranteed_ABE
9468 Target_Decl
=> Spec_Decl
,
9469 Target_Body
=> Body_Declaration
(Task_Rep
))
9471 if Elaboration_Warnings_OK
(Call_Rep
) then
9472 Error_Msg_Sloc
:= Sloc
(Call
);
9474 ("??task & will be activated # before elaboration of its "
9477 ("\Program_Error will be raised at run time", Obj_Id
);
9480 -- Mark the activation call as a guaranteed ABE
9482 Set_Is_Known_Guaranteed_ABE
(Call
);
9484 -- Install a run-time ABE failue because this activation call will
9485 -- always result in an ABE.
9488 Install_Scenario_ABE_Failure
9490 Targ_Id
=> Task_Typ
,
9491 Targ_Rep
=> Task_Rep
,
9492 Disable
=> Obj_Rep
);
9495 end Process_Guaranteed_ABE_Activation
;
9497 ---------------------------------
9498 -- Process_Guaranteed_ABE_Call --
9499 ---------------------------------
9501 procedure Process_Guaranteed_ABE_Call
9503 Call_Rep
: Scenario_Rep_Id
;
9504 In_State
: Processing_In_State
)
9506 Subp_Id
: constant Entity_Id
:= Target
(Call_Rep
);
9507 Subp_Rep
: constant Target_Rep_Id
:=
9508 Target_Representation_Of
(Subp_Id
, In_State
);
9509 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Subp_Rep
);
9511 Check_OK
: constant Boolean :=
9512 not In_State
.Suppress_Checks
9513 and then Ghost_Mode_Of
(Call_Rep
) /= Is_Ignored
9514 and then Ghost_Mode_Of
(Subp_Rep
) /= Is_Ignored
9515 and then Elaboration_Checks_OK
(Call_Rep
)
9516 and then Elaboration_Checks_OK
(Subp_Rep
);
9517 -- A run-time ABE check may be installed only when both the call
9518 -- and the target have active elaboration checks, and both are not
9519 -- ignored Ghost constructs.
9522 -- Nothing to do when the root scenario appears at the declaration
9523 -- level and the target is in the same unit but outside this context.
9525 -- function B ...; -- target declaration
9527 -- procedure Proc is
9528 -- function A ... is
9530 -- if Some_Condition then
9531 -- return B; -- call site
9535 -- X : ... := A; -- root scenario
9538 -- function B ... is
9542 -- In the example above, the context of X is the declarative region
9543 -- of Proc. The "elaboration" of X may eventually reach B which is
9544 -- defined outside of X's context. B is relevant only when Proc is
9545 -- invoked, but this happens only by means of "normal" elaboration,
9546 -- therefore B must not be considered if this is not the case.
9548 if Is_Up_Level_Target
9549 (Targ_Decl
=> Spec_Decl
,
9550 In_State
=> In_State
)
9554 -- Nothing to do when the call is ABE-safe
9557 -- function Gen ...;
9559 -- function Gen ... is
9565 -- procedure Main is
9566 -- function Inst is new Gen;
9567 -- X : ... := Inst; -- safe call
9570 elsif Is_Safe_Call
(Call
, Subp_Id
, Subp_Rep
) then
9573 -- A call leads to a guaranteed ABE when the call and the target
9574 -- appear within the same context ignoring library levels, and the
9575 -- body of the target has not been seen yet or appears after the
9578 -- procedure Guaranteed_ABE is
9579 -- function Func ...;
9581 -- package Nested is
9582 -- Obj : ... := Func; -- guaranteed ABE
9585 -- function Func ... is
9590 elsif Is_Guaranteed_ABE
9592 Target_Decl
=> Spec_Decl
,
9593 Target_Body
=> Body_Declaration
(Subp_Rep
))
9595 if Elaboration_Warnings_OK
(Call_Rep
) then
9597 ("??cannot call & before body seen", Call
, Subp_Id
);
9598 Error_Msg_N
("\Program_Error will be raised at run time", Call
);
9601 -- Mark the call as a guaranteed ABE
9603 Set_Is_Known_Guaranteed_ABE
(Call
);
9605 -- Install a run-time ABE failure because the call will always
9606 -- result in an ABE.
9609 Install_Scenario_ABE_Failure
9612 Targ_Rep
=> Subp_Rep
,
9613 Disable
=> Call_Rep
);
9616 end Process_Guaranteed_ABE_Call
;
9618 ------------------------------------------
9619 -- Process_Guaranteed_ABE_Instantiation --
9620 ------------------------------------------
9622 procedure Process_Guaranteed_ABE_Instantiation
9624 Inst_Rep
: Scenario_Rep_Id
;
9625 In_State
: Processing_In_State
)
9627 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
9628 Gen_Rep
: constant Target_Rep_Id
:=
9629 Target_Representation_Of
(Gen_Id
, In_State
);
9630 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Gen_Rep
);
9632 Check_OK
: constant Boolean :=
9633 not In_State
.Suppress_Checks
9634 and then Ghost_Mode_Of
(Inst_Rep
) /= Is_Ignored
9635 and then Ghost_Mode_Of
(Gen_Rep
) /= Is_Ignored
9636 and then Elaboration_Checks_OK
(Inst_Rep
)
9637 and then Elaboration_Checks_OK
(Gen_Rep
);
9638 -- A run-time ABE check may be installed only when both the instance
9639 -- and the generic have active elaboration checks and both are not
9640 -- ignored Ghost constructs.
9643 -- Nothing to do when the root scenario appears at the declaration
9644 -- level and the generic is in the same unit, but outside this
9648 -- procedure Gen is ...; -- generic declaration
9650 -- procedure Proc is
9651 -- function A ... is
9653 -- if Some_Condition then
9655 -- procedure I is new Gen; -- instantiation site
9660 -- X : ... := A; -- root scenario
9667 -- In the example above, the context of X is the declarative region
9668 -- of Proc. The "elaboration" of X may eventually reach Gen which
9669 -- appears outside of X's context. Gen is relevant only when Proc is
9670 -- invoked, but this happens only by means of "normal" elaboration,
9671 -- therefore Gen must not be considered if this is not the case.
9673 if Is_Up_Level_Target
9674 (Targ_Decl
=> Spec_Decl
,
9675 In_State
=> In_State
)
9679 -- Nothing to do when the instantiation is ABE-safe
9686 -- package body Gen is
9691 -- procedure Main is
9692 -- package Inst is new Gen (ABE); -- safe instantiation
9695 elsif Is_Safe_Instantiation
(Inst
, Gen_Id
, Gen_Rep
) then
9698 -- An instantiation leads to a guaranteed ABE when the instantiation
9699 -- and the generic appear within the same context ignoring library
9700 -- levels, and the body of the generic has not been seen yet or
9701 -- appears after the instantiation.
9703 -- procedure Guaranteed_ABE is
9707 -- package Nested is
9708 -- procedure Inst is new Gen; -- guaranteed ABE
9716 elsif Is_Guaranteed_ABE
9718 Target_Decl
=> Spec_Decl
,
9719 Target_Body
=> Body_Declaration
(Gen_Rep
))
9721 if Elaboration_Warnings_OK
(Inst_Rep
) then
9723 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
9724 Error_Msg_N
("\Program_Error will be raised at run time", Inst
);
9727 -- Mark the instantiation as a guarantee ABE. This automatically
9728 -- suppresses the instantiation of the generic body.
9730 Set_Is_Known_Guaranteed_ABE
(Inst
);
9732 -- Install a run-time ABE failure because the instantiation will
9733 -- always result in an ABE.
9736 Install_Scenario_ABE_Failure
9739 Targ_Rep
=> Gen_Rep
,
9740 Disable
=> Inst_Rep
);
9743 end Process_Guaranteed_ABE_Instantiation
;
9744 end Guaranteed_ABE_Processor
;
9750 function Has_Body
(Pack_Decl
: Node_Id
) return Boolean is
9751 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
;
9752 pragma Inline
(Find_Corresponding_Body
);
9753 -- Try to locate the corresponding body of spec Spec_Id. If no body is
9754 -- found, return Empty.
9757 (Spec_Id
: Entity_Id
;
9758 From
: Node_Id
) return Node_Id
;
9759 pragma Inline
(Find_Body
);
9760 -- Try to locate the corresponding body of spec Spec_Id in the node list
9761 -- which follows arbitrary node From. If no body is found, return Empty.
9763 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
;
9764 pragma Inline
(Load_Package_Body
);
9765 -- Attempt to load the body of unit Unit_Nam. If the load failed, return
9766 -- Empty. If the compilation will not generate code, return Empty.
9768 -----------------------------
9769 -- Find_Corresponding_Body --
9770 -----------------------------
9772 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
is
9773 Context
: constant Entity_Id
:= Scope
(Spec_Id
);
9774 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9775 Body_Decl
: Node_Id
;
9776 Body_Id
: Entity_Id
;
9779 if Is_Compilation_Unit
(Spec_Id
) then
9780 Body_Id
:= Corresponding_Body
(Spec_Decl
);
9782 if Present
(Body_Id
) then
9783 return Unit_Declaration_Node
(Body_Id
);
9785 -- The package is at the library and requires a body. Load the
9786 -- corresponding body because the optional body may be declared
9789 elsif Unit_Requires_Body
(Spec_Id
) then
9792 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec_Decl
))));
9794 -- Otherwise there is no optional body
9800 -- The immediate context is a package. The optional body may be
9801 -- within the body of that package.
9803 -- procedure Proc is
9804 -- package Nested_1 is
9805 -- package Nested_2 is
9812 -- package body Nested_1 is
9813 -- package body Nested_2 is separate;
9816 -- separate (Proc.Nested_1.Nested_2)
9817 -- package body Nested_2 is
9818 -- package body Pack is -- optional body
9823 elsif Is_Package_Or_Generic_Package
(Context
) then
9824 Body_Decl
:= Find_Corresponding_Body
(Context
);
9826 -- The optional body is within the body of the enclosing package
9828 if Present
(Body_Decl
) then
9831 (Spec_Id
=> Spec_Id
,
9832 From
=> First
(Declarations
(Body_Decl
)));
9834 -- Otherwise the enclosing package does not have a body. This may
9835 -- be the result of an error or a genuine lack of a body.
9841 -- Otherwise the immediate context is a body. The optional body may
9842 -- be within the same list as the spec.
9844 -- procedure Proc is
9849 -- package body Pack is -- optional body
9856 (Spec_Id
=> Spec_Id
,
9857 From
=> Next
(Spec_Decl
));
9859 end Find_Corresponding_Body
;
9866 (Spec_Id
: Entity_Id
;
9867 From
: Node_Id
) return Node_Id
9869 Spec_Nam
: constant Name_Id
:= Chars
(Spec_Id
);
9875 while Present
(Item
) loop
9877 -- The current item denotes the optional body
9879 if Nkind
(Item
) = N_Package_Body
9880 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
9884 -- The current item denotes a stub, the optional body may be in
9887 elsif Nkind
(Item
) = N_Package_Body_Stub
9888 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
9890 Lib_Unit
:= Library_Unit
(Item
);
9892 -- The corresponding subunit was previously loaded
9894 if Present
(Lib_Unit
) then
9897 -- Otherwise attempt to load the corresponding subunit
9900 return Load_Package_Body
(Get_Unit_Name
(Item
));
9910 -----------------------
9911 -- Load_Package_Body --
9912 -----------------------
9914 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
is
9915 Body_Decl
: Node_Id
;
9916 Unit_Num
: Unit_Number_Type
;
9919 -- The load is performed only when the compilation will generate code
9921 if Operating_Mode
= Generate_Code
then
9924 (Load_Name
=> Unit_Nam
,
9927 Error_Node
=> Pack_Decl
);
9929 -- The load failed most likely because the physical file is
9932 if Unit_Num
= No_Unit
then
9935 -- Otherwise the load was successful, return the body of the unit
9938 Body_Decl
:= Unit
(Cunit
(Unit_Num
));
9940 -- If the unit is a subunit with an available proper body,
9941 -- return the proper body.
9943 if Nkind
(Body_Decl
) = N_Subunit
9944 and then Present
(Proper_Body
(Body_Decl
))
9946 Body_Decl
:= Proper_Body
(Body_Decl
);
9954 end Load_Package_Body
;
9958 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
9960 -- Start of processing for Has_Body
9963 -- The body is available
9965 if Present
(Corresponding_Body
(Pack_Decl
)) then
9968 -- The body is required if the package spec contains a construct which
9969 -- requires a completion in a body.
9971 elsif Unit_Requires_Body
(Pack_Id
) then
9974 -- The body may be optional
9977 return Present
(Find_Corresponding_Body
(Pack_Id
));
9985 function Hash
(NE
: Node_Or_Entity_Id
) return Bucket_Range_Type
is
9986 pragma Assert
(Present
(NE
));
9988 return Bucket_Range_Type
(NE
);
9991 --------------------------
9992 -- In_External_Instance --
9993 --------------------------
9995 function In_External_Instance
9997 Target_Decl
: Node_Id
) return Boolean
10000 Inst_Body
: Node_Id
;
10001 Inst_Spec
: Node_Id
;
10004 Inst
:= Find_Enclosing_Instance
(Target_Decl
);
10006 -- The target declaration appears within an instance spec. Visibility is
10007 -- ignored because internally generated primitives for private types may
10008 -- reside in the private declarations and still be invoked from outside.
10010 if Present
(Inst
) and then Nkind
(Inst
) = N_Package_Declaration
then
10012 -- The scenario comes from the main unit and the instance does not
10014 if In_Extended_Main_Code_Unit
(N
)
10015 and then not In_Extended_Main_Code_Unit
(Inst
)
10019 -- Otherwise the scenario must not appear within the instance spec or
10023 Spec_And_Body_From_Node
10025 Spec_Decl
=> Inst_Spec
,
10026 Body_Decl
=> Inst_Body
);
10028 return not In_Subtree
10030 Root1
=> Inst_Spec
,
10031 Root2
=> Inst_Body
);
10036 end In_External_Instance
;
10038 ---------------------
10039 -- In_Main_Context --
10040 ---------------------
10042 function In_Main_Context
(N
: Node_Id
) return Boolean is
10044 -- Scenarios outside the main unit are not considered because the ALI
10045 -- information supplied to binde is for the main unit only.
10047 if not In_Extended_Main_Code_Unit
(N
) then
10050 -- Scenarios within internal units are not considered unless switch
10051 -- -gnatdE (elaboration checks on predefined units) is in effect.
10053 elsif not Debug_Flag_EE
and then In_Internal_Unit
(N
) then
10058 end In_Main_Context
;
10060 ---------------------
10061 -- In_Same_Context --
10062 ---------------------
10064 function In_Same_Context
10067 Nested_OK
: Boolean := False) return Boolean
10069 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
;
10070 pragma Inline
(Find_Enclosing_Context
);
10071 -- Return the nearest enclosing non-library-level or compilation unit
10072 -- node which encapsulates arbitrary node N. Return Empty is no such
10073 -- context is available.
10075 function In_Nested_Context
10077 Inner
: Node_Id
) return Boolean;
10078 pragma Inline
(In_Nested_Context
);
10079 -- Determine whether arbitrary node Outer encapsulates arbitrary node
10082 ----------------------------
10083 -- Find_Enclosing_Context --
10084 ----------------------------
10086 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
is
10092 while Present
(Par
) loop
10094 -- A traversal from a subunit continues via the corresponding stub
10096 if Nkind
(Par
) = N_Subunit
then
10097 Par
:= Corresponding_Stub
(Par
);
10099 -- Stop the traversal when the nearest enclosing non-library-level
10100 -- encapsulator has been reached.
10102 elsif Is_Non_Library_Level_Encapsulator
(Par
) then
10103 Context
:= Parent
(Par
);
10105 -- The sole exception is when the encapsulator is the unit of
10106 -- compilation because this case requires special processing
10109 if Present
(Context
)
10110 and then Nkind
(Context
) = N_Compilation_Unit
10118 -- Reaching a compilation unit node without hitting a non-library-
10119 -- level encapsulator indicates that N is at the library level in
10120 -- which case the compilation unit is the context.
10122 elsif Nkind
(Par
) = N_Compilation_Unit
then
10126 Par
:= Parent
(Par
);
10130 end Find_Enclosing_Context
;
10132 -----------------------
10133 -- In_Nested_Context --
10134 -----------------------
10136 function In_Nested_Context
10138 Inner
: Node_Id
) return Boolean
10144 while Present
(Par
) loop
10146 -- A traversal from a subunit continues via the corresponding stub
10148 if Nkind
(Par
) = N_Subunit
then
10149 Par
:= Corresponding_Stub
(Par
);
10151 elsif Par
= Outer
then
10155 Par
:= Parent
(Par
);
10159 end In_Nested_Context
;
10163 Context_1
: constant Node_Id
:= Find_Enclosing_Context
(N1
);
10164 Context_2
: constant Node_Id
:= Find_Enclosing_Context
(N2
);
10166 -- Start of processing for In_Same_Context
10169 -- Both nodes appear within the same context
10171 if Context_1
= Context_2
then
10174 -- Both nodes appear in compilation units. Determine whether one unit
10175 -- is the body of the other.
10177 elsif Nkind
(Context_1
) = N_Compilation_Unit
10178 and then Nkind
(Context_2
) = N_Compilation_Unit
10182 (Unit_1
=> Defining_Entity
(Unit
(Context_1
)),
10183 Unit_2
=> Defining_Entity
(Unit
(Context_2
)));
10185 -- The context of N1 encloses the context of N2
10187 elsif Nested_OK
and then In_Nested_Context
(Context_1
, Context_2
) then
10192 end In_Same_Context
;
10198 procedure Initialize
is
10200 -- Set the soft link which enables Atree.Rewrite to update a scenario
10201 -- each time it is transformed into another node.
10203 Set_Rewriting_Proc
(Update_Elaboration_Scenario
'Access);
10205 -- Create all internal data structures and activate the elaboration
10206 -- phase of the compiler.
10208 Initialize_All_Data_Structures
;
10209 Set_Elaboration_Phase
(Active
);
10212 ------------------------------------
10213 -- Initialize_All_Data_Structures --
10214 ------------------------------------
10216 procedure Initialize_All_Data_Structures
is
10218 Initialize_Body_Processor
;
10219 Initialize_Early_Call_Region_Processor
;
10220 Initialize_Elaborated_Units
;
10221 Initialize_Internal_Representation
;
10222 Initialize_Invocation_Graph
;
10223 Initialize_Scenario_Storage
;
10224 end Initialize_All_Data_Structures
;
10226 --------------------------
10227 -- Instantiated_Generic --
10228 --------------------------
10230 function Instantiated_Generic
(Inst
: Node_Id
) return Entity_Id
is
10232 -- Traverse a possible chain of renamings to obtain the original generic
10233 -- being instantiatied.
10235 return Get_Renamed_Entity
(Entity
(Name
(Inst
)));
10236 end Instantiated_Generic
;
10238 -----------------------------
10239 -- Internal_Representation --
10240 -----------------------------
10242 package body Internal_Representation
is
10248 -- The following type represents the contents of a scenario
10250 type Scenario_Rep_Record
is record
10251 Elab_Checks_OK
: Boolean := False;
10252 -- The status of elaboration checks for the scenario
10254 Elab_Warnings_OK
: Boolean := False;
10255 -- The status of elaboration warnings for the scenario
10257 GM
: Extended_Ghost_Mode
:= Is_Checked_Or_Not_Specified
;
10258 -- The Ghost mode of the scenario
10260 Kind
: Scenario_Kind
:= No_Scenario
;
10261 -- The nature of the scenario
10263 Level
: Enclosing_Level_Kind
:= No_Level
;
10264 -- The enclosing level where the scenario resides
10266 SM
: Extended_SPARK_Mode
:= Is_Off_Or_Not_Specified
;
10267 -- The SPARK mode of the scenario
10269 Target
: Entity_Id
:= Empty
;
10270 -- The target of the scenario
10272 -- The following attributes are multiplexed and depend on the Kind of
10273 -- the scenario. They are mapped as follows:
10276 -- Is_Dispatching_Call (Flag_1)
10278 -- Task_Activation_Scenario
10279 -- Activated_Task_Objects (List_1)
10280 -- Activated_Task_Type (Field_1)
10282 -- Variable_Reference
10283 -- Is_Read_Reference (Flag_1)
10285 Flag_1
: Boolean := False;
10286 Field_1
: Node_Or_Entity_Id
:= Empty
;
10287 List_1
: NE_List
.Doubly_Linked_List
:= NE_List
.Nil
;
10290 -- The following type represents the contents of a target
10292 type Target_Rep_Record
is record
10293 Body_Decl
: Node_Id
:= Empty
;
10294 -- The declaration of the target body
10296 Elab_Checks_OK
: Boolean := False;
10297 -- The status of elaboration checks for the target
10299 Elab_Warnings_OK
: Boolean := False;
10300 -- The status of elaboration warnings for the target
10302 GM
: Extended_Ghost_Mode
:= Is_Checked_Or_Not_Specified
;
10303 -- The Ghost mode of the target
10305 Kind
: Target_Kind
:= No_Target
;
10306 -- The nature of the target
10308 SM
: Extended_SPARK_Mode
:= Is_Off_Or_Not_Specified
;
10309 -- The SPARK mode of the target
10311 Spec_Decl
: Node_Id
:= Empty
;
10312 -- The declaration of the target spec
10314 Unit
: Entity_Id
:= Empty
;
10315 -- The top unit where the target is declared
10317 Version
: Representation_Kind
:= No_Representation
;
10318 -- The version of the target representation
10320 -- The following attributes are multiplexed and depend on the Kind of
10321 -- the target. They are mapped as follows:
10323 -- Subprogram_Target
10324 -- Barrier_Body_Declaration (Field_1)
10327 -- Variable_Declaration (Field_1)
10329 Field_1
: Node_Or_Entity_Id
:= Empty
;
10332 ---------------------
10333 -- Data structures --
10334 ---------------------
10336 procedure Destroy
(T_Id
: in out Target_Rep_Id
);
10337 -- Destroy a target representation T_Id
10339 package ETT_Map
is new Dynamic_Hash_Tables
10340 (Key_Type
=> Entity_Id
,
10341 Value_Type
=> Target_Rep_Id
,
10342 No_Value
=> No_Target_Rep
,
10343 Expansion_Threshold
=> 1.5,
10344 Expansion_Factor
=> 2,
10345 Compression_Threshold
=> 0.3,
10346 Compression_Factor
=> 2,
10348 Destroy_Value
=> Destroy
,
10351 -- The following map relates target representations to entities
10353 Entity_To_Target_Map
: ETT_Map
.Dynamic_Hash_Table
:= ETT_Map
.Nil
;
10355 procedure Destroy
(S_Id
: in out Scenario_Rep_Id
);
10356 -- Destroy a scenario representation S_Id
10358 package NTS_Map
is new Dynamic_Hash_Tables
10359 (Key_Type
=> Node_Id
,
10360 Value_Type
=> Scenario_Rep_Id
,
10361 No_Value
=> No_Scenario_Rep
,
10362 Expansion_Threshold
=> 1.5,
10363 Expansion_Factor
=> 2,
10364 Compression_Threshold
=> 0.3,
10365 Compression_Factor
=> 2,
10367 Destroy_Value
=> Destroy
,
10370 -- The following map relates scenario representations to nodes
10372 Node_To_Scenario_Map
: NTS_Map
.Dynamic_Hash_Table
:= NTS_Map
.Nil
;
10374 -- The following table stores all scenario representations
10376 package Scenario_Reps
is new Table
.Table
10377 (Table_Index_Type
=> Scenario_Rep_Id
,
10378 Table_Component_Type
=> Scenario_Rep_Record
,
10379 Table_Low_Bound
=> First_Scenario_Rep
,
10380 Table_Initial
=> 1000,
10381 Table_Increment
=> 200,
10382 Table_Name
=> "Scenario_Reps");
10384 -- The following table stores all target representations
10386 package Target_Reps
is new Table
.Table
10387 (Table_Index_Type
=> Target_Rep_Id
,
10388 Table_Component_Type
=> Target_Rep_Record
,
10389 Table_Low_Bound
=> First_Target_Rep
,
10390 Table_Initial
=> 1000,
10391 Table_Increment
=> 200,
10392 Table_Name
=> "Target_Reps");
10398 function Create_Access_Taken_Rep
10399 (Attr
: Node_Id
) return Scenario_Rep_Record
;
10400 pragma Inline
(Create_Access_Taken_Rep
);
10401 -- Create the representation of 'Access attribute Attr
10403 function Create_Call_Or_Task_Activation_Rep
10404 (Call
: Node_Id
) return Scenario_Rep_Record
;
10405 pragma Inline
(Create_Call_Or_Task_Activation_Rep
);
10406 -- Create the representation of call or task activation Call
10408 function Create_Derived_Type_Rep
10409 (Typ_Decl
: Node_Id
) return Scenario_Rep_Record
;
10410 pragma Inline
(Create_Derived_Type_Rep
);
10411 -- Create the representation of a derived type described by declaration
10414 function Create_Generic_Rep
10415 (Gen_Id
: Entity_Id
) return Target_Rep_Record
;
10416 pragma Inline
(Create_Generic_Rep
);
10417 -- Create the representation of generic Gen_Id
10419 function Create_Instantiation_Rep
10420 (Inst
: Node_Id
) return Scenario_Rep_Record
;
10421 pragma Inline
(Create_Instantiation_Rep
);
10422 -- Create the representation of instantiation Inst
10424 function Create_Package_Rep
10425 (Pack_Id
: Entity_Id
) return Target_Rep_Record
;
10426 pragma Inline
(Create_Package_Rep
);
10427 -- Create the representation of package Pack_Id
10429 function Create_Protected_Entry_Rep
10430 (PE_Id
: Entity_Id
) return Target_Rep_Record
;
10431 pragma Inline
(Create_Protected_Entry_Rep
);
10432 -- Create the representation of protected entry PE_Id
10434 function Create_Protected_Subprogram_Rep
10435 (PS_Id
: Entity_Id
) return Target_Rep_Record
;
10436 pragma Inline
(Create_Protected_Subprogram_Rep
);
10437 -- Create the representation of protected subprogram PS_Id
10439 function Create_Refined_State_Pragma_Rep
10440 (Prag
: Node_Id
) return Scenario_Rep_Record
;
10441 pragma Inline
(Create_Refined_State_Pragma_Rep
);
10442 -- Create the representation of Refined_State pragma Prag
10444 function Create_Scenario_Rep
10446 In_State
: Processing_In_State
) return Scenario_Rep_Record
;
10447 pragma Inline
(Create_Scenario_Rep
);
10448 -- Top level dispatcher. Create the representation of elaboration
10449 -- scenario N. In_State is the current state of the Processing phase.
10451 function Create_Subprogram_Rep
10452 (Subp_Id
: Entity_Id
) return Target_Rep_Record
;
10453 pragma Inline
(Create_Subprogram_Rep
);
10454 -- Create the representation of entry, operator, or subprogram Subp_Id
10456 function Create_Target_Rep
10458 In_State
: Processing_In_State
) return Target_Rep_Record
;
10459 pragma Inline
(Create_Target_Rep
);
10460 -- Top level dispatcher. Create the representation of elaboration target
10461 -- Id. In_State is the current state of the Processing phase.
10463 function Create_Task_Entry_Rep
10464 (TE_Id
: Entity_Id
) return Target_Rep_Record
;
10465 pragma Inline
(Create_Task_Entry_Rep
);
10466 -- Create the representation of task entry TE_Id
10468 function Create_Task_Rep
(Task_Typ
: Entity_Id
) return Target_Rep_Record
;
10469 pragma Inline
(Create_Task_Rep
);
10470 -- Create the representation of task type Typ
10472 function Create_Variable_Assignment_Rep
10473 (Asmt
: Node_Id
) return Scenario_Rep_Record
;
10474 pragma Inline
(Create_Variable_Assignment_Rep
);
10475 -- Create the representation of variable assignment Asmt
10477 function Create_Variable_Reference_Rep
10478 (Ref
: Node_Id
) return Scenario_Rep_Record
;
10479 pragma Inline
(Create_Variable_Reference_Rep
);
10480 -- Create the representation of variable reference Ref
10482 function Create_Variable_Rep
10483 (Var_Id
: Entity_Id
) return Target_Rep_Record
;
10484 pragma Inline
(Create_Variable_Rep
);
10485 -- Create the representation of variable Var_Id
10487 -----------------------
10488 -- Local subprograms --
10489 -----------------------
10491 function Ghost_Mode_Of_Entity
10492 (Id
: Entity_Id
) return Extended_Ghost_Mode
;
10493 pragma Inline
(Ghost_Mode_Of_Entity
);
10494 -- Obtain the extended Ghost mode of arbitrary entity Id
10496 function Ghost_Mode_Of_Node
(N
: Node_Id
) return Extended_Ghost_Mode
;
10497 pragma Inline
(Ghost_Mode_Of_Node
);
10498 -- Obtain the extended Ghost mode of arbitrary node N
10500 function Present
(S_Id
: Scenario_Rep_Id
) return Boolean;
10501 pragma Inline
(Present
);
10502 -- Determine whether scenario representation S_Id exists
10504 function Present
(T_Id
: Target_Rep_Id
) return Boolean;
10505 pragma Inline
(Present
);
10506 -- Determine whether target representation T_Id exists
10508 function SPARK_Mode_Of_Entity
10509 (Id
: Entity_Id
) return Extended_SPARK_Mode
;
10510 pragma Inline
(SPARK_Mode_Of_Entity
);
10511 -- Obtain the extended SPARK mode of arbitrary entity Id
10513 function SPARK_Mode_Of_Node
(N
: Node_Id
) return Extended_SPARK_Mode
;
10514 pragma Inline
(SPARK_Mode_Of_Node
);
10515 -- Obtain the extended SPARK mode of arbitrary node N
10517 function To_Ghost_Mode
10518 (Ignored_Status
: Boolean) return Extended_Ghost_Mode
;
10519 pragma Inline
(To_Ghost_Mode
);
10520 -- Convert a Ghost mode indicated by Ignored_Status into its extended
10523 function To_SPARK_Mode
(On_Status
: Boolean) return Extended_SPARK_Mode
;
10524 pragma Inline
(To_SPARK_Mode
);
10525 -- Convert a SPARK mode indicated by On_Status into its extended
10528 function Version
(T_Id
: Target_Rep_Id
) return Representation_Kind
;
10529 pragma Inline
(Version
);
10530 -- Obtain the version of target representation T_Id
10532 ----------------------------
10533 -- Activated_Task_Objects --
10534 ----------------------------
10536 function Activated_Task_Objects
10537 (S_Id
: Scenario_Rep_Id
) return NE_List
.Doubly_Linked_List
10539 pragma Assert
(Present
(S_Id
));
10540 pragma Assert
(Kind
(S_Id
) = Task_Activation_Scenario
);
10543 return Scenario_Reps
.Table
(S_Id
).List_1
;
10544 end Activated_Task_Objects
;
10546 -------------------------
10547 -- Activated_Task_Type --
10548 -------------------------
10550 function Activated_Task_Type
10551 (S_Id
: Scenario_Rep_Id
) return Entity_Id
10553 pragma Assert
(Present
(S_Id
));
10554 pragma Assert
(Kind
(S_Id
) = Task_Activation_Scenario
);
10557 return Scenario_Reps
.Table
(S_Id
).Field_1
;
10558 end Activated_Task_Type
;
10560 ------------------------------
10561 -- Barrier_Body_Declaration --
10562 ------------------------------
10564 function Barrier_Body_Declaration
10565 (T_Id
: Target_Rep_Id
) return Node_Id
10567 pragma Assert
(Present
(T_Id
));
10568 pragma Assert
(Kind
(T_Id
) = Subprogram_Target
);
10571 return Target_Reps
.Table
(T_Id
).Field_1
;
10572 end Barrier_Body_Declaration
;
10574 ----------------------
10575 -- Body_Declaration --
10576 ----------------------
10578 function Body_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
is
10579 pragma Assert
(Present
(T_Id
));
10581 return Target_Reps
.Table
(T_Id
).Body_Decl
;
10582 end Body_Declaration
;
10584 -----------------------------
10585 -- Create_Access_Taken_Rep --
10586 -----------------------------
10588 function Create_Access_Taken_Rep
10589 (Attr
: Node_Id
) return Scenario_Rep_Record
10591 Rec
: Scenario_Rep_Record
;
10594 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Attr
);
10595 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Node
(Attr
);
10596 Rec
.GM
:= Is_Checked_Or_Not_Specified
;
10597 Rec
.SM
:= SPARK_Mode_Of_Node
(Attr
);
10598 Rec
.Kind
:= Access_Taken_Scenario
;
10599 Rec
.Target
:= Canonical_Subprogram
(Entity
(Prefix
(Attr
)));
10602 end Create_Access_Taken_Rep
;
10604 ----------------------------------------
10605 -- Create_Call_Or_Task_Activation_Rep --
10606 ----------------------------------------
10608 function Create_Call_Or_Task_Activation_Rep
10609 (Call
: Node_Id
) return Scenario_Rep_Record
10611 Subp_Id
: constant Entity_Id
:= Canonical_Subprogram
(Target
(Call
));
10612 Kind
: Scenario_Kind
;
10613 Rec
: Scenario_Rep_Record
;
10616 if Is_Activation_Proc
(Subp_Id
) then
10617 Kind
:= Task_Activation_Scenario
;
10619 Kind
:= Call_Scenario
;
10622 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Call
);
10623 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Node
(Call
);
10624 Rec
.GM
:= Ghost_Mode_Of_Node
(Call
);
10625 Rec
.SM
:= SPARK_Mode_Of_Node
(Call
);
10627 Rec
.Target
:= Subp_Id
;
10629 -- Scenario-specific attributes
10631 Rec
.Flag_1
:= Is_Dispatching_Call
(Call
); -- Dispatching_Call
10634 end Create_Call_Or_Task_Activation_Rep
;
10636 -----------------------------
10637 -- Create_Derived_Type_Rep --
10638 -----------------------------
10640 function Create_Derived_Type_Rep
10641 (Typ_Decl
: Node_Id
) return Scenario_Rep_Record
10643 Typ
: constant Entity_Id
:= Defining_Entity
(Typ_Decl
);
10644 Rec
: Scenario_Rep_Record
;
10647 Rec
.Elab_Checks_OK
:= False; -- not relevant
10648 Rec
.Elab_Warnings_OK
:= False; -- not relevant
10649 Rec
.GM
:= Ghost_Mode_Of_Entity
(Typ
);
10650 Rec
.SM
:= SPARK_Mode_Of_Entity
(Typ
);
10651 Rec
.Kind
:= Derived_Type_Scenario
;
10655 end Create_Derived_Type_Rep
;
10657 ------------------------
10658 -- Create_Generic_Rep --
10659 ------------------------
10661 function Create_Generic_Rep
10662 (Gen_Id
: Entity_Id
) return Target_Rep_Record
10664 Rec
: Target_Rep_Record
;
10667 Rec
.Kind
:= Generic_Target
;
10669 Spec_And_Body_From_Entity
10671 Body_Decl
=> Rec
.Body_Decl
,
10672 Spec_Decl
=> Rec
.Spec_Decl
);
10675 end Create_Generic_Rep
;
10677 ------------------------------
10678 -- Create_Instantiation_Rep --
10679 ------------------------------
10681 function Create_Instantiation_Rep
10682 (Inst
: Node_Id
) return Scenario_Rep_Record
10684 Rec
: Scenario_Rep_Record
;
10687 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Inst
);
10688 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Node
(Inst
);
10689 Rec
.GM
:= Ghost_Mode_Of_Node
(Inst
);
10690 Rec
.SM
:= SPARK_Mode_Of_Node
(Inst
);
10691 Rec
.Kind
:= Instantiation_Scenario
;
10692 Rec
.Target
:= Instantiated_Generic
(Inst
);
10695 end Create_Instantiation_Rep
;
10697 ------------------------
10698 -- Create_Package_Rep --
10699 ------------------------
10701 function Create_Package_Rep
10702 (Pack_Id
: Entity_Id
) return Target_Rep_Record
10704 Rec
: Target_Rep_Record
;
10707 Rec
.Kind
:= Package_Target
;
10709 Spec_And_Body_From_Entity
10711 Body_Decl
=> Rec
.Body_Decl
,
10712 Spec_Decl
=> Rec
.Spec_Decl
);
10715 end Create_Package_Rep
;
10717 --------------------------------
10718 -- Create_Protected_Entry_Rep --
10719 --------------------------------
10721 function Create_Protected_Entry_Rep
10722 (PE_Id
: Entity_Id
) return Target_Rep_Record
10724 Prot_Id
: constant Entity_Id
:= Protected_Body_Subprogram
(PE_Id
);
10726 Barf_Id
: Entity_Id
;
10728 Rec
: Target_Rep_Record
;
10729 Spec_Id
: Entity_Id
;
10732 -- When the entry [family] has already been expanded, it carries both
10733 -- the procedure which emulates the behavior of the entry [family] as
10734 -- well as the barrier function.
10736 if Present
(Prot_Id
) then
10737 Barf_Id
:= Barrier_Function
(PE_Id
);
10738 Spec_Id
:= Prot_Id
;
10740 -- Otherwise no expansion took place
10747 Rec
.Kind
:= Subprogram_Target
;
10749 Spec_And_Body_From_Entity
10751 Body_Decl
=> Rec
.Body_Decl
,
10752 Spec_Decl
=> Rec
.Spec_Decl
);
10754 -- Target-specific attributes
10756 if Present
(Barf_Id
) then
10757 Spec_And_Body_From_Entity
10759 Body_Decl
=> Rec
.Field_1
, -- Barrier_Body_Declaration
10760 Spec_Decl
=> Dummy
);
10764 end Create_Protected_Entry_Rep
;
10766 -------------------------------------
10767 -- Create_Protected_Subprogram_Rep --
10768 -------------------------------------
10770 function Create_Protected_Subprogram_Rep
10771 (PS_Id
: Entity_Id
) return Target_Rep_Record
10773 Prot_Id
: constant Entity_Id
:= Protected_Body_Subprogram
(PS_Id
);
10774 Rec
: Target_Rep_Record
;
10775 Spec_Id
: Entity_Id
;
10778 -- When the protected subprogram has already been expanded, it
10779 -- carries the subprogram which seizes the lock and invokes the
10780 -- original statements.
10782 if Present
(Prot_Id
) then
10783 Spec_Id
:= Prot_Id
;
10785 -- Otherwise no expansion took place
10791 Rec
.Kind
:= Subprogram_Target
;
10793 Spec_And_Body_From_Entity
10795 Body_Decl
=> Rec
.Body_Decl
,
10796 Spec_Decl
=> Rec
.Spec_Decl
);
10799 end Create_Protected_Subprogram_Rep
;
10801 -------------------------------------
10802 -- Create_Refined_State_Pragma_Rep --
10803 -------------------------------------
10805 function Create_Refined_State_Pragma_Rep
10806 (Prag
: Node_Id
) return Scenario_Rep_Record
10808 Rec
: Scenario_Rep_Record
;
10811 Rec
.Elab_Checks_OK
:= False; -- not relevant
10812 Rec
.Elab_Warnings_OK
:= False; -- not relevant
10814 To_Ghost_Mode
(Is_Ignored_Ghost_Pragma
(Prag
));
10815 Rec
.SM
:= Is_Off_Or_Not_Specified
;
10816 Rec
.Kind
:= Refined_State_Pragma_Scenario
;
10817 Rec
.Target
:= Empty
;
10820 end Create_Refined_State_Pragma_Rep
;
10822 -------------------------
10823 -- Create_Scenario_Rep --
10824 -------------------------
10826 function Create_Scenario_Rep
10828 In_State
: Processing_In_State
) return Scenario_Rep_Record
10830 pragma Unreferenced
(In_State
);
10832 Rec
: Scenario_Rep_Record
;
10835 if Is_Suitable_Access_Taken
(N
) then
10836 Rec
:= Create_Access_Taken_Rep
(N
);
10838 elsif Is_Suitable_Call
(N
) then
10839 Rec
:= Create_Call_Or_Task_Activation_Rep
(N
);
10841 elsif Is_Suitable_Instantiation
(N
) then
10842 Rec
:= Create_Instantiation_Rep
(N
);
10844 elsif Is_Suitable_SPARK_Derived_Type
(N
) then
10845 Rec
:= Create_Derived_Type_Rep
(N
);
10847 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
10848 Rec
:= Create_Refined_State_Pragma_Rep
(N
);
10850 elsif Is_Suitable_Variable_Assignment
(N
) then
10851 Rec
:= Create_Variable_Assignment_Rep
(N
);
10853 elsif Is_Suitable_Variable_Reference
(N
) then
10854 Rec
:= Create_Variable_Reference_Rep
(N
);
10857 pragma Assert
(False);
10861 -- Common scenario attributes
10863 Rec
.Level
:= Find_Enclosing_Level
(N
);
10866 end Create_Scenario_Rep
;
10868 ---------------------------
10869 -- Create_Subprogram_Rep --
10870 ---------------------------
10872 function Create_Subprogram_Rep
10873 (Subp_Id
: Entity_Id
) return Target_Rep_Record
10875 Rec
: Target_Rep_Record
;
10876 Spec_Id
: Entity_Id
;
10879 Spec_Id
:= Subp_Id
;
10880 Rec
.Kind
:= Subprogram_Target
;
10882 Spec_And_Body_From_Entity
10884 Body_Decl
=> Rec
.Body_Decl
,
10885 Spec_Decl
=> Rec
.Spec_Decl
);
10888 end Create_Subprogram_Rep
;
10890 -----------------------
10891 -- Create_Target_Rep --
10892 -----------------------
10894 function Create_Target_Rep
10896 In_State
: Processing_In_State
) return Target_Rep_Record
10898 Rec
: Target_Rep_Record
;
10901 if Is_Generic_Unit
(Id
) then
10902 Rec
:= Create_Generic_Rep
(Id
);
10904 elsif Is_Protected_Entry
(Id
) then
10905 Rec
:= Create_Protected_Entry_Rep
(Id
);
10907 elsif Is_Protected_Subp
(Id
) then
10908 Rec
:= Create_Protected_Subprogram_Rep
(Id
);
10910 elsif Is_Task_Entry
(Id
) then
10911 Rec
:= Create_Task_Entry_Rep
(Id
);
10913 elsif Is_Task_Type
(Id
) then
10914 Rec
:= Create_Task_Rep
(Id
);
10916 elsif Ekind
(Id
) in E_Constant | E_Variable
then
10917 Rec
:= Create_Variable_Rep
(Id
);
10919 elsif Ekind
(Id
) in E_Entry | E_Function | E_Operator | E_Procedure
10921 Rec
:= Create_Subprogram_Rep
(Id
);
10923 elsif Ekind
(Id
) = E_Package
then
10924 Rec
:= Create_Package_Rep
(Id
);
10927 pragma Assert
(False);
10931 -- Common target attributes
10933 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Id
(Id
);
10934 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Id
(Id
);
10935 Rec
.GM
:= Ghost_Mode_Of_Entity
(Id
);
10936 Rec
.SM
:= SPARK_Mode_Of_Entity
(Id
);
10937 Rec
.Unit
:= Find_Top_Unit
(Id
);
10938 Rec
.Version
:= In_State
.Representation
;
10941 end Create_Target_Rep
;
10943 ---------------------------
10944 -- Create_Task_Entry_Rep --
10945 ---------------------------
10947 function Create_Task_Entry_Rep
10948 (TE_Id
: Entity_Id
) return Target_Rep_Record
10950 Task_Typ
: constant Entity_Id
:= Non_Private_View
(Scope
(TE_Id
));
10951 Task_Body_Id
: constant Entity_Id
:= Task_Body_Procedure
(Task_Typ
);
10953 Rec
: Target_Rep_Record
;
10954 Spec_Id
: Entity_Id
;
10957 -- The task type has already been expanded, it carries the procedure
10958 -- which emulates the behavior of the task body.
10960 if Present
(Task_Body_Id
) then
10961 Spec_Id
:= Task_Body_Id
;
10963 -- Otherwise no expansion took place
10969 Rec
.Kind
:= Subprogram_Target
;
10971 Spec_And_Body_From_Entity
10973 Body_Decl
=> Rec
.Body_Decl
,
10974 Spec_Decl
=> Rec
.Spec_Decl
);
10977 end Create_Task_Entry_Rep
;
10979 ---------------------
10980 -- Create_Task_Rep --
10981 ---------------------
10983 function Create_Task_Rep
10984 (Task_Typ
: Entity_Id
) return Target_Rep_Record
10986 Task_Body_Id
: constant Entity_Id
:= Task_Body_Procedure
(Task_Typ
);
10988 Rec
: Target_Rep_Record
;
10989 Spec_Id
: Entity_Id
;
10992 -- The task type has already been expanded, it carries the procedure
10993 -- which emulates the behavior of the task body.
10995 if Present
(Task_Body_Id
) then
10996 Spec_Id
:= Task_Body_Id
;
10998 -- Otherwise no expansion took place
11001 Spec_Id
:= Task_Typ
;
11004 Rec
.Kind
:= Task_Target
;
11006 Spec_And_Body_From_Entity
11008 Body_Decl
=> Rec
.Body_Decl
,
11009 Spec_Decl
=> Rec
.Spec_Decl
);
11012 end Create_Task_Rep
;
11014 ------------------------------------
11015 -- Create_Variable_Assignment_Rep --
11016 ------------------------------------
11018 function Create_Variable_Assignment_Rep
11019 (Asmt
: Node_Id
) return Scenario_Rep_Record
11021 Var_Id
: constant Entity_Id
:= Entity
(Assignment_Target
(Asmt
));
11022 Rec
: Scenario_Rep_Record
;
11025 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Asmt
);
11026 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Id
(Var_Id
);
11027 Rec
.GM
:= Ghost_Mode_Of_Node
(Asmt
);
11028 Rec
.SM
:= SPARK_Mode_Of_Node
(Asmt
);
11029 Rec
.Kind
:= Variable_Assignment_Scenario
;
11030 Rec
.Target
:= Var_Id
;
11033 end Create_Variable_Assignment_Rep
;
11035 -----------------------------------
11036 -- Create_Variable_Reference_Rep --
11037 -----------------------------------
11039 function Create_Variable_Reference_Rep
11040 (Ref
: Node_Id
) return Scenario_Rep_Record
11042 Rec
: Scenario_Rep_Record
;
11045 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Ref
);
11046 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Node
(Ref
);
11047 Rec
.GM
:= Ghost_Mode_Of_Node
(Ref
);
11048 Rec
.SM
:= SPARK_Mode_Of_Node
(Ref
);
11049 Rec
.Kind
:= Variable_Reference_Scenario
;
11050 Rec
.Target
:= Target
(Ref
);
11052 -- Scenario-specific attributes
11054 Rec
.Flag_1
:= Is_Read
(Ref
); -- Is_Read_Reference
11057 end Create_Variable_Reference_Rep
;
11059 -------------------------
11060 -- Create_Variable_Rep --
11061 -------------------------
11063 function Create_Variable_Rep
11064 (Var_Id
: Entity_Id
) return Target_Rep_Record
11066 Rec
: Target_Rep_Record
;
11069 Rec
.Kind
:= Variable_Target
;
11071 -- Target-specific attributes
11073 Rec
.Field_1
:= Declaration_Node
(Var_Id
); -- Variable_Declaration
11076 end Create_Variable_Rep
;
11082 procedure Destroy
(S_Id
: in out Scenario_Rep_Id
) is
11083 pragma Unreferenced
(S_Id
);
11092 procedure Destroy
(T_Id
: in out Target_Rep_Id
) is
11093 pragma Unreferenced
(T_Id
);
11098 --------------------------------
11099 -- Disable_Elaboration_Checks --
11100 --------------------------------
11102 procedure Disable_Elaboration_Checks
(S_Id
: Scenario_Rep_Id
) is
11103 pragma Assert
(Present
(S_Id
));
11105 Scenario_Reps
.Table
(S_Id
).Elab_Checks_OK
:= False;
11106 end Disable_Elaboration_Checks
;
11108 --------------------------------
11109 -- Disable_Elaboration_Checks --
11110 --------------------------------
11112 procedure Disable_Elaboration_Checks
(T_Id
: Target_Rep_Id
) is
11113 pragma Assert
(Present
(T_Id
));
11115 Target_Reps
.Table
(T_Id
).Elab_Checks_OK
:= False;
11116 end Disable_Elaboration_Checks
;
11118 ---------------------------
11119 -- Elaboration_Checks_OK --
11120 ---------------------------
11122 function Elaboration_Checks_OK
(S_Id
: Scenario_Rep_Id
) return Boolean is
11123 pragma Assert
(Present
(S_Id
));
11125 return Scenario_Reps
.Table
(S_Id
).Elab_Checks_OK
;
11126 end Elaboration_Checks_OK
;
11128 ---------------------------
11129 -- Elaboration_Checks_OK --
11130 ---------------------------
11132 function Elaboration_Checks_OK
(T_Id
: Target_Rep_Id
) return Boolean is
11133 pragma Assert
(Present
(T_Id
));
11135 return Target_Reps
.Table
(T_Id
).Elab_Checks_OK
;
11136 end Elaboration_Checks_OK
;
11138 -----------------------------
11139 -- Elaboration_Warnings_OK --
11140 -----------------------------
11142 function Elaboration_Warnings_OK
11143 (S_Id
: Scenario_Rep_Id
) return Boolean
11145 pragma Assert
(Present
(S_Id
));
11147 return Scenario_Reps
.Table
(S_Id
).Elab_Warnings_OK
;
11148 end Elaboration_Warnings_OK
;
11150 -----------------------------
11151 -- Elaboration_Warnings_OK --
11152 -----------------------------
11154 function Elaboration_Warnings_OK
(T_Id
: Target_Rep_Id
) return Boolean is
11155 pragma Assert
(Present
(T_Id
));
11157 return Target_Reps
.Table
(T_Id
).Elab_Warnings_OK
;
11158 end Elaboration_Warnings_OK
;
11160 --------------------------------------
11161 -- Finalize_Internal_Representation --
11162 --------------------------------------
11164 procedure Finalize_Internal_Representation
is
11166 ETT_Map
.Destroy
(Entity_To_Target_Map
);
11167 NTS_Map
.Destroy
(Node_To_Scenario_Map
);
11168 end Finalize_Internal_Representation
;
11170 -------------------
11171 -- Ghost_Mode_Of --
11172 -------------------
11174 function Ghost_Mode_Of
11175 (S_Id
: Scenario_Rep_Id
) return Extended_Ghost_Mode
11177 pragma Assert
(Present
(S_Id
));
11179 return Scenario_Reps
.Table
(S_Id
).GM
;
11182 -------------------
11183 -- Ghost_Mode_Of --
11184 -------------------
11186 function Ghost_Mode_Of
11187 (T_Id
: Target_Rep_Id
) return Extended_Ghost_Mode
11189 pragma Assert
(Present
(T_Id
));
11191 return Target_Reps
.Table
(T_Id
).GM
;
11194 --------------------------
11195 -- Ghost_Mode_Of_Entity --
11196 --------------------------
11198 function Ghost_Mode_Of_Entity
11199 (Id
: Entity_Id
) return Extended_Ghost_Mode
11202 return To_Ghost_Mode
(Is_Ignored_Ghost_Entity
(Id
));
11203 end Ghost_Mode_Of_Entity
;
11205 ------------------------
11206 -- Ghost_Mode_Of_Node --
11207 ------------------------
11209 function Ghost_Mode_Of_Node
(N
: Node_Id
) return Extended_Ghost_Mode
is
11211 return To_Ghost_Mode
(Is_Ignored_Ghost_Node
(N
));
11212 end Ghost_Mode_Of_Node
;
11214 ----------------------------------------
11215 -- Initialize_Internal_Representation --
11216 ----------------------------------------
11218 procedure Initialize_Internal_Representation
is
11220 Entity_To_Target_Map
:= ETT_Map
.Create
(500);
11221 Node_To_Scenario_Map
:= NTS_Map
.Create
(500);
11222 end Initialize_Internal_Representation
;
11224 -------------------------
11225 -- Is_Dispatching_Call --
11226 -------------------------
11228 function Is_Dispatching_Call
(S_Id
: Scenario_Rep_Id
) return Boolean is
11229 pragma Assert
(Present
(S_Id
));
11230 pragma Assert
(Kind
(S_Id
) = Call_Scenario
);
11233 return Scenario_Reps
.Table
(S_Id
).Flag_1
;
11234 end Is_Dispatching_Call
;
11236 -----------------------
11237 -- Is_Read_Reference --
11238 -----------------------
11240 function Is_Read_Reference
(S_Id
: Scenario_Rep_Id
) return Boolean is
11241 pragma Assert
(Present
(S_Id
));
11242 pragma Assert
(Kind
(S_Id
) = Variable_Reference_Scenario
);
11245 return Scenario_Reps
.Table
(S_Id
).Flag_1
;
11246 end Is_Read_Reference
;
11252 function Kind
(S_Id
: Scenario_Rep_Id
) return Scenario_Kind
is
11253 pragma Assert
(Present
(S_Id
));
11255 return Scenario_Reps
.Table
(S_Id
).Kind
;
11262 function Kind
(T_Id
: Target_Rep_Id
) return Target_Kind
is
11263 pragma Assert
(Present
(T_Id
));
11265 return Target_Reps
.Table
(T_Id
).Kind
;
11272 function Level
(S_Id
: Scenario_Rep_Id
) return Enclosing_Level_Kind
is
11273 pragma Assert
(Present
(S_Id
));
11275 return Scenario_Reps
.Table
(S_Id
).Level
;
11282 function Present
(S_Id
: Scenario_Rep_Id
) return Boolean is
11284 return S_Id
/= No_Scenario_Rep
;
11291 function Present
(T_Id
: Target_Rep_Id
) return Boolean is
11293 return T_Id
/= No_Target_Rep
;
11296 --------------------------------
11297 -- Scenario_Representation_Of --
11298 --------------------------------
11300 function Scenario_Representation_Of
11302 In_State
: Processing_In_State
) return Scenario_Rep_Id
11304 S_Id
: Scenario_Rep_Id
;
11307 S_Id
:= NTS_Map
.Get
(Node_To_Scenario_Map
, N
);
11309 -- The elaboration scenario lacks a representation. This indicates
11310 -- that the scenario is encountered for the first time. Create the
11311 -- representation of it.
11313 if not Present
(S_Id
) then
11314 Scenario_Reps
.Append
(Create_Scenario_Rep
(N
, In_State
));
11315 S_Id
:= Scenario_Reps
.Last
;
11317 -- Associate the internal representation with the elaboration
11320 NTS_Map
.Put
(Node_To_Scenario_Map
, N
, S_Id
);
11323 pragma Assert
(Present
(S_Id
));
11326 end Scenario_Representation_Of
;
11328 --------------------------------
11329 -- Set_Activated_Task_Objects --
11330 --------------------------------
11332 procedure Set_Activated_Task_Objects
11333 (S_Id
: Scenario_Rep_Id
;
11334 Task_Objs
: NE_List
.Doubly_Linked_List
)
11336 pragma Assert
(Present
(S_Id
));
11337 pragma Assert
(Kind
(S_Id
) = Task_Activation_Scenario
);
11340 Scenario_Reps
.Table
(S_Id
).List_1
:= Task_Objs
;
11341 end Set_Activated_Task_Objects
;
11343 -----------------------------
11344 -- Set_Activated_Task_Type --
11345 -----------------------------
11347 procedure Set_Activated_Task_Type
11348 (S_Id
: Scenario_Rep_Id
;
11349 Task_Typ
: Entity_Id
)
11351 pragma Assert
(Present
(S_Id
));
11352 pragma Assert
(Kind
(S_Id
) = Task_Activation_Scenario
);
11355 Scenario_Reps
.Table
(S_Id
).Field_1
:= Task_Typ
;
11356 end Set_Activated_Task_Type
;
11358 -------------------
11359 -- SPARK_Mode_Of --
11360 -------------------
11362 function SPARK_Mode_Of
11363 (S_Id
: Scenario_Rep_Id
) return Extended_SPARK_Mode
11365 pragma Assert
(Present
(S_Id
));
11367 return Scenario_Reps
.Table
(S_Id
).SM
;
11370 -------------------
11371 -- SPARK_Mode_Of --
11372 -------------------
11374 function SPARK_Mode_Of
11375 (T_Id
: Target_Rep_Id
) return Extended_SPARK_Mode
11377 pragma Assert
(Present
(T_Id
));
11379 return Target_Reps
.Table
(T_Id
).SM
;
11382 --------------------------
11383 -- SPARK_Mode_Of_Entity --
11384 --------------------------
11386 function SPARK_Mode_Of_Entity
11387 (Id
: Entity_Id
) return Extended_SPARK_Mode
11389 Prag
: constant Node_Id
:= SPARK_Pragma
(Id
);
11395 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
);
11396 end SPARK_Mode_Of_Entity
;
11398 ------------------------
11399 -- SPARK_Mode_Of_Node --
11400 ------------------------
11402 function SPARK_Mode_Of_Node
(N
: Node_Id
) return Extended_SPARK_Mode
is
11404 return To_SPARK_Mode
(Is_SPARK_Mode_On_Node
(N
));
11405 end SPARK_Mode_Of_Node
;
11407 ----------------------
11408 -- Spec_Declaration --
11409 ----------------------
11411 function Spec_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
is
11412 pragma Assert
(Present
(T_Id
));
11414 return Target_Reps
.Table
(T_Id
).Spec_Decl
;
11415 end Spec_Declaration
;
11421 function Target
(S_Id
: Scenario_Rep_Id
) return Entity_Id
is
11422 pragma Assert
(Present
(S_Id
));
11424 return Scenario_Reps
.Table
(S_Id
).Target
;
11427 ------------------------------
11428 -- Target_Representation_Of --
11429 ------------------------------
11431 function Target_Representation_Of
11433 In_State
: Processing_In_State
) return Target_Rep_Id
11435 T_Id
: Target_Rep_Id
;
11438 T_Id
:= ETT_Map
.Get
(Entity_To_Target_Map
, Id
);
11440 -- The elaboration target lacks an internal representation. This
11441 -- indicates that the target is encountered for the first time.
11442 -- Create the internal representation of it.
11444 if not Present
(T_Id
) then
11445 Target_Reps
.Append
(Create_Target_Rep
(Id
, In_State
));
11446 T_Id
:= Target_Reps
.Last
;
11448 -- Associate the internal representation with the elaboration
11451 ETT_Map
.Put
(Entity_To_Target_Map
, Id
, T_Id
);
11453 -- The Processing phase is working with a partially analyzed tree,
11454 -- where various attributes become available as analysis continues.
11455 -- This case arrises in the context of guaranteed ABE processing.
11456 -- Update the existing representation by including new attributes.
11458 elsif In_State
.Representation
= Inconsistent_Representation
then
11459 Target_Reps
.Table
(T_Id
) := Create_Target_Rep
(Id
, In_State
);
11461 -- Otherwise the Processing phase imposes a particular representation
11462 -- version which is not satisfied by the target. This case arrises
11463 -- when the Processing phase switches from guaranteed ABE checks and
11464 -- diagnostics to some other mode of operation. Update the existing
11465 -- representation to include all attributes.
11467 elsif In_State
.Representation
/= Version
(T_Id
) then
11468 Target_Reps
.Table
(T_Id
) := Create_Target_Rep
(Id
, In_State
);
11471 pragma Assert
(Present
(T_Id
));
11474 end Target_Representation_Of
;
11476 -------------------
11477 -- To_Ghost_Mode --
11478 -------------------
11480 function To_Ghost_Mode
11481 (Ignored_Status
: Boolean) return Extended_Ghost_Mode
11484 if Ignored_Status
then
11487 return Is_Checked_Or_Not_Specified
;
11491 -------------------
11492 -- To_SPARK_Mode --
11493 -------------------
11495 function To_SPARK_Mode
11496 (On_Status
: Boolean) return Extended_SPARK_Mode
11502 return Is_Off_Or_Not_Specified
;
11510 function Unit
(T_Id
: Target_Rep_Id
) return Entity_Id
is
11511 pragma Assert
(Present
(T_Id
));
11513 return Target_Reps
.Table
(T_Id
).Unit
;
11516 --------------------------
11517 -- Variable_Declaration --
11518 --------------------------
11520 function Variable_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
is
11521 pragma Assert
(Present
(T_Id
));
11522 pragma Assert
(Kind
(T_Id
) = Variable_Target
);
11525 return Target_Reps
.Table
(T_Id
).Field_1
;
11526 end Variable_Declaration
;
11532 function Version
(T_Id
: Target_Rep_Id
) return Representation_Kind
is
11533 pragma Assert
(Present
(T_Id
));
11535 return Target_Reps
.Table
(T_Id
).Version
;
11537 end Internal_Representation
;
11539 ----------------------
11540 -- Invocation_Graph --
11541 ----------------------
11543 package body Invocation_Graph
is
11549 -- The following type represents simplified version of an invocation
11552 type Invoker_Target_Relation
is record
11553 Invoker
: Entity_Id
:= Empty
;
11554 Target
: Entity_Id
:= Empty
;
11557 -- The following variables define the entities of the dummy elaboration
11558 -- procedures used as origins of library level paths.
11560 Elab_Body_Id
: Entity_Id
:= Empty
;
11561 Elab_Spec_Id
: Entity_Id
:= Empty
;
11563 ---------------------
11564 -- Data structures --
11565 ---------------------
11567 -- The following set contains all declared invocation constructs. It
11568 -- ensures that the same construct is not declared multiple times in
11569 -- the ALI file of the main unit.
11571 Saved_Constructs_Set
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
11573 function Hash
(Key
: Invoker_Target_Relation
) return Bucket_Range_Type
;
11574 -- Obtain the hash value of pair Key
11576 package IR_Set
is new Membership_Sets
11577 (Element_Type
=> Invoker_Target_Relation
,
11581 -- The following set contains all recorded simple invocation relations.
11582 -- It ensures that multiple relations involving the same invoker and
11583 -- target do not appear in the ALI file of the main unit.
11585 Saved_Relations_Set
: IR_Set
.Membership_Set
:= IR_Set
.Nil
;
11591 function Signature_Of
(Id
: Entity_Id
) return Invocation_Signature_Id
;
11592 pragma Inline
(Signature_Of
);
11593 -- Obtain the invication signature id of arbitrary entity Id
11595 -----------------------
11596 -- Local subprograms --
11597 -----------------------
11599 procedure Build_Elaborate_Body_Procedure
;
11600 pragma Inline
(Build_Elaborate_Body_Procedure
);
11601 -- Create a dummy elaborate body procedure and store its entity in
11604 procedure Build_Elaborate_Procedure
11605 (Proc_Id
: out Entity_Id
;
11606 Proc_Nam
: Name_Id
;
11608 pragma Inline
(Build_Elaborate_Procedure
);
11609 -- Create a dummy elaborate procedure with name Proc_Nam and source
11610 -- location Loc. The entity is returned in Proc_Id.
11612 procedure Build_Elaborate_Spec_Procedure
;
11613 pragma Inline
(Build_Elaborate_Spec_Procedure
);
11614 -- Create a dummy elaborate spec procedure and store its entity in
11617 function Build_Subprogram_Invocation
11618 (Subp_Id
: Entity_Id
) return Node_Id
;
11619 pragma Inline
(Build_Subprogram_Invocation
);
11620 -- Create a dummy call marker that invokes subprogram Subp_Id
11622 function Build_Task_Activation
11623 (Task_Typ
: Entity_Id
;
11624 In_State
: Processing_In_State
) return Node_Id
;
11625 pragma Inline
(Build_Task_Activation
);
11626 -- Create a dummy call marker that activates an anonymous task object of
11629 procedure Declare_Invocation_Construct
11630 (Constr_Id
: Entity_Id
;
11631 In_State
: Processing_In_State
);
11632 pragma Inline
(Declare_Invocation_Construct
);
11633 -- Declare invocation construct Constr_Id by creating a declaration for
11634 -- it in the ALI file of the main unit. In_State is the current state of
11635 -- the Processing phase.
11637 function Invocation_Graph_Recording_OK
return Boolean;
11638 pragma Inline
(Invocation_Graph_Recording_OK
);
11639 -- Determine whether the invocation graph can be recorded
11641 function Is_Invocation_Scenario
(N
: Node_Id
) return Boolean;
11642 pragma Inline
(Is_Invocation_Scenario
);
11643 -- Determine whether node N is a suitable scenario for invocation graph
11644 -- recording purposes.
11646 function Is_Invocation_Target
(Id
: Entity_Id
) return Boolean;
11647 pragma Inline
(Is_Invocation_Target
);
11648 -- Determine whether arbitrary entity Id denotes an invocation target
11650 function Is_Saved_Construct
(Constr
: Entity_Id
) return Boolean;
11651 pragma Inline
(Is_Saved_Construct
);
11652 -- Determine whether invocation construct Constr has already been
11653 -- declared in the ALI file of the main unit.
11655 function Is_Saved_Relation
11656 (Rel
: Invoker_Target_Relation
) return Boolean;
11657 pragma Inline
(Is_Saved_Relation
);
11658 -- Determine whether simple invocation relation Rel has already been
11659 -- recorded in the ALI file of the main unit.
11661 procedure Process_Declarations
11663 In_State
: Processing_In_State
);
11664 pragma Inline
(Process_Declarations
);
11665 -- Process declaration list Decls by processing all invocation scenarios
11668 procedure Process_Freeze_Node
11670 In_State
: Processing_In_State
);
11671 pragma Inline
(Process_Freeze_Node
);
11672 -- Process freeze node Fnode by processing all invocation scenarios in
11673 -- its Actions list.
11675 procedure Process_Invocation_Activation
11677 Call_Rep
: Scenario_Rep_Id
;
11678 Obj_Id
: Entity_Id
;
11679 Obj_Rep
: Target_Rep_Id
;
11680 Task_Typ
: Entity_Id
;
11681 Task_Rep
: Target_Rep_Id
;
11682 In_State
: Processing_In_State
);
11683 pragma Inline
(Process_Invocation_Activation
);
11684 -- Process activation call Call which activates object Obj_Id of task
11685 -- type Task_Typ by processing all invocation scenarios within the task
11686 -- body. Call_Rep is the representation of the call. Obj_Rep denotes the
11687 -- representation of the object. Task_Rep is the representation of the
11688 -- task type. In_State is the current state of the Processing phase.
11690 procedure Process_Invocation_Body_Scenarios
;
11691 pragma Inline
(Process_Invocation_Body_Scenarios
);
11692 -- Process all library level body scenarios
11694 procedure Process_Invocation_Call
11696 Call_Rep
: Scenario_Rep_Id
;
11697 In_State
: Processing_In_State
);
11698 pragma Inline
(Process_Invocation_Call
);
11699 -- Process invocation call scenario Call with representation Call_Rep.
11700 -- In_State is the current state of the Processing phase.
11702 procedure Process_Invocation_Instantiation
11704 Inst_Rep
: Scenario_Rep_Id
;
11705 In_State
: Processing_In_State
);
11706 pragma Inline
(Process_Invocation_Instantiation
);
11707 -- Process invocation instantiation scenario Inst with representation
11708 -- Inst_Rep. In_State is the current state of the Processing phase.
11710 procedure Process_Invocation_Scenario
11712 In_State
: Processing_In_State
);
11713 pragma Inline
(Process_Invocation_Scenario
);
11714 -- Process single invocation scenario N. In_State is the current state
11715 -- of the Processing phase.
11717 procedure Process_Invocation_Scenarios
11718 (Iter
: in out NE_Set
.Iterator
;
11719 In_State
: Processing_In_State
);
11720 pragma Inline
(Process_Invocation_Scenarios
);
11721 -- Process all invocation scenarios obtained via iterator Iter. In_State
11722 -- is the current state of the Processing phase.
11724 procedure Process_Invocation_Spec_Scenarios
;
11725 pragma Inline
(Process_Invocation_Spec_Scenarios
);
11726 -- Process all library level spec scenarios
11728 procedure Process_Main_Unit
;
11729 pragma Inline
(Process_Main_Unit
);
11730 -- Process all invocation scenarios within the main unit
11732 procedure Process_Package_Declaration
11733 (Pack_Decl
: Node_Id
;
11734 In_State
: Processing_In_State
);
11735 pragma Inline
(Process_Package_Declaration
);
11736 -- Process package declaration Pack_Decl by processing all invocation
11737 -- scenarios in its visible and private declarations. If the main unit
11738 -- contains a generic, the declarations of the body are also examined.
11739 -- In_State is the current state of the Processing phase.
11741 procedure Process_Protected_Type_Declaration
11742 (Prot_Decl
: Node_Id
;
11743 In_State
: Processing_In_State
);
11744 pragma Inline
(Process_Protected_Type_Declaration
);
11745 -- Process the declarations of protected type Prot_Decl. In_State is the
11746 -- current state of the Processing phase.
11748 procedure Process_Subprogram_Declaration
11749 (Subp_Decl
: Node_Id
;
11750 In_State
: Processing_In_State
);
11751 pragma Inline
(Process_Subprogram_Declaration
);
11752 -- Process subprogram declaration Subp_Decl by processing all invocation
11753 -- scenarios within its body. In_State denotes the current state of the
11754 -- Processing phase.
11756 procedure Process_Subprogram_Instantiation
11758 In_State
: Processing_In_State
);
11759 pragma Inline
(Process_Subprogram_Instantiation
);
11760 -- Process subprogram instantiation Inst. In_State is the current state
11761 -- of the Processing phase.
11763 procedure Process_Task_Type_Declaration
11764 (Task_Decl
: Node_Id
;
11765 In_State
: Processing_In_State
);
11766 pragma Inline
(Process_Task_Type_Declaration
);
11767 -- Process task declaration Task_Decl by processing all invocation
11768 -- scenarios within its body. In_State is the current state of the
11769 -- Processing phase.
11771 procedure Record_Full_Invocation_Path
(In_State
: Processing_In_State
);
11772 pragma Inline
(Record_Full_Invocation_Path
);
11773 -- Record all relations between scenario pairs found in the stack of
11774 -- active scenarios. In_State is the current state of the Processing
11777 procedure Record_Invocation_Graph_Encoding
;
11778 pragma Inline
(Record_Invocation_Graph_Encoding
);
11779 -- Record the encoding format used to capture information related to
11780 -- invocation constructs and relations.
11782 procedure Record_Invocation_Path
(In_State
: Processing_In_State
);
11783 pragma Inline
(Record_Invocation_Path
);
11784 -- Record the invocation relations found within the path represented in
11785 -- the active scenario stack. In_State denotes the current state of the
11786 -- Processing phase.
11788 procedure Record_Simple_Invocation_Path
(In_State
: Processing_In_State
);
11789 pragma Inline
(Record_Simple_Invocation_Path
);
11790 -- Record a single relation from the start to the end of the stack of
11791 -- active scenarios. In_State is the current state of the Processing
11794 procedure Record_Invocation_Relation
11795 (Invk_Id
: Entity_Id
;
11796 Targ_Id
: Entity_Id
;
11797 In_State
: Processing_In_State
);
11798 pragma Inline
(Record_Invocation_Relation
);
11799 -- Record an invocation relation with invoker Invk_Id and target Targ_Id
11800 -- by creating an entry for it in the ALI file of the main unit. Formal
11801 -- In_State denotes the current state of the Processing phase.
11803 procedure Set_Is_Saved_Construct
(Constr
: Entity_Id
);
11804 pragma Inline
(Set_Is_Saved_Construct
);
11805 -- Mark invocation construct Constr as declared in the ALI file of the
11808 procedure Set_Is_Saved_Relation
(Rel
: Invoker_Target_Relation
);
11809 pragma Inline
(Set_Is_Saved_Relation
);
11810 -- Mark simple invocation relation Rel as recorded in the ALI file of
11814 (Pos
: Active_Scenario_Pos
;
11815 In_State
: Processing_In_State
) return Entity_Id
;
11816 pragma Inline
(Target_Of
);
11817 -- Given position within the active scenario stack Pos, obtain the
11818 -- target of the indicated scenario. In_State is the current state
11819 -- of the Processing phase.
11821 procedure Traverse_Invocation_Body
11823 In_State
: Processing_In_State
);
11824 pragma Inline
(Traverse_Invocation_Body
);
11825 -- Traverse subprogram body N looking for suitable invocation scenarios
11826 -- that need to be processed for invocation graph recording purposes.
11827 -- In_State is the current state of the Processing phase.
11829 procedure Write_Invocation_Path
(In_State
: Processing_In_State
);
11830 pragma Inline
(Write_Invocation_Path
);
11831 -- Write out a path represented by the active scenario on the stack to
11832 -- standard output. In_State denotes the current state of the Processing
11835 ------------------------------------
11836 -- Build_Elaborate_Body_Procedure --
11837 ------------------------------------
11839 procedure Build_Elaborate_Body_Procedure
is
11840 Body_Decl
: Node_Id
;
11841 Spec_Decl
: Node_Id
;
11844 -- Nothing to do when a previous call already created the procedure
11846 if Present
(Elab_Body_Id
) then
11850 Spec_And_Body_From_Entity
11851 (Id
=> Main_Unit_Entity
,
11852 Body_Decl
=> Body_Decl
,
11853 Spec_Decl
=> Spec_Decl
);
11855 pragma Assert
(Present
(Body_Decl
));
11857 Build_Elaborate_Procedure
11858 (Proc_Id
=> Elab_Body_Id
,
11859 Proc_Nam
=> Name_B
,
11860 Loc
=> Sloc
(Body_Decl
));
11861 end Build_Elaborate_Body_Procedure
;
11863 -------------------------------
11864 -- Build_Elaborate_Procedure --
11865 -------------------------------
11867 procedure Build_Elaborate_Procedure
11868 (Proc_Id
: out Entity_Id
;
11869 Proc_Nam
: Name_Id
;
11872 Proc_Decl
: Node_Id
;
11873 pragma Unreferenced
(Proc_Decl
);
11876 Proc_Id
:= Make_Defining_Identifier
(Loc
, Proc_Nam
);
11878 -- Partially decorate the elaboration procedure because it will not
11879 -- be insertred into the tree and analyzed.
11881 Mutate_Ekind
(Proc_Id
, E_Procedure
);
11882 Set_Etype
(Proc_Id
, Standard_Void_Type
);
11883 Set_Scope
(Proc_Id
, Unique_Entity
(Main_Unit_Entity
));
11885 -- Create a dummy declaration for the elaboration procedure. The
11886 -- declaration does not need to be syntactically legal, but must
11887 -- carry an accurate source location.
11890 Make_Subprogram_Body
(Loc
,
11892 Make_Procedure_Specification
(Loc
,
11893 Defining_Unit_Name
=> Proc_Id
),
11894 Declarations
=> No_List
,
11895 Handled_Statement_Sequence
=> Empty
);
11896 end Build_Elaborate_Procedure
;
11898 ------------------------------------
11899 -- Build_Elaborate_Spec_Procedure --
11900 ------------------------------------
11902 procedure Build_Elaborate_Spec_Procedure
is
11903 Body_Decl
: Node_Id
;
11904 Spec_Decl
: Node_Id
;
11907 -- Nothing to do when a previous call already created the procedure
11909 if Present
(Elab_Spec_Id
) then
11913 Spec_And_Body_From_Entity
11914 (Id
=> Main_Unit_Entity
,
11915 Body_Decl
=> Body_Decl
,
11916 Spec_Decl
=> Spec_Decl
);
11918 pragma Assert
(Present
(Spec_Decl
));
11920 Build_Elaborate_Procedure
11921 (Proc_Id
=> Elab_Spec_Id
,
11922 Proc_Nam
=> Name_S
,
11923 Loc
=> Sloc
(Spec_Decl
));
11924 end Build_Elaborate_Spec_Procedure
;
11926 ---------------------------------
11927 -- Build_Subprogram_Invocation --
11928 ---------------------------------
11930 function Build_Subprogram_Invocation
11931 (Subp_Id
: Entity_Id
) return Node_Id
11933 Marker
: constant Node_Id
:= Make_Call_Marker
(Sloc
(Subp_Id
));
11934 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
11937 -- Create a dummy call marker which invokes the subprogram
11939 Set_Is_Declaration_Level_Node
(Marker
, False);
11940 Set_Is_Dispatching_Call
(Marker
, False);
11941 Set_Is_Elaboration_Checks_OK_Node
(Marker
, False);
11942 Set_Is_Elaboration_Warnings_OK_Node
(Marker
, False);
11943 Set_Is_Ignored_Ghost_Node
(Marker
, False);
11944 Set_Is_Preelaborable_Call
(Marker
, False);
11945 Set_Is_Source_Call
(Marker
, False);
11946 Set_Is_SPARK_Mode_On_Node
(Marker
, False);
11948 -- Invoke the uniform canonical entity of the subprogram
11950 Set_Target
(Marker
, Canonical_Subprogram
(Subp_Id
));
11952 -- Partially insert the marker into the tree
11954 Set_Parent
(Marker
, Parent
(Subp_Decl
));
11957 end Build_Subprogram_Invocation
;
11959 ---------------------------
11960 -- Build_Task_Activation --
11961 ---------------------------
11963 function Build_Task_Activation
11964 (Task_Typ
: Entity_Id
;
11965 In_State
: Processing_In_State
) return Node_Id
11967 Loc
: constant Source_Ptr
:= Sloc
(Task_Typ
);
11968 Marker
: constant Node_Id
:= Make_Call_Marker
(Loc
);
11969 Task_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Task_Typ
);
11971 Activ_Id
: Entity_Id
;
11972 Marker_Rep_Id
: Scenario_Rep_Id
;
11973 Task_Obj
: Entity_Id
;
11974 Task_Objs
: NE_List
.Doubly_Linked_List
;
11977 -- Create a dummy call marker which activates some tasks
11979 Set_Is_Declaration_Level_Node
(Marker
, False);
11980 Set_Is_Dispatching_Call
(Marker
, False);
11981 Set_Is_Elaboration_Checks_OK_Node
(Marker
, False);
11982 Set_Is_Elaboration_Warnings_OK_Node
(Marker
, False);
11983 Set_Is_Ignored_Ghost_Node
(Marker
, False);
11984 Set_Is_Preelaborable_Call
(Marker
, False);
11985 Set_Is_Source_Call
(Marker
, False);
11986 Set_Is_SPARK_Mode_On_Node
(Marker
, False);
11988 -- Invoke the appropriate version of Activate_Tasks
11990 if Restricted_Profile
then
11991 Activ_Id
:= RTE
(RE_Activate_Restricted_Tasks
);
11993 Activ_Id
:= RTE
(RE_Activate_Tasks
);
11996 Set_Target
(Marker
, Activ_Id
);
11998 -- Partially insert the marker into the tree
12000 Set_Parent
(Marker
, Parent
(Task_Decl
));
12002 -- Create a dummy task object. Partially decorate the object because
12003 -- it will not be inserted into the tree and analyzed.
12005 Task_Obj
:= Make_Temporary
(Loc
, 'T');
12006 Mutate_Ekind
(Task_Obj
, E_Variable
);
12007 Set_Etype
(Task_Obj
, Task_Typ
);
12009 -- Associate the dummy task object with the activation call
12011 Task_Objs
:= NE_List
.Create
;
12012 NE_List
.Append
(Task_Objs
, Task_Obj
);
12014 Marker_Rep_Id
:= Scenario_Representation_Of
(Marker
, In_State
);
12015 Set_Activated_Task_Objects
(Marker_Rep_Id
, Task_Objs
);
12016 Set_Activated_Task_Type
(Marker_Rep_Id
, Task_Typ
);
12019 end Build_Task_Activation
;
12021 ----------------------------------
12022 -- Declare_Invocation_Construct --
12023 ----------------------------------
12025 procedure Declare_Invocation_Construct
12026 (Constr_Id
: Entity_Id
;
12027 In_State
: Processing_In_State
)
12029 function Body_Placement_Of
12030 (Id
: Entity_Id
) return Declaration_Placement_Kind
;
12031 pragma Inline
(Body_Placement_Of
);
12032 -- Obtain the placement of arbitrary entity Id's body
12034 function Declaration_Placement_Of_Node
12035 (N
: Node_Id
) return Declaration_Placement_Kind
;
12036 pragma Inline
(Declaration_Placement_Of_Node
);
12037 -- Obtain the placement of arbitrary node N
12039 function Kind_Of
(Id
: Entity_Id
) return Invocation_Construct_Kind
;
12040 pragma Inline
(Kind_Of
);
12041 -- Obtain the invocation construct kind of arbitrary entity Id
12043 function Spec_Placement_Of
12044 (Id
: Entity_Id
) return Declaration_Placement_Kind
;
12045 pragma Inline
(Spec_Placement_Of
);
12046 -- Obtain the placement of arbitrary entity Id's spec
12048 -----------------------
12049 -- Body_Placement_Of --
12050 -----------------------
12052 function Body_Placement_Of
12053 (Id
: Entity_Id
) return Declaration_Placement_Kind
12055 Id_Rep
: constant Target_Rep_Id
:=
12056 Target_Representation_Of
(Id
, In_State
);
12057 Body_Decl
: constant Node_Id
:= Body_Declaration
(Id_Rep
);
12058 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Id_Rep
);
12061 -- The entity has a body
12063 if Present
(Body_Decl
) then
12064 return Declaration_Placement_Of_Node
(Body_Decl
);
12066 -- Otherwise the entity must have a spec
12069 pragma Assert
(Present
(Spec_Decl
));
12070 return Declaration_Placement_Of_Node
(Spec_Decl
);
12072 end Body_Placement_Of
;
12074 -----------------------------------
12075 -- Declaration_Placement_Of_Node --
12076 -----------------------------------
12078 function Declaration_Placement_Of_Node
12079 (N
: Node_Id
) return Declaration_Placement_Kind
12081 Main_Unit_Id
: constant Entity_Id
:= Main_Unit_Entity
;
12082 N_Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(N
);
12085 -- The node is in the main unit, its placement depends on the main
12088 if N_Unit_Id
= Main_Unit_Id
then
12090 -- The main unit is a body
12092 if Ekind
(Main_Unit_Id
) in E_Package_Body | E_Subprogram_Body
12096 -- The main unit is a stand-alone subprogram body
12098 elsif Ekind
(Main_Unit_Id
) in E_Function | E_Procedure
12099 and then Nkind
(Unit_Declaration_Node
(Main_Unit_Id
)) =
12104 -- Otherwise the main unit is a spec
12110 -- Otherwise the node is in the complementary unit of the main
12111 -- unit. The main unit is a body, the node is in the spec.
12113 elsif Ekind
(Main_Unit_Id
) in E_Package_Body | E_Subprogram_Body
12117 -- The main unit is a spec, the node is in the body
12122 end Declaration_Placement_Of_Node
;
12128 function Kind_Of
(Id
: Entity_Id
) return Invocation_Construct_Kind
is
12130 if Id
= Elab_Body_Id
then
12131 return Elaborate_Body_Procedure
;
12133 elsif Id
= Elab_Spec_Id
then
12134 return Elaborate_Spec_Procedure
;
12137 return Regular_Construct
;
12141 -----------------------
12142 -- Spec_Placement_Of --
12143 -----------------------
12145 function Spec_Placement_Of
12146 (Id
: Entity_Id
) return Declaration_Placement_Kind
12148 Id_Rep
: constant Target_Rep_Id
:=
12149 Target_Representation_Of
(Id
, In_State
);
12150 Body_Decl
: constant Node_Id
:= Body_Declaration
(Id_Rep
);
12151 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Id_Rep
);
12154 -- The entity has a spec
12156 if Present
(Spec_Decl
) then
12157 return Declaration_Placement_Of_Node
(Spec_Decl
);
12159 -- Otherwise the entity must have a body
12162 pragma Assert
(Present
(Body_Decl
));
12163 return Declaration_Placement_Of_Node
(Body_Decl
);
12165 end Spec_Placement_Of
;
12167 -- Start of processing for Declare_Invocation_Construct
12170 -- Nothing to do when the construct has already been declared in the
12173 if Is_Saved_Construct
(Constr_Id
) then
12177 -- Mark the construct as declared in the ALI file
12179 Set_Is_Saved_Construct
(Constr_Id
);
12181 -- Add the construct in the ALI file
12183 Add_Invocation_Construct
12184 (Body_Placement
=> Body_Placement_Of
(Constr_Id
),
12185 Kind
=> Kind_Of
(Constr_Id
),
12186 Signature
=> Signature_Of
(Constr_Id
),
12187 Spec_Placement
=> Spec_Placement_Of
(Constr_Id
),
12188 Update_Units
=> False);
12189 end Declare_Invocation_Construct
;
12191 -------------------------------
12192 -- Finalize_Invocation_Graph --
12193 -------------------------------
12195 procedure Finalize_Invocation_Graph
is
12197 NE_Set
.Destroy
(Saved_Constructs_Set
);
12198 IR_Set
.Destroy
(Saved_Relations_Set
);
12199 end Finalize_Invocation_Graph
;
12205 function Hash
(Key
: Invoker_Target_Relation
) return Bucket_Range_Type
is
12206 pragma Assert
(Present
(Key
.Invoker
));
12207 pragma Assert
(Present
(Key
.Target
));
12212 (Bucket_Range_Type
(Key
.Invoker
),
12213 Bucket_Range_Type
(Key
.Target
));
12216 ---------------------------------
12217 -- Initialize_Invocation_Graph --
12218 ---------------------------------
12220 procedure Initialize_Invocation_Graph
is
12222 Saved_Constructs_Set
:= NE_Set
.Create
(100);
12223 Saved_Relations_Set
:= IR_Set
.Create
(200);
12224 end Initialize_Invocation_Graph
;
12226 -----------------------------------
12227 -- Invocation_Graph_Recording_OK --
12228 -----------------------------------
12230 function Invocation_Graph_Recording_OK
return Boolean is
12231 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
12234 -- Nothing to do when compiling for GNATprove because the invocation
12235 -- graph is not needed.
12237 if GNATprove_Mode
then
12240 -- Nothing to do when the compilation will not produce an ALI file
12242 elsif Serious_Errors_Detected
> 0 then
12245 -- Nothing to do when the main unit requires a body. Processing the
12246 -- completing body will create the ALI file for the unit and record
12247 -- the invocation graph.
12249 elsif Body_Required
(Main_Cunit
) then
12254 end Invocation_Graph_Recording_OK
;
12256 ----------------------------
12257 -- Is_Invocation_Scenario --
12258 ----------------------------
12260 function Is_Invocation_Scenario
(N
: Node_Id
) return Boolean is
12263 Is_Suitable_Access_Taken
(N
)
12264 or else Is_Suitable_Call
(N
)
12265 or else Is_Suitable_Instantiation
(N
);
12266 end Is_Invocation_Scenario
;
12268 --------------------------
12269 -- Is_Invocation_Target --
12270 --------------------------
12272 function Is_Invocation_Target
(Id
: Entity_Id
) return Boolean is
12274 -- To qualify, the entity must either come from source, or denote an
12275 -- Ada, bridge, or SPARK target.
12278 Comes_From_Source
(Id
)
12279 or else Is_Ada_Semantic_Target
(Id
)
12280 or else Is_Bridge_Target
(Id
)
12281 or else Is_SPARK_Semantic_Target
(Id
);
12282 end Is_Invocation_Target
;
12284 ------------------------
12285 -- Is_Saved_Construct --
12286 ------------------------
12288 function Is_Saved_Construct
(Constr
: Entity_Id
) return Boolean is
12289 pragma Assert
(Present
(Constr
));
12291 return NE_Set
.Contains
(Saved_Constructs_Set
, Constr
);
12292 end Is_Saved_Construct
;
12294 -----------------------
12295 -- Is_Saved_Relation --
12296 -----------------------
12298 function Is_Saved_Relation
12299 (Rel
: Invoker_Target_Relation
) return Boolean
12301 pragma Assert
(Present
(Rel
.Invoker
));
12302 pragma Assert
(Present
(Rel
.Target
));
12305 return IR_Set
.Contains
(Saved_Relations_Set
, Rel
);
12306 end Is_Saved_Relation
;
12308 --------------------------
12309 -- Process_Declarations --
12310 --------------------------
12312 procedure Process_Declarations
12314 In_State
: Processing_In_State
)
12319 Decl
:= First
(Decls
);
12320 while Present
(Decl
) loop
12324 if Nkind
(Decl
) = N_Freeze_Entity
then
12325 Process_Freeze_Node
12327 In_State
=> In_State
);
12329 -- Package (nested)
12331 elsif Nkind
(Decl
) = N_Package_Declaration
then
12332 Process_Package_Declaration
12333 (Pack_Decl
=> Decl
,
12334 In_State
=> In_State
);
12338 elsif Nkind
(Decl
) in N_Protected_Type_Declaration
12339 | N_Single_Protected_Declaration
12341 Process_Protected_Type_Declaration
12342 (Prot_Decl
=> Decl
,
12343 In_State
=> In_State
);
12345 -- Subprogram or entry
12347 elsif Nkind
(Decl
) in N_Entry_Declaration
12348 | N_Subprogram_Declaration
12350 Process_Subprogram_Declaration
12351 (Subp_Decl
=> Decl
,
12352 In_State
=> In_State
);
12354 -- Subprogram body (stand alone)
12356 elsif Nkind
(Decl
) = N_Subprogram_Body
12357 and then No
(Corresponding_Spec
(Decl
))
12359 Process_Subprogram_Declaration
12360 (Subp_Decl
=> Decl
,
12361 In_State
=> In_State
);
12363 -- Subprogram instantiation
12365 elsif Nkind
(Decl
) in N_Subprogram_Instantiation
then
12366 Process_Subprogram_Instantiation
12368 In_State
=> In_State
);
12372 elsif Nkind
(Decl
) in N_Single_Task_Declaration
12373 | N_Task_Type_Declaration
12375 Process_Task_Type_Declaration
12376 (Task_Decl
=> Decl
,
12377 In_State
=> In_State
);
12379 -- Task type (derived)
12381 elsif Nkind
(Decl
) = N_Full_Type_Declaration
12382 and then Is_Task_Type
(Defining_Entity
(Decl
))
12384 Process_Task_Type_Declaration
12385 (Task_Decl
=> Decl
,
12386 In_State
=> In_State
);
12391 end Process_Declarations
;
12393 -------------------------
12394 -- Process_Freeze_Node --
12395 -------------------------
12397 procedure Process_Freeze_Node
12399 In_State
: Processing_In_State
)
12402 Process_Declarations
12403 (Decls
=> Actions
(Fnode
),
12404 In_State
=> In_State
);
12405 end Process_Freeze_Node
;
12407 -----------------------------------
12408 -- Process_Invocation_Activation --
12409 -----------------------------------
12411 procedure Process_Invocation_Activation
12413 Call_Rep
: Scenario_Rep_Id
;
12414 Obj_Id
: Entity_Id
;
12415 Obj_Rep
: Target_Rep_Id
;
12416 Task_Typ
: Entity_Id
;
12417 Task_Rep
: Target_Rep_Id
;
12418 In_State
: Processing_In_State
)
12420 pragma Unreferenced
(Call
);
12421 pragma Unreferenced
(Call_Rep
);
12422 pragma Unreferenced
(Obj_Id
);
12423 pragma Unreferenced
(Obj_Rep
);
12426 -- Nothing to do when the task type appears within an internal unit
12428 if In_Internal_Unit
(Task_Typ
) then
12432 -- The task type being activated is within the main unit. Extend the
12433 -- DFS traversal into its body.
12435 if In_Extended_Main_Code_Unit
(Task_Typ
) then
12436 Traverse_Invocation_Body
12437 (N
=> Body_Declaration
(Task_Rep
),
12438 In_State
=> In_State
);
12440 -- The task type being activated resides within an external unit
12442 -- Main unit External unit
12443 -- +-----------+ +-------------+
12445 -- | Start ------------> Task_Typ |
12447 -- +-----------+ +-------------+
12449 -- Record the invocation path which originates from Start and reaches
12453 Record_Invocation_Path
(In_State
);
12455 end Process_Invocation_Activation
;
12457 ---------------------------------------
12458 -- Process_Invocation_Body_Scenarios --
12459 ---------------------------------------
12461 procedure Process_Invocation_Body_Scenarios
is
12462 Iter
: NE_Set
.Iterator
:= Iterate_Library_Body_Scenarios
;
12464 Process_Invocation_Scenarios
12466 In_State
=> Invocation_Body_State
);
12467 end Process_Invocation_Body_Scenarios
;
12469 -----------------------------
12470 -- Process_Invocation_Call --
12471 -----------------------------
12473 procedure Process_Invocation_Call
12475 Call_Rep
: Scenario_Rep_Id
;
12476 In_State
: Processing_In_State
)
12478 pragma Unreferenced
(Call
);
12480 Subp_Id
: constant Entity_Id
:= Target
(Call_Rep
);
12481 Subp_Rep
: constant Target_Rep_Id
:=
12482 Target_Representation_Of
(Subp_Id
, In_State
);
12485 -- Nothing to do when the subprogram appears within an internal unit
12487 if In_Internal_Unit
(Subp_Id
) then
12490 -- Nothing to do for an abstract subprogram because it has no body to
12493 elsif Ekind
(Subp_Id
) in E_Function | E_Procedure
12494 and then Is_Abstract_Subprogram
(Subp_Id
)
12498 -- Nothin to do for a formal subprogram because it has no body to
12501 elsif Is_Formal_Subprogram
(Subp_Id
) then
12505 -- The subprogram being called is within the main unit. Extend the
12506 -- DFS traversal into its barrier function and body.
12508 if In_Extended_Main_Code_Unit
(Subp_Id
) then
12509 if Ekind
(Subp_Id
) in E_Entry | E_Entry_Family | E_Procedure
then
12510 Traverse_Invocation_Body
12511 (N
=> Barrier_Body_Declaration
(Subp_Rep
),
12512 In_State
=> In_State
);
12515 Traverse_Invocation_Body
12516 (N
=> Body_Declaration
(Subp_Rep
),
12517 In_State
=> In_State
);
12519 -- The subprogram being called resides within an external unit
12521 -- Main unit External unit
12522 -- +-----------+ +-------------+
12524 -- | Start ------------> Subp_Id |
12526 -- +-----------+ +-------------+
12528 -- Record the invocation path which originates from Start and reaches
12532 Record_Invocation_Path
(In_State
);
12534 end Process_Invocation_Call
;
12536 --------------------------------------
12537 -- Process_Invocation_Instantiation --
12538 --------------------------------------
12540 procedure Process_Invocation_Instantiation
12542 Inst_Rep
: Scenario_Rep_Id
;
12543 In_State
: Processing_In_State
)
12545 pragma Unreferenced
(Inst
);
12547 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
12550 -- Nothing to do when the generic appears within an internal unit
12552 if In_Internal_Unit
(Gen_Id
) then
12556 -- The generic being instantiated resides within an external unit
12558 -- Main unit External unit
12559 -- +-----------+ +-------------+
12561 -- | Start ------------> Generic |
12563 -- +-----------+ +-------------+
12565 -- Record the invocation path which originates from Start and reaches
12568 if not In_Extended_Main_Code_Unit
(Gen_Id
) then
12569 Record_Invocation_Path
(In_State
);
12571 end Process_Invocation_Instantiation
;
12573 ---------------------------------
12574 -- Process_Invocation_Scenario --
12575 ---------------------------------
12577 procedure Process_Invocation_Scenario
12579 In_State
: Processing_In_State
)
12581 Scen
: constant Node_Id
:= Scenario
(N
);
12582 Scen_Rep
: Scenario_Rep_Id
;
12585 -- Add the current scenario to the stack of active scenarios
12587 Push_Active_Scenario
(Scen
);
12589 -- Call or task activation
12591 if Is_Suitable_Call
(Scen
) then
12592 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
12594 -- Routine Build_Call_Marker creates call markers regardless of
12595 -- whether the call occurs within the main unit or not. This way
12596 -- the serialization of internal names is kept consistent. Only
12597 -- call markers found within the main unit must be processed.
12599 if In_Main_Context
(Scen
) then
12600 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
12602 if Kind
(Scen_Rep
) = Call_Scenario
then
12603 Process_Invocation_Call
12605 Call_Rep
=> Scen_Rep
,
12606 In_State
=> In_State
);
12609 pragma Assert
(Kind
(Scen_Rep
) = Task_Activation_Scenario
);
12613 Call_Rep
=> Scen_Rep
,
12614 Processor
=> Process_Invocation_Activation
'Access,
12615 In_State
=> In_State
);
12621 elsif Is_Suitable_Instantiation
(Scen
) then
12622 Process_Invocation_Instantiation
12624 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
12625 In_State
=> In_State
);
12628 -- Remove the current scenario from the stack of active scenarios
12629 -- once all invocation constructs and paths have been saved.
12631 Pop_Active_Scenario
(Scen
);
12632 end Process_Invocation_Scenario
;
12634 ----------------------------------
12635 -- Process_Invocation_Scenarios --
12636 ----------------------------------
12638 procedure Process_Invocation_Scenarios
12639 (Iter
: in out NE_Set
.Iterator
;
12640 In_State
: Processing_In_State
)
12645 while NE_Set
.Has_Next
(Iter
) loop
12646 NE_Set
.Next
(Iter
, N
);
12648 -- Reset the traversed status of all subprogram bodies because the
12649 -- current invocation scenario acts as a new DFS traversal root.
12651 Reset_Traversed_Bodies
;
12653 Process_Invocation_Scenario
(N
, In_State
);
12655 end Process_Invocation_Scenarios
;
12657 ---------------------------------------
12658 -- Process_Invocation_Spec_Scenarios --
12659 ---------------------------------------
12661 procedure Process_Invocation_Spec_Scenarios
is
12662 Iter
: NE_Set
.Iterator
:= Iterate_Library_Spec_Scenarios
;
12664 Process_Invocation_Scenarios
12666 In_State
=> Invocation_Spec_State
);
12667 end Process_Invocation_Spec_Scenarios
;
12669 -----------------------
12670 -- Process_Main_Unit --
12671 -----------------------
12673 procedure Process_Main_Unit
is
12674 Unit_Decl
: constant Node_Id
:= Unit
(Cunit
(Main_Unit
));
12675 Spec_Id
: Entity_Id
;
12678 -- The main unit is a [generic] package body
12680 if Nkind
(Unit_Decl
) = N_Package_Body
then
12681 Spec_Id
:= Corresponding_Spec
(Unit_Decl
);
12682 pragma Assert
(Present
(Spec_Id
));
12684 Process_Package_Declaration
12685 (Pack_Decl
=> Unit_Declaration_Node
(Spec_Id
),
12686 In_State
=> Invocation_Construct_State
);
12688 -- The main unit is a [generic] package declaration
12690 elsif Nkind
(Unit_Decl
) = N_Package_Declaration
then
12691 Process_Package_Declaration
12692 (Pack_Decl
=> Unit_Decl
,
12693 In_State
=> Invocation_Construct_State
);
12695 -- The main unit is a [generic] subprogram body
12697 elsif Nkind
(Unit_Decl
) = N_Subprogram_Body
then
12698 Spec_Id
:= Corresponding_Spec
(Unit_Decl
);
12700 -- The body completes a previous declaration
12702 if Present
(Spec_Id
) then
12703 Process_Subprogram_Declaration
12704 (Subp_Decl
=> Unit_Declaration_Node
(Spec_Id
),
12705 In_State
=> Invocation_Construct_State
);
12707 -- Otherwise the body is stand-alone
12710 Process_Subprogram_Declaration
12711 (Subp_Decl
=> Unit_Decl
,
12712 In_State
=> Invocation_Construct_State
);
12715 -- The main unit is a subprogram instantiation
12717 elsif Nkind
(Unit_Decl
) in N_Subprogram_Instantiation
then
12718 Process_Subprogram_Instantiation
12719 (Inst
=> Unit_Decl
,
12720 In_State
=> Invocation_Construct_State
);
12722 -- The main unit is an imported subprogram declaration
12724 elsif Nkind
(Unit_Decl
) = N_Subprogram_Declaration
then
12725 Process_Subprogram_Declaration
12726 (Subp_Decl
=> Unit_Decl
,
12727 In_State
=> Invocation_Construct_State
);
12729 end Process_Main_Unit
;
12731 ---------------------------------
12732 -- Process_Package_Declaration --
12733 ---------------------------------
12735 procedure Process_Package_Declaration
12736 (Pack_Decl
: Node_Id
;
12737 In_State
: Processing_In_State
)
12739 Body_Id
: constant Entity_Id
:= Corresponding_Body
(Pack_Decl
);
12740 Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
12741 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
12744 -- Add a declaration for the generic package in the ALI of the main
12745 -- unit in case a client unit instantiates it.
12747 if Ekind
(Spec_Id
) = E_Generic_Package
then
12748 Declare_Invocation_Construct
12749 (Constr_Id
=> Spec_Id
,
12750 In_State
=> In_State
);
12752 -- Otherwise inspect the visible and private declarations of the
12753 -- package for invocation constructs.
12756 Process_Declarations
12757 (Decls
=> Visible_Declarations
(Spec
),
12758 In_State
=> In_State
);
12760 Process_Declarations
12761 (Decls
=> Private_Declarations
(Spec
),
12762 In_State
=> In_State
);
12764 -- The package body containst at least one generic unit or an
12765 -- inlinable subprogram. Such constructs may grant clients of
12766 -- the main unit access to the private enclosing contexts of
12767 -- the constructs. Process the main unit body to discover and
12768 -- encode relevant invocation constructs and relations that
12769 -- may ultimately reach an external unit.
12771 if Present
(Body_Id
)
12772 and then Save_Invocation_Graph_Of_Body
(Cunit
(Main_Unit
))
12774 Process_Declarations
12775 (Decls
=> Declarations
(Unit_Declaration_Node
(Body_Id
)),
12776 In_State
=> In_State
);
12779 end Process_Package_Declaration
;
12781 ----------------------------------------
12782 -- Process_Protected_Type_Declaration --
12783 ----------------------------------------
12785 procedure Process_Protected_Type_Declaration
12786 (Prot_Decl
: Node_Id
;
12787 In_State
: Processing_In_State
)
12789 Prot_Def
: constant Node_Id
:= Protected_Definition
(Prot_Decl
);
12792 if Present
(Prot_Def
) then
12793 Process_Declarations
12794 (Decls
=> Visible_Declarations
(Prot_Def
),
12795 In_State
=> In_State
);
12797 end Process_Protected_Type_Declaration
;
12799 ------------------------------------
12800 -- Process_Subprogram_Declaration --
12801 ------------------------------------
12803 procedure Process_Subprogram_Declaration
12804 (Subp_Decl
: Node_Id
;
12805 In_State
: Processing_In_State
)
12807 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
12810 -- Nothing to do when the subprogram is not an invocation target
12812 if not Is_Invocation_Target
(Subp_Id
) then
12816 -- Add a declaration for the subprogram in the ALI file of the main
12817 -- unit in case a client unit calls or instantiates it.
12819 Declare_Invocation_Construct
12820 (Constr_Id
=> Subp_Id
,
12821 In_State
=> In_State
);
12823 -- Do not process subprograms without a body because they do not
12824 -- contain any invocation scenarios.
12826 if Is_Bodiless_Subprogram
(Subp_Id
) then
12829 -- Do not process generic subprograms because generics must not be
12832 elsif Is_Generic_Subprogram
(Subp_Id
) then
12835 -- Otherwise create a dummy scenario which calls the subprogram to
12836 -- act as a root for a DFS traversal.
12839 -- Reset the traversed status of all subprogram bodies because the
12840 -- subprogram acts as a new DFS traversal root.
12842 Reset_Traversed_Bodies
;
12844 Process_Invocation_Scenario
12845 (N
=> Build_Subprogram_Invocation
(Subp_Id
),
12846 In_State
=> In_State
);
12848 end Process_Subprogram_Declaration
;
12850 --------------------------------------
12851 -- Process_Subprogram_Instantiation --
12852 --------------------------------------
12854 procedure Process_Subprogram_Instantiation
12856 In_State
: Processing_In_State
)
12859 -- Add a declaration for the instantiation in the ALI file of the
12860 -- main unit in case a client unit calls it.
12862 Declare_Invocation_Construct
12863 (Constr_Id
=> Defining_Entity
(Inst
),
12864 In_State
=> In_State
);
12865 end Process_Subprogram_Instantiation
;
12867 -----------------------------------
12868 -- Process_Task_Type_Declaration --
12869 -----------------------------------
12871 procedure Process_Task_Type_Declaration
12872 (Task_Decl
: Node_Id
;
12873 In_State
: Processing_In_State
)
12875 Task_Typ
: constant Entity_Id
:= Defining_Entity
(Task_Decl
);
12876 Task_Def
: Node_Id
;
12879 -- Add a declaration for the task type the ALI file of the main unit
12880 -- in case a client unit creates a task object and activates it.
12882 Declare_Invocation_Construct
12883 (Constr_Id
=> Task_Typ
,
12884 In_State
=> In_State
);
12886 -- Process the entries of the task type because they represent valid
12887 -- entry points into the task body.
12889 if Nkind
(Task_Decl
) in N_Single_Task_Declaration
12890 | N_Task_Type_Declaration
12892 Task_Def
:= Task_Definition
(Task_Decl
);
12894 if Present
(Task_Def
) then
12895 Process_Declarations
12896 (Decls
=> Visible_Declarations
(Task_Def
),
12897 In_State
=> In_State
);
12901 -- Reset the traversed status of all subprogram bodies because the
12902 -- task type acts as a new DFS traversal root.
12904 Reset_Traversed_Bodies
;
12906 -- Create a dummy scenario which activates an anonymous object of the
12907 -- task type to acts as a root of a DFS traversal.
12909 Process_Invocation_Scenario
12910 (N
=> Build_Task_Activation
(Task_Typ
, In_State
),
12911 In_State
=> In_State
);
12912 end Process_Task_Type_Declaration
;
12914 ---------------------------------
12915 -- Record_Full_Invocation_Path --
12916 ---------------------------------
12918 procedure Record_Full_Invocation_Path
(In_State
: Processing_In_State
) is
12919 package Scenarios
renames Active_Scenario_Stack
;
12922 -- The path originates from the elaboration of the body. Add an extra
12923 -- relation from the elaboration body procedure to the first active
12926 if In_State
.Processing
= Invocation_Body_Processing
then
12927 Build_Elaborate_Body_Procedure
;
12929 Record_Invocation_Relation
12930 (Invk_Id
=> Elab_Body_Id
,
12931 Targ_Id
=> Target_Of
(Scenarios
.First
, In_State
),
12932 In_State
=> In_State
);
12934 -- The path originates from the elaboration of the spec. Add an extra
12935 -- relation from the elaboration spec procedure to the first active
12938 elsif In_State
.Processing
= Invocation_Spec_Processing
then
12939 Build_Elaborate_Spec_Procedure
;
12941 Record_Invocation_Relation
12942 (Invk_Id
=> Elab_Spec_Id
,
12943 Targ_Id
=> Target_Of
(Scenarios
.First
, In_State
),
12944 In_State
=> In_State
);
12947 -- Record individual relations formed by pairs of scenarios
12949 for Index
in Scenarios
.First
.. Scenarios
.Last
- 1 loop
12950 Record_Invocation_Relation
12951 (Invk_Id
=> Target_Of
(Index
, In_State
),
12952 Targ_Id
=> Target_Of
(Index
+ 1, In_State
),
12953 In_State
=> In_State
);
12955 end Record_Full_Invocation_Path
;
12957 -----------------------------
12958 -- Record_Invocation_Graph --
12959 -----------------------------
12961 procedure Record_Invocation_Graph
is
12963 -- Nothing to do when the invocation graph is not recorded
12965 if not Invocation_Graph_Recording_OK
then
12969 -- Save the encoding format used to capture information about the
12970 -- invocation constructs and relations in the ALI file of the main
12973 Record_Invocation_Graph_Encoding
;
12975 -- Examine all library level invocation scenarios and perform DFS
12976 -- traversals from each one. Encode a path in the ALI file of the
12977 -- main unit if it reaches into an external unit.
12979 Process_Invocation_Body_Scenarios
;
12980 Process_Invocation_Spec_Scenarios
;
12982 -- Examine all invocation constructs within the spec and body of the
12983 -- main unit and perform DFS traversals from each one. Encode a path
12984 -- in the ALI file of the main unit if it reaches into an external
12988 end Record_Invocation_Graph
;
12990 --------------------------------------
12991 -- Record_Invocation_Graph_Encoding --
12992 --------------------------------------
12994 procedure Record_Invocation_Graph_Encoding
is
12995 Kind
: Invocation_Graph_Encoding_Kind
:= No_Encoding
;
12998 -- Switch -gnatd_F (encode full invocation paths in ALI files) is in
13001 if Debug_Flag_Underscore_FF
then
13002 Kind
:= Full_Path_Encoding
;
13004 Kind
:= Endpoints_Encoding
;
13007 -- Save the encoding format in the ALI file of the main unit
13009 Set_Invocation_Graph_Encoding
13011 Update_Units
=> False);
13012 end Record_Invocation_Graph_Encoding
;
13014 ----------------------------
13015 -- Record_Invocation_Path --
13016 ----------------------------
13018 procedure Record_Invocation_Path
(In_State
: Processing_In_State
) is
13019 package Scenarios
renames Active_Scenario_Stack
;
13022 -- Save a path when the active scenario stack contains at least one
13023 -- invocation scenario.
13025 if Scenarios
.Last
- Scenarios
.First
< 0 then
13029 -- Register all relations in the path when switch -gnatd_F (encode
13030 -- full invocation paths in ALI files) is in effect.
13032 if Debug_Flag_Underscore_FF
then
13033 Record_Full_Invocation_Path
(In_State
);
13035 -- Otherwise register a single relation
13038 Record_Simple_Invocation_Path
(In_State
);
13041 Write_Invocation_Path
(In_State
);
13042 end Record_Invocation_Path
;
13044 --------------------------------
13045 -- Record_Invocation_Relation --
13046 --------------------------------
13048 procedure Record_Invocation_Relation
13049 (Invk_Id
: Entity_Id
;
13050 Targ_Id
: Entity_Id
;
13051 In_State
: Processing_In_State
)
13053 pragma Assert
(Present
(Invk_Id
));
13054 pragma Assert
(Present
(Targ_Id
));
13056 procedure Get_Invocation_Attributes
13057 (Extra
: out Entity_Id
;
13058 Kind
: out Invocation_Kind
);
13059 pragma Inline
(Get_Invocation_Attributes
);
13060 -- Return the additional entity used in error diagnostics in Extra
13061 -- and the invocation kind in Kind which pertain to the invocation
13062 -- relation with invoker Invk_Id and target Targ_Id.
13064 -------------------------------
13065 -- Get_Invocation_Attributes --
13066 -------------------------------
13068 procedure Get_Invocation_Attributes
13069 (Extra
: out Entity_Id
;
13070 Kind
: out Invocation_Kind
)
13073 -- Accept within a task body
13075 if Is_Accept_Alternative_Proc
(Targ_Id
) then
13076 Extra
:= Receiving_Entry
(Targ_Id
);
13077 Kind
:= Accept_Alternative
;
13079 -- Activation of a task object
13081 elsif Is_Activation_Proc
(Targ_Id
)
13082 or else Is_Task_Type
(Targ_Id
)
13085 Kind
:= Task_Activation
;
13087 -- Controlled adjustment actions
13089 elsif Is_Controlled_Procedure
(Targ_Id
, Name_Adjust
) then
13090 Extra
:= First_Formal_Type
(Targ_Id
);
13091 Kind
:= Controlled_Adjustment
;
13093 -- Controlled finalization actions
13095 elsif Is_Controlled_Procedure
(Targ_Id
, Name_Finalize
)
13096 or else Is_Finalizer
(Targ_Id
)
13098 Extra
:= First_Formal_Type
(Targ_Id
);
13099 Kind
:= Controlled_Finalization
;
13101 -- Controlled initialization actions
13103 elsif Is_Controlled_Procedure
(Targ_Id
, Name_Initialize
) then
13104 Extra
:= First_Formal_Type
(Targ_Id
);
13105 Kind
:= Controlled_Initialization
;
13107 -- Default_Initial_Condition verification
13109 elsif Is_Default_Initial_Condition_Proc
(Targ_Id
) then
13110 Extra
:= First_Formal_Type
(Targ_Id
);
13111 Kind
:= Default_Initial_Condition_Verification
;
13113 -- Initialization of object
13115 elsif Is_Init_Proc
(Targ_Id
) then
13116 Extra
:= First_Formal_Type
(Targ_Id
);
13117 Kind
:= Type_Initialization
;
13119 -- Initial_Condition verification
13121 elsif Is_Initial_Condition_Proc
(Targ_Id
) then
13122 Extra
:= First_Formal_Type
(Targ_Id
);
13123 Kind
:= Initial_Condition_Verification
;
13127 elsif Is_Generic_Unit
(Targ_Id
) then
13129 Kind
:= Instantiation
;
13131 -- Internal controlled adjustment actions
13133 elsif Is_TSS
(Targ_Id
, TSS_Deep_Adjust
) then
13134 Extra
:= First_Formal_Type
(Targ_Id
);
13135 Kind
:= Internal_Controlled_Adjustment
;
13137 -- Internal controlled finalization actions
13139 elsif Is_TSS
(Targ_Id
, TSS_Deep_Finalize
) then
13140 Extra
:= First_Formal_Type
(Targ_Id
);
13141 Kind
:= Internal_Controlled_Finalization
;
13143 -- Internal controlled initialization actions
13145 elsif Is_TSS
(Targ_Id
, TSS_Deep_Initialize
) then
13146 Extra
:= First_Formal_Type
(Targ_Id
);
13147 Kind
:= Internal_Controlled_Initialization
;
13149 -- Invariant verification
13151 elsif Is_Invariant_Proc
(Targ_Id
)
13152 or else Is_Partial_Invariant_Proc
(Targ_Id
)
13154 Extra
:= First_Formal_Type
(Targ_Id
);
13155 Kind
:= Invariant_Verification
;
13157 -- Protected entry call
13159 elsif Is_Protected_Entry
(Targ_Id
) then
13161 Kind
:= Protected_Entry_Call
;
13163 -- Protected subprogram call
13165 elsif Is_Protected_Subp
(Targ_Id
) then
13167 Kind
:= Protected_Subprogram_Call
;
13171 elsif Is_Task_Entry
(Targ_Id
) then
13173 Kind
:= Task_Entry_Call
;
13175 -- Entry, operator, or subprogram call. This case must come last
13176 -- because most invocations above are variations of this case.
13178 elsif Ekind
(Targ_Id
) in
13179 E_Entry | E_Function | E_Operator | E_Procedure
13185 pragma Assert
(False);
13187 Kind
:= No_Invocation
;
13189 end Get_Invocation_Attributes
;
13194 Extra_Nam
: Name_Id
;
13195 Kind
: Invocation_Kind
;
13196 Rel
: Invoker_Target_Relation
;
13198 -- Start of processing for Record_Invocation_Relation
13201 Rel
.Invoker
:= Invk_Id
;
13202 Rel
.Target
:= Targ_Id
;
13204 -- Nothing to do when the invocation relation has already been
13205 -- recorded in ALI file of the main unit.
13207 if Is_Saved_Relation
(Rel
) then
13211 -- Mark the relation as recorded in the ALI file
13213 Set_Is_Saved_Relation
(Rel
);
13215 -- Declare the invoker in the ALI file
13217 Declare_Invocation_Construct
13218 (Constr_Id
=> Invk_Id
,
13219 In_State
=> In_State
);
13221 -- Obtain the invocation-specific attributes of the relation
13223 Get_Invocation_Attributes
(Extra
, Kind
);
13225 -- Certain invocations lack an extra entity used in error diagnostics
13227 if Present
(Extra
) then
13228 Extra_Nam
:= Chars
(Extra
);
13230 Extra_Nam
:= No_Name
;
13233 -- Add the relation in the ALI file
13235 Add_Invocation_Relation
13236 (Extra
=> Extra_Nam
,
13237 Invoker
=> Signature_Of
(Invk_Id
),
13239 Target
=> Signature_Of
(Targ_Id
),
13240 Update_Units
=> False);
13241 end Record_Invocation_Relation
;
13243 -----------------------------------
13244 -- Record_Simple_Invocation_Path --
13245 -----------------------------------
13247 procedure Record_Simple_Invocation_Path
13248 (In_State
: Processing_In_State
)
13250 package Scenarios
renames Active_Scenario_Stack
;
13252 Last_Targ
: constant Entity_Id
:=
13253 Target_Of
(Scenarios
.Last
, In_State
);
13254 First_Targ
: Entity_Id
;
13257 -- The path originates from the elaboration of the body. Add an extra
13258 -- relation from the elaboration body procedure to the first active
13261 if In_State
.Processing
= Invocation_Body_Processing
then
13262 Build_Elaborate_Body_Procedure
;
13263 First_Targ
:= Elab_Body_Id
;
13265 -- The path originates from the elaboration of the spec. Add an extra
13266 -- relation from the elaboration spec procedure to the first active
13269 elsif In_State
.Processing
= Invocation_Spec_Processing
then
13270 Build_Elaborate_Spec_Procedure
;
13271 First_Targ
:= Elab_Spec_Id
;
13274 First_Targ
:= Target_Of
(Scenarios
.First
, In_State
);
13277 -- Record a single relation from the first to the last scenario
13279 if First_Targ
/= Last_Targ
then
13280 Record_Invocation_Relation
13281 (Invk_Id
=> First_Targ
,
13282 Targ_Id
=> Last_Targ
,
13283 In_State
=> In_State
);
13285 end Record_Simple_Invocation_Path
;
13287 ----------------------------
13288 -- Set_Is_Saved_Construct --
13289 ----------------------------
13291 procedure Set_Is_Saved_Construct
(Constr
: Entity_Id
) is
13292 pragma Assert
(Present
(Constr
));
13295 NE_Set
.Insert
(Saved_Constructs_Set
, Constr
);
13296 end Set_Is_Saved_Construct
;
13298 ---------------------------
13299 -- Set_Is_Saved_Relation --
13300 ---------------------------
13302 procedure Set_Is_Saved_Relation
(Rel
: Invoker_Target_Relation
) is
13304 IR_Set
.Insert
(Saved_Relations_Set
, Rel
);
13305 end Set_Is_Saved_Relation
;
13311 function Signature_Of
(Id
: Entity_Id
) return Invocation_Signature_Id
is
13312 Loc
: constant Source_Ptr
:= Sloc
(Id
);
13314 function Instantiation_Locations
return Name_Id
;
13315 pragma Inline
(Instantiation_Locations
);
13316 -- Create a concatenation of all lines and colums of each instance
13317 -- where source location Loc appears. Return No_Name if no instances
13320 function Qualified_Scope
return Name_Id
;
13321 pragma Inline
(Qualified_Scope
);
13322 -- Obtain the qualified name of Id's scope
13324 -----------------------------
13325 -- Instantiation_Locations --
13326 -----------------------------
13328 function Instantiation_Locations
return Name_Id
is
13329 Buffer
: Bounded_String
(2052);
13332 SFI
: Source_File_Index
;
13335 SFI
:= Get_Source_File_Index
(Loc
);
13336 Inst
:= Instantiation
(SFI
);
13338 -- The location is within an instance. Construct a concatenation
13339 -- of all lines and colums of each individual instance using the
13340 -- following format:
13342 -- line1_column1_line2_column2_ ... _lineN_columnN
13344 if Inst
/= No_Location
then
13346 Append
(Buffer
, Nat
(Get_Logical_Line_Number
(Inst
)));
13347 Append
(Buffer
, '_');
13348 Append
(Buffer
, Nat
(Get_Column_Number
(Inst
)));
13350 SFI
:= Get_Source_File_Index
(Inst
);
13351 Inst
:= Instantiation
(SFI
);
13353 exit when Inst
= No_Location
;
13355 Append
(Buffer
, '_');
13358 Loc_Nam
:= Name_Find
(Buffer
);
13361 -- Otherwise there no instances are involved
13366 end Instantiation_Locations
;
13368 ---------------------
13369 -- Qualified_Scope --
13370 ---------------------
13372 function Qualified_Scope
return Name_Id
is
13376 Scop
:= Scope
(Id
);
13378 -- The entity appears within an anonymous concurrent type created
13379 -- for a single protected or task type declaration. Use the entity
13380 -- of the anonymous object as it represents the original scope.
13382 if Is_Concurrent_Type
(Scop
)
13383 and then Present
(Anonymous_Object
(Scop
))
13385 Scop
:= Anonymous_Object
(Scop
);
13388 return Get_Qualified_Name
(Scop
);
13389 end Qualified_Scope
;
13391 -- Start of processing for Signature_Of
13395 Invocation_Signature_Of
13396 (Column
=> Nat
(Get_Column_Number
(Loc
)),
13397 Line
=> Nat
(Get_Logical_Line_Number
(Loc
)),
13398 Locations
=> Instantiation_Locations
,
13399 Name
=> Chars
(Id
),
13400 Scope
=> Qualified_Scope
);
13408 (Pos
: Active_Scenario_Pos
;
13409 In_State
: Processing_In_State
) return Entity_Id
13411 package Scenarios
renames Active_Scenario_Stack
;
13413 -- Ensure that the position is within the bounds of the active
13416 pragma Assert
(Scenarios
.First
<= Pos
);
13417 pragma Assert
(Pos
<= Scenarios
.Last
);
13419 Scen_Rep
: constant Scenario_Rep_Id
:=
13420 Scenario_Representation_Of
13421 (Scenarios
.Table
(Pos
), In_State
);
13424 -- The true target of an activation call is the current task type
13425 -- rather than routine Activate_Tasks.
13427 if Kind
(Scen_Rep
) = Task_Activation_Scenario
then
13428 return Activated_Task_Type
(Scen_Rep
);
13430 return Target
(Scen_Rep
);
13434 ------------------------------
13435 -- Traverse_Invocation_Body --
13436 ------------------------------
13438 procedure Traverse_Invocation_Body
13440 In_State
: Processing_In_State
)
13445 Requires_Processing
=> Is_Invocation_Scenario
'Access,
13446 Processor
=> Process_Invocation_Scenario
'Access,
13447 In_State
=> In_State
);
13448 end Traverse_Invocation_Body
;
13450 ---------------------------
13451 -- Write_Invocation_Path --
13452 ---------------------------
13454 procedure Write_Invocation_Path
(In_State
: Processing_In_State
) is
13455 procedure Write_Target
(Targ_Id
: Entity_Id
; Is_First
: Boolean);
13456 pragma Inline
(Write_Target
);
13457 -- Write out invocation target Targ_Id to standard output. Flag
13458 -- Is_First should be set when the target is first in a path.
13464 procedure Write_Target
(Targ_Id
: Entity_Id
; Is_First
: Boolean) is
13466 if not Is_First
then
13467 Write_Str
(" --> ");
13470 Write_Name
(Get_Qualified_Name
(Targ_Id
));
13476 package Scenarios
renames Active_Scenario_Stack
;
13478 First_Seen
: Boolean := False;
13480 -- Start of processing for Write_Invocation_Path
13483 -- Nothing to do when flag -gnatd_T (output trace information on
13484 -- invocation path recording) is not in effect.
13486 if not Debug_Flag_Underscore_TT
then
13490 -- The path originates from the elaboration of the body. Write the
13491 -- elaboration body procedure.
13493 if In_State
.Processing
= Invocation_Body_Processing
then
13494 Write_Target
(Elab_Body_Id
, True);
13495 First_Seen
:= True;
13497 -- The path originates from the elaboration of the spec. Write the
13498 -- elaboration spec procedure.
13500 elsif In_State
.Processing
= Invocation_Spec_Processing
then
13501 Write_Target
(Elab_Spec_Id
, True);
13502 First_Seen
:= True;
13505 -- Write each individual target invoked by its corresponding scenario
13506 -- on the active scenario stack.
13508 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
13510 (Targ_Id
=> Target_Of
(Index
, In_State
),
13511 Is_First
=> Index
= Scenarios
.First
and then not First_Seen
);
13515 end Write_Invocation_Path
;
13516 end Invocation_Graph
;
13518 ------------------------
13519 -- Is_Safe_Activation --
13520 ------------------------
13522 function Is_Safe_Activation
13524 Task_Rep
: Target_Rep_Id
) return Boolean
13527 -- The activation of a task coming from an external instance cannot
13528 -- cause an ABE because the generic was already instantiated. Note
13529 -- that the instantiation itself may lead to an ABE.
13532 In_External_Instance
13534 Target_Decl
=> Spec_Declaration
(Task_Rep
));
13535 end Is_Safe_Activation
;
13541 function Is_Safe_Call
13543 Subp_Id
: Entity_Id
;
13544 Subp_Rep
: Target_Rep_Id
) return Boolean
13546 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
13547 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Subp_Rep
);
13550 -- The target is either an abstract subprogram, formal subprogram, or
13551 -- imported, in which case it does not have a body at compile or bind
13552 -- time. Assume that the call is ABE-safe.
13554 if Is_Bodiless_Subprogram
(Subp_Id
) then
13557 -- The target is an instantiation of a generic subprogram. The call
13558 -- cannot cause an ABE because the generic was already instantiated.
13559 -- Note that the instantiation itself may lead to an ABE.
13561 elsif Is_Generic_Instance
(Subp_Id
) then
13564 -- The invocation of a target coming from an external instance cannot
13565 -- cause an ABE because the generic was already instantiated. Note that
13566 -- the instantiation itself may lead to an ABE.
13568 elsif In_External_Instance
13570 Target_Decl
=> Spec_Decl
)
13574 -- The target is a subprogram body without a previous declaration. The
13575 -- call cannot cause an ABE because the body has already been seen.
13577 elsif Nkind
(Spec_Decl
) = N_Subprogram_Body
13578 and then No
(Corresponding_Spec
(Spec_Decl
))
13582 -- The target is a subprogram body stub without a prior declaration.
13583 -- The call cannot cause an ABE because the proper body substitutes
13586 elsif Nkind
(Spec_Decl
) = N_Subprogram_Body_Stub
13587 and then No
(Corresponding_Spec_Of_Stub
(Spec_Decl
))
13591 -- A call to an expression function that is not a completion cannot
13592 -- cause an ABE because it has no prior declaration; this remains
13593 -- true even if the FE transforms the callee into something else.
13595 elsif Nkind
(Original_Node
(Spec_Decl
)) = N_Expression_Function
then
13598 -- Subprogram bodies which wrap attribute references used as actuals
13599 -- in instantiations are always ABE-safe. These bodies are artifacts
13602 elsif Present
(Body_Decl
)
13603 and then Nkind
(Body_Decl
) = N_Subprogram_Body
13604 and then Was_Attribute_Reference
(Body_Decl
)
13612 ---------------------------
13613 -- Is_Safe_Instantiation --
13614 ---------------------------
13616 function Is_Safe_Instantiation
13618 Gen_Id
: Entity_Id
;
13619 Gen_Rep
: Target_Rep_Id
) return Boolean
13621 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Gen_Rep
);
13624 -- The generic is an intrinsic subprogram in which case it does not
13625 -- have a body at compile or bind time. Assume that the instantiation
13628 if Is_Bodiless_Subprogram
(Gen_Id
) then
13631 -- The instantiation of an external nested generic cannot cause an ABE
13632 -- if the outer generic was already instantiated. Note that the instance
13633 -- of the outer generic may lead to an ABE.
13635 elsif In_External_Instance
13637 Target_Decl
=> Spec_Decl
)
13641 -- The generic is a package. The instantiation cannot cause an ABE when
13642 -- the package has no body.
13644 elsif Ekind
(Gen_Id
) = E_Generic_Package
13645 and then not Has_Body
(Spec_Decl
)
13651 end Is_Safe_Instantiation
;
13657 function Is_Same_Unit
13658 (Unit_1
: Entity_Id
;
13659 Unit_2
: Entity_Id
) return Boolean
13662 return Unit_Entity
(Unit_1
) = Unit_Entity
(Unit_2
);
13665 -------------------------------
13666 -- Kill_Elaboration_Scenario --
13667 -------------------------------
13669 procedure Kill_Elaboration_Scenario
(N
: Node_Id
) is
13671 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
13672 -- enabled) is in effect because the legacy ABE lechanism does not need
13673 -- to carry out this action.
13675 if Legacy_Elaboration_Checks
then
13678 -- Nothing to do when the elaboration phase of the compiler is not
13681 elsif not Elaboration_Phase_Active
then
13685 -- Eliminate a recorded scenario when it appears within dead code
13686 -- because it will not be executed at elaboration time.
13688 if Is_Scenario
(N
) then
13689 Delete_Scenario
(N
);
13691 end Kill_Elaboration_Scenario
;
13693 ----------------------
13694 -- Main_Unit_Entity --
13695 ----------------------
13697 function Main_Unit_Entity
return Entity_Id
is
13699 -- Note that Cunit_Entity (Main_Unit) is not reliable in the presence of
13700 -- generic bodies and may return an outdated entity.
13702 return Defining_Entity
(Unit
(Cunit
(Main_Unit
)));
13703 end Main_Unit_Entity
;
13705 ----------------------
13706 -- Non_Private_View --
13707 ----------------------
13709 function Non_Private_View
(Typ
: Entity_Id
) return Entity_Id
is
13711 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
13712 return Full_View
(Typ
);
13716 end Non_Private_View
;
13718 ---------------------------------
13719 -- Record_Elaboration_Scenario --
13720 ---------------------------------
13722 procedure Record_Elaboration_Scenario
(N
: Node_Id
) is
13723 procedure Check_Preelaborated_Call
13725 Call_Lvl
: Enclosing_Level_Kind
);
13726 pragma Inline
(Check_Preelaborated_Call
);
13727 -- Verify that entry, operator, or subprogram call Call with enclosing
13728 -- level Call_Lvl does not appear at the library level of preelaborated
13731 function Find_Code_Unit
(Nod
: Node_Or_Entity_Id
) return Entity_Id
;
13732 pragma Inline
(Find_Code_Unit
);
13733 -- Return the code unit which contains arbitrary node or entity Nod.
13734 -- This is the unit of the file which physically contains the related
13735 -- construct denoted by Nod except when Nod is within an instantiation.
13736 -- In that case the unit is that of the top-level instantiation.
13738 function In_Preelaborated_Context
(Nod
: Node_Id
) return Boolean;
13739 pragma Inline
(In_Preelaborated_Context
);
13740 -- Determine whether arbitrary node Nod appears within a preelaborated
13743 procedure Record_Access_Taken
13745 Attr_Lvl
: Enclosing_Level_Kind
);
13746 pragma Inline
(Record_Access_Taken
);
13747 -- Record 'Access scenario Attr with enclosing level Attr_Lvl
13749 procedure Record_Call_Or_Task_Activation
13751 Call_Lvl
: Enclosing_Level_Kind
);
13752 pragma Inline
(Record_Call_Or_Task_Activation
);
13753 -- Record call scenario Call with enclosing level Call_Lvl
13755 procedure Record_Instantiation
13757 Inst_Lvl
: Enclosing_Level_Kind
);
13758 pragma Inline
(Record_Instantiation
);
13759 -- Record instantiation scenario Inst with enclosing level Inst_Lvl
13761 procedure Record_Variable_Assignment
13763 Asmt_Lvl
: Enclosing_Level_Kind
);
13764 pragma Inline
(Record_Variable_Assignment
);
13765 -- Record variable assignment scenario Asmt with enclosing level
13768 procedure Record_Variable_Reference
13770 Ref_Lvl
: Enclosing_Level_Kind
);
13771 pragma Inline
(Record_Variable_Reference
);
13772 -- Record variable reference scenario Ref with enclosing level Ref_Lvl
13774 ------------------------------
13775 -- Check_Preelaborated_Call --
13776 ------------------------------
13778 procedure Check_Preelaborated_Call
13780 Call_Lvl
: Enclosing_Level_Kind
)
13783 -- Nothing to do when the call is internally generated because it is
13784 -- assumed that it will never violate preelaboration.
13786 if not Is_Source_Call
(Call
) then
13789 -- Nothing to do when the call is preelaborable by definition
13791 elsif Is_Preelaborable_Call
(Call
) then
13794 -- Library-level calls are always considered because they are part of
13795 -- the associated unit's elaboration actions.
13797 elsif Call_Lvl
in Library_Level
then
13800 -- Calls at the library level of a generic package body have to be
13801 -- checked because they would render an instantiation illegal if the
13802 -- template is marked as preelaborated. Note that this does not apply
13803 -- to calls at the library level of a generic package spec.
13805 elsif Call_Lvl
= Generic_Body_Level
then
13808 -- Otherwise the call does not appear at the proper level and must
13809 -- not be considered for this check.
13815 -- If the call appears within a preelaborated unit, give an error
13817 if In_Preelaborated_Context
(Call
) then
13818 Error_Preelaborated_Call
(Call
);
13820 end Check_Preelaborated_Call
;
13822 --------------------
13823 -- Find_Code_Unit --
13824 --------------------
13826 function Find_Code_Unit
(Nod
: Node_Or_Entity_Id
) return Entity_Id
is
13828 return Find_Unit_Entity
(Unit
(Cunit
(Get_Code_Unit
(Nod
))));
13829 end Find_Code_Unit
;
13831 ------------------------------
13832 -- In_Preelaborated_Context --
13833 ------------------------------
13835 function In_Preelaborated_Context
(Nod
: Node_Id
) return Boolean is
13836 Body_Id
: constant Entity_Id
:= Find_Code_Unit
(Nod
);
13837 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Body_Id
);
13840 -- The node appears within a package body whose corresponding spec is
13841 -- subject to pragma Remote_Call_Interface or Remote_Types. This does
13842 -- not result in a preelaborated context because the package body may
13843 -- be on another machine.
13845 if Ekind
(Body_Id
) = E_Package_Body
13846 and then Is_Package_Or_Generic_Package
(Spec_Id
)
13847 and then (Is_Remote_Call_Interface
(Spec_Id
)
13848 or else Is_Remote_Types
(Spec_Id
))
13852 -- Otherwise the node appears within a preelaborated context when the
13853 -- associated unit is preelaborated.
13856 return Is_Preelaborated_Unit
(Spec_Id
);
13858 end In_Preelaborated_Context
;
13860 -------------------------
13861 -- Record_Access_Taken --
13862 -------------------------
13864 procedure Record_Access_Taken
13866 Attr_Lvl
: Enclosing_Level_Kind
)
13869 -- Signal any enclosing local exception handlers that the 'Access may
13870 -- raise Program_Error due to a failed ABE check when switch -gnatd.o
13871 -- (conservative elaboration order for indirect calls) is in effect.
13872 -- Marking the exception handlers ensures proper expansion by both
13873 -- the front and back end restriction when No_Exception_Propagation
13876 if Debug_Flag_Dot_O
then
13877 Possible_Local_Raise
(Attr
, Standard_Program_Error
);
13880 -- Add 'Access to the appropriate set
13882 if Attr_Lvl
= Library_Body_Level
then
13883 Add_Library_Body_Scenario
(Attr
);
13885 elsif Attr_Lvl
= Library_Spec_Level
13886 or else Attr_Lvl
= Instantiation_Level
13888 Add_Library_Spec_Scenario
(Attr
);
13891 -- 'Access requires a conditional ABE check when the dynamic model is
13894 Add_Dynamic_ABE_Check_Scenario
(Attr
);
13895 end Record_Access_Taken
;
13897 ------------------------------------
13898 -- Record_Call_Or_Task_Activation --
13899 ------------------------------------
13901 procedure Record_Call_Or_Task_Activation
13903 Call_Lvl
: Enclosing_Level_Kind
)
13906 -- Signal any enclosing local exception handlers that the call may
13907 -- raise Program_Error due to failed ABE check. Marking the exception
13908 -- handlers ensures proper expansion by both the front and back end
13909 -- restriction when No_Exception_Propagation is in effect.
13911 Possible_Local_Raise
(Call
, Standard_Program_Error
);
13913 -- Perform early detection of guaranteed ABEs in order to suppress
13914 -- the instantiation of generic bodies because gigi cannot handle
13915 -- certain types of premature instantiations.
13917 Process_Guaranteed_ABE
13919 In_State
=> Guaranteed_ABE_State
);
13921 -- Add the call or task activation to the appropriate set
13923 if Call_Lvl
= Declaration_Level
then
13924 Add_Declaration_Scenario
(Call
);
13926 elsif Call_Lvl
= Library_Body_Level
then
13927 Add_Library_Body_Scenario
(Call
);
13929 elsif Call_Lvl
= Library_Spec_Level
13930 or else Call_Lvl
= Instantiation_Level
13932 Add_Library_Spec_Scenario
(Call
);
13935 -- A call or a task activation requires a conditional ABE check when
13936 -- the dynamic model is in effect.
13938 Add_Dynamic_ABE_Check_Scenario
(Call
);
13939 end Record_Call_Or_Task_Activation
;
13941 --------------------------
13942 -- Record_Instantiation --
13943 --------------------------
13945 procedure Record_Instantiation
13947 Inst_Lvl
: Enclosing_Level_Kind
)
13950 -- Signal enclosing local exception handlers that instantiation may
13951 -- raise Program_Error due to failed ABE check. Marking the exception
13952 -- handlers ensures proper expansion by both the front and back end
13953 -- restriction when No_Exception_Propagation is in effect.
13955 Possible_Local_Raise
(Inst
, Standard_Program_Error
);
13957 -- Perform early detection of guaranteed ABEs in order to suppress
13958 -- the instantiation of generic bodies because gigi cannot handle
13959 -- certain types of premature instantiations.
13961 Process_Guaranteed_ABE
13963 In_State
=> Guaranteed_ABE_State
);
13965 -- Add the instantiation to the appropriate set
13967 if Inst_Lvl
= Declaration_Level
then
13968 Add_Declaration_Scenario
(Inst
);
13970 elsif Inst_Lvl
= Library_Body_Level
then
13971 Add_Library_Body_Scenario
(Inst
);
13973 elsif Inst_Lvl
= Library_Spec_Level
13974 or else Inst_Lvl
= Instantiation_Level
13976 Add_Library_Spec_Scenario
(Inst
);
13979 -- Instantiations of generics subject to SPARK_Mode On require
13980 -- elaboration-related checks even though the instantiations may
13981 -- not appear within elaboration code.
13983 if Is_Suitable_SPARK_Instantiation
(Inst
) then
13984 Add_SPARK_Scenario
(Inst
);
13987 -- An instantiation requires a conditional ABE check when the dynamic
13988 -- model is in effect.
13990 Add_Dynamic_ABE_Check_Scenario
(Inst
);
13991 end Record_Instantiation
;
13993 --------------------------------
13994 -- Record_Variable_Assignment --
13995 --------------------------------
13997 procedure Record_Variable_Assignment
13999 Asmt_Lvl
: Enclosing_Level_Kind
)
14002 -- Add the variable assignment to the appropriate set
14004 if Asmt_Lvl
= Library_Body_Level
then
14005 Add_Library_Body_Scenario
(Asmt
);
14007 elsif Asmt_Lvl
= Library_Spec_Level
14008 or else Asmt_Lvl
= Instantiation_Level
14010 Add_Library_Spec_Scenario
(Asmt
);
14012 end Record_Variable_Assignment
;
14014 -------------------------------
14015 -- Record_Variable_Reference --
14016 -------------------------------
14018 procedure Record_Variable_Reference
14020 Ref_Lvl
: Enclosing_Level_Kind
)
14023 -- Add the variable reference to the appropriate set
14025 if Ref_Lvl
= Library_Body_Level
then
14026 Add_Library_Body_Scenario
(Ref
);
14028 elsif Ref_Lvl
= Library_Spec_Level
14029 or else Ref_Lvl
= Instantiation_Level
14031 Add_Library_Spec_Scenario
(Ref
);
14033 end Record_Variable_Reference
;
14037 Scen
: constant Node_Id
:= Scenario
(N
);
14038 Scen_Lvl
: Enclosing_Level_Kind
;
14040 -- Start of processing for Record_Elaboration_Scenario
14043 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
14044 -- enabled) is in effect because the legacy ABE mechanism does not need
14045 -- to carry out this action.
14047 if Legacy_Elaboration_Checks
then
14050 -- Nothing to do when the scenario is being preanalyzed
14052 elsif Preanalysis_Active
then
14055 -- Nothing to do when the elaboration phase of the compiler is not
14058 elsif not Elaboration_Phase_Active
then
14062 Scen_Lvl
:= Find_Enclosing_Level
(Scen
);
14064 -- Ensure that a library-level call does not appear in a preelaborated
14065 -- unit. The check must come before ignoring scenarios within external
14066 -- units or inside generics because calls in those context must also be
14069 if Is_Suitable_Call
(Scen
) then
14070 Check_Preelaborated_Call
(Scen
, Scen_Lvl
);
14073 -- Nothing to do when the scenario does not appear within the main unit
14075 if not In_Main_Context
(Scen
) then
14078 -- Nothing to do when the scenario appears within a generic
14080 elsif Inside_A_Generic
then
14085 elsif Is_Suitable_Access_Taken
(Scen
) then
14086 Record_Access_Taken
14088 Attr_Lvl
=> Scen_Lvl
);
14090 -- Call or task activation
14092 elsif Is_Suitable_Call
(Scen
) then
14093 Record_Call_Or_Task_Activation
14095 Call_Lvl
=> Scen_Lvl
);
14097 -- Derived type declaration
14099 elsif Is_Suitable_SPARK_Derived_Type
(Scen
) then
14100 Add_SPARK_Scenario
(Scen
);
14104 elsif Is_Suitable_Instantiation
(Scen
) then
14105 Record_Instantiation
14107 Inst_Lvl
=> Scen_Lvl
);
14109 -- Refined_State pragma
14111 elsif Is_Suitable_SPARK_Refined_State_Pragma
(Scen
) then
14112 Add_SPARK_Scenario
(Scen
);
14114 -- Variable assignment
14116 elsif Is_Suitable_Variable_Assignment
(Scen
) then
14117 Record_Variable_Assignment
14119 Asmt_Lvl
=> Scen_Lvl
);
14121 -- Variable reference
14123 elsif Is_Suitable_Variable_Reference
(Scen
) then
14124 Record_Variable_Reference
14126 Ref_Lvl
=> Scen_Lvl
);
14128 end Record_Elaboration_Scenario
;
14134 function Scenario
(N
: Node_Id
) return Node_Id
is
14135 Orig_N
: constant Node_Id
:= Original_Node
(N
);
14138 -- An expanded instantiation is rewritten into a spec-body pair where
14139 -- N denotes the spec. In this case the original instantiation is the
14140 -- proper elaboration scenario.
14142 if Nkind
(Orig_N
) in N_Generic_Instantiation
then
14145 -- Otherwise the scenario is already in its proper form
14152 ----------------------
14153 -- Scenario_Storage --
14154 ----------------------
14156 package body Scenario_Storage
is
14158 ---------------------
14159 -- Data structures --
14160 ---------------------
14162 -- The following sets store all scenarios
14164 Declaration_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14165 Dynamic_ABE_Check_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14166 Library_Body_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14167 Library_Spec_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14168 SPARK_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14170 -------------------------------
14171 -- Finalize_Scenario_Storage --
14172 -------------------------------
14174 procedure Finalize_Scenario_Storage
is
14176 NE_Set
.Destroy
(Declaration_Scenarios
);
14177 NE_Set
.Destroy
(Dynamic_ABE_Check_Scenarios
);
14178 NE_Set
.Destroy
(Library_Body_Scenarios
);
14179 NE_Set
.Destroy
(Library_Spec_Scenarios
);
14180 NE_Set
.Destroy
(SPARK_Scenarios
);
14181 end Finalize_Scenario_Storage
;
14183 ---------------------------------
14184 -- Initialize_Scenario_Storage --
14185 ---------------------------------
14187 procedure Initialize_Scenario_Storage
is
14189 Declaration_Scenarios
:= NE_Set
.Create
(1000);
14190 Dynamic_ABE_Check_Scenarios
:= NE_Set
.Create
(500);
14191 Library_Body_Scenarios
:= NE_Set
.Create
(1000);
14192 Library_Spec_Scenarios
:= NE_Set
.Create
(1000);
14193 SPARK_Scenarios
:= NE_Set
.Create
(100);
14194 end Initialize_Scenario_Storage
;
14196 ------------------------------
14197 -- Add_Declaration_Scenario --
14198 ------------------------------
14200 procedure Add_Declaration_Scenario
(N
: Node_Id
) is
14201 pragma Assert
(Present
(N
));
14203 NE_Set
.Insert
(Declaration_Scenarios
, N
);
14204 end Add_Declaration_Scenario
;
14206 ------------------------------------
14207 -- Add_Dynamic_ABE_Check_Scenario --
14208 ------------------------------------
14210 procedure Add_Dynamic_ABE_Check_Scenario
(N
: Node_Id
) is
14211 pragma Assert
(Present
(N
));
14214 if not Check_Or_Failure_Generation_OK
then
14217 -- Nothing to do if the dynamic model is not in effect
14219 elsif not Dynamic_Elaboration_Checks
then
14223 NE_Set
.Insert
(Dynamic_ABE_Check_Scenarios
, N
);
14224 end Add_Dynamic_ABE_Check_Scenario
;
14226 -------------------------------
14227 -- Add_Library_Body_Scenario --
14228 -------------------------------
14230 procedure Add_Library_Body_Scenario
(N
: Node_Id
) is
14231 pragma Assert
(Present
(N
));
14233 NE_Set
.Insert
(Library_Body_Scenarios
, N
);
14234 end Add_Library_Body_Scenario
;
14236 -------------------------------
14237 -- Add_Library_Spec_Scenario --
14238 -------------------------------
14240 procedure Add_Library_Spec_Scenario
(N
: Node_Id
) is
14241 pragma Assert
(Present
(N
));
14243 NE_Set
.Insert
(Library_Spec_Scenarios
, N
);
14244 end Add_Library_Spec_Scenario
;
14246 ------------------------
14247 -- Add_SPARK_Scenario --
14248 ------------------------
14250 procedure Add_SPARK_Scenario
(N
: Node_Id
) is
14251 pragma Assert
(Present
(N
));
14253 NE_Set
.Insert
(SPARK_Scenarios
, N
);
14254 end Add_SPARK_Scenario
;
14256 ---------------------
14257 -- Delete_Scenario --
14258 ---------------------
14260 procedure Delete_Scenario
(N
: Node_Id
) is
14261 pragma Assert
(Present
(N
));
14264 -- Delete the scenario from whichever set it belongs to
14266 NE_Set
.Delete
(Declaration_Scenarios
, N
);
14267 NE_Set
.Delete
(Dynamic_ABE_Check_Scenarios
, N
);
14268 NE_Set
.Delete
(Library_Body_Scenarios
, N
);
14269 NE_Set
.Delete
(Library_Spec_Scenarios
, N
);
14270 NE_Set
.Delete
(SPARK_Scenarios
, N
);
14271 end Delete_Scenario
;
14273 -----------------------------------
14274 -- Iterate_Declaration_Scenarios --
14275 -----------------------------------
14277 function Iterate_Declaration_Scenarios
return NE_Set
.Iterator
is
14279 return NE_Set
.Iterate
(Declaration_Scenarios
);
14280 end Iterate_Declaration_Scenarios
;
14282 -----------------------------------------
14283 -- Iterate_Dynamic_ABE_Check_Scenarios --
14284 -----------------------------------------
14286 function Iterate_Dynamic_ABE_Check_Scenarios
return NE_Set
.Iterator
is
14288 return NE_Set
.Iterate
(Dynamic_ABE_Check_Scenarios
);
14289 end Iterate_Dynamic_ABE_Check_Scenarios
;
14291 ------------------------------------
14292 -- Iterate_Library_Body_Scenarios --
14293 ------------------------------------
14295 function Iterate_Library_Body_Scenarios
return NE_Set
.Iterator
is
14297 return NE_Set
.Iterate
(Library_Body_Scenarios
);
14298 end Iterate_Library_Body_Scenarios
;
14300 ------------------------------------
14301 -- Iterate_Library_Spec_Scenarios --
14302 ------------------------------------
14304 function Iterate_Library_Spec_Scenarios
return NE_Set
.Iterator
is
14306 return NE_Set
.Iterate
(Library_Spec_Scenarios
);
14307 end Iterate_Library_Spec_Scenarios
;
14309 -----------------------------
14310 -- Iterate_SPARK_Scenarios --
14311 -----------------------------
14313 function Iterate_SPARK_Scenarios
return NE_Set
.Iterator
is
14315 return NE_Set
.Iterate
(SPARK_Scenarios
);
14316 end Iterate_SPARK_Scenarios
;
14318 ----------------------
14319 -- Replace_Scenario --
14320 ----------------------
14322 procedure Replace_Scenario
(Old_N
: Node_Id
; New_N
: Node_Id
) is
14323 procedure Replace_Scenario_In
(Scenarios
: NE_Set
.Membership_Set
);
14324 -- Determine whether scenario Old_N is present in set Scenarios, and
14325 -- if this is the case it, replace it with New_N.
14327 -------------------------
14328 -- Replace_Scenario_In --
14329 -------------------------
14331 procedure Replace_Scenario_In
(Scenarios
: NE_Set
.Membership_Set
) is
14333 -- The set is intentionally checked for existance because node
14334 -- rewriting may occur after Sem_Elab has verified all scenarios
14335 -- and data structures have been destroyed.
14337 if NE_Set
.Present
(Scenarios
)
14338 and then NE_Set
.Contains
(Scenarios
, Old_N
)
14340 NE_Set
.Delete
(Scenarios
, Old_N
);
14341 NE_Set
.Insert
(Scenarios
, New_N
);
14343 end Replace_Scenario_In
;
14345 -- Start of processing for Replace_Scenario
14348 Replace_Scenario_In
(Declaration_Scenarios
);
14349 Replace_Scenario_In
(Dynamic_ABE_Check_Scenarios
);
14350 Replace_Scenario_In
(Library_Body_Scenarios
);
14351 Replace_Scenario_In
(Library_Spec_Scenarios
);
14352 Replace_Scenario_In
(SPARK_Scenarios
);
14353 end Replace_Scenario
;
14354 end Scenario_Storage
;
14360 package body Semantics
is
14362 --------------------------------
14363 -- Is_Accept_Alternative_Proc --
14364 --------------------------------
14366 function Is_Accept_Alternative_Proc
(Id
: Entity_Id
) return Boolean is
14368 -- To qualify, the entity must denote a procedure with a receiving
14372 Ekind
(Id
) = E_Procedure
and then Present
(Receiving_Entry
(Id
));
14373 end Is_Accept_Alternative_Proc
;
14375 ------------------------
14376 -- Is_Activation_Proc --
14377 ------------------------
14379 function Is_Activation_Proc
(Id
: Entity_Id
) return Boolean is
14381 -- To qualify, the entity must denote one of the runtime procedures
14382 -- in charge of task activation.
14384 if Ekind
(Id
) = E_Procedure
then
14385 if Restricted_Profile
then
14386 return Is_RTE
(Id
, RE_Activate_Restricted_Tasks
);
14388 return Is_RTE
(Id
, RE_Activate_Tasks
);
14393 end Is_Activation_Proc
;
14395 ----------------------------
14396 -- Is_Ada_Semantic_Target --
14397 ----------------------------
14399 function Is_Ada_Semantic_Target
(Id
: Entity_Id
) return Boolean is
14402 Is_Activation_Proc
(Id
)
14403 or else Is_Controlled_Procedure
(Id
, Name_Adjust
)
14404 or else Is_Controlled_Procedure
(Id
, Name_Finalize
)
14405 or else Is_Controlled_Procedure
(Id
, Name_Initialize
)
14406 or else Is_Init_Proc
(Id
)
14407 or else Is_Invariant_Proc
(Id
)
14408 or else Is_Protected_Entry
(Id
)
14409 or else Is_Protected_Subp
(Id
)
14410 or else Is_Protected_Body_Subp
(Id
)
14411 or else Is_Subprogram_Inst
(Id
)
14412 or else Is_Task_Entry
(Id
);
14413 end Is_Ada_Semantic_Target
;
14415 --------------------------------
14416 -- Is_Assertion_Pragma_Target --
14417 --------------------------------
14419 function Is_Assertion_Pragma_Target
(Id
: Entity_Id
) return Boolean is
14422 Is_Default_Initial_Condition_Proc
(Id
)
14423 or else Is_Initial_Condition_Proc
(Id
)
14424 or else Is_Invariant_Proc
(Id
)
14425 or else Is_Partial_Invariant_Proc
(Id
);
14426 end Is_Assertion_Pragma_Target
;
14428 ----------------------------
14429 -- Is_Bodiless_Subprogram --
14430 ----------------------------
14432 function Is_Bodiless_Subprogram
(Subp_Id
: Entity_Id
) return Boolean is
14434 -- An abstract subprogram does not have a body
14436 if Ekind
(Subp_Id
) in E_Function | E_Operator | E_Procedure
14437 and then Is_Abstract_Subprogram
(Subp_Id
)
14441 -- A formal subprogram does not have a body
14443 elsif Is_Formal_Subprogram
(Subp_Id
) then
14446 -- An imported subprogram may have a body, however it is not known at
14447 -- compile or bind time where the body resides and whether it will be
14448 -- elaborated on time.
14450 elsif Is_Imported
(Subp_Id
) then
14455 end Is_Bodiless_Subprogram
;
14457 ----------------------
14458 -- Is_Bridge_Target --
14459 ----------------------
14461 function Is_Bridge_Target
(Id
: Entity_Id
) return Boolean is
14464 Is_Accept_Alternative_Proc
(Id
)
14465 or else Is_Finalizer
(Id
)
14466 or else Is_Partial_Invariant_Proc
(Id
)
14467 or else Is_TSS
(Id
, TSS_Deep_Adjust
)
14468 or else Is_TSS
(Id
, TSS_Deep_Finalize
)
14469 or else Is_TSS
(Id
, TSS_Deep_Initialize
);
14470 end Is_Bridge_Target
;
14472 ---------------------------------------
14473 -- Is_Default_Initial_Condition_Proc --
14474 ---------------------------------------
14476 function Is_Default_Initial_Condition_Proc
14477 (Id
: Entity_Id
) return Boolean
14480 -- To qualify, the entity must denote a Default_Initial_Condition
14483 return Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
);
14484 end Is_Default_Initial_Condition_Proc
;
14486 -------------------------------
14487 -- Is_Initial_Condition_Proc --
14488 -------------------------------
14490 function Is_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean is
14492 -- To qualify, the entity must denote an Initial_Condition procedure
14495 Ekind
(Id
) = E_Procedure
14496 and then Is_Initial_Condition_Procedure
(Id
);
14497 end Is_Initial_Condition_Proc
;
14499 --------------------
14500 -- Is_Initialized --
14501 --------------------
14503 function Is_Initialized
(Obj_Decl
: Node_Id
) return Boolean is
14505 -- To qualify, the object declaration must have an expression
14508 Present
(Expression
(Obj_Decl
))
14509 or else Has_Init_Expression
(Obj_Decl
);
14510 end Is_Initialized
;
14512 -----------------------
14513 -- Is_Invariant_Proc --
14514 -----------------------
14516 function Is_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
14518 -- To qualify, the entity must denote the "full" invariant procedure
14520 return Ekind
(Id
) = E_Procedure
and then Is_Invariant_Procedure
(Id
);
14521 end Is_Invariant_Proc
;
14523 ---------------------------------------
14524 -- Is_Non_Library_Level_Encapsulator --
14525 ---------------------------------------
14527 function Is_Non_Library_Level_Encapsulator
14528 (N
: Node_Id
) return Boolean
14532 when N_Abstract_Subprogram_Declaration
14533 | N_Aspect_Specification
14534 | N_Component_Declaration
14536 | N_Entry_Declaration
14537 | N_Expression_Function
14538 | N_Formal_Abstract_Subprogram_Declaration
14539 | N_Formal_Concrete_Subprogram_Declaration
14540 | N_Formal_Object_Declaration
14541 | N_Formal_Package_Declaration
14542 | N_Formal_Type_Declaration
14543 | N_Generic_Association
14544 | N_Implicit_Label_Declaration
14545 | N_Incomplete_Type_Declaration
14546 | N_Private_Extension_Declaration
14547 | N_Private_Type_Declaration
14549 | N_Protected_Type_Declaration
14550 | N_Single_Protected_Declaration
14551 | N_Single_Task_Declaration
14552 | N_Subprogram_Body
14553 | N_Subprogram_Declaration
14555 | N_Task_Type_Declaration
14560 return Is_Generic_Declaration_Or_Body
(N
);
14562 end Is_Non_Library_Level_Encapsulator
;
14564 -------------------------------
14565 -- Is_Partial_Invariant_Proc --
14566 -------------------------------
14568 function Is_Partial_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
14570 -- To qualify, the entity must denote the "partial" invariant
14574 Ekind
(Id
) = E_Procedure
14575 and then Is_Partial_Invariant_Procedure
(Id
);
14576 end Is_Partial_Invariant_Proc
;
14578 ---------------------------
14579 -- Is_Preelaborated_Unit --
14580 ---------------------------
14582 function Is_Preelaborated_Unit
(Id
: Entity_Id
) return Boolean is
14585 Is_Preelaborated
(Id
)
14586 or else Is_Pure
(Id
)
14587 or else Is_Remote_Call_Interface
(Id
)
14588 or else Is_Remote_Types
(Id
)
14589 or else Is_Shared_Passive
(Id
);
14590 end Is_Preelaborated_Unit
;
14592 ------------------------
14593 -- Is_Protected_Entry --
14594 ------------------------
14596 function Is_Protected_Entry
(Id
: Entity_Id
) return Boolean is
14598 -- To qualify, the entity must denote an entry defined in a protected
14603 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
14604 end Is_Protected_Entry
;
14606 -----------------------
14607 -- Is_Protected_Subp --
14608 -----------------------
14610 function Is_Protected_Subp
(Id
: Entity_Id
) return Boolean is
14612 -- To qualify, the entity must denote a subprogram defined within a
14616 Ekind
(Id
) in E_Function | E_Procedure
14617 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
14618 end Is_Protected_Subp
;
14620 ----------------------------
14621 -- Is_Protected_Body_Subp --
14622 ----------------------------
14624 function Is_Protected_Body_Subp
(Id
: Entity_Id
) return Boolean is
14626 -- To qualify, the entity must denote a subprogram with attribute
14627 -- Protected_Subprogram set.
14630 Ekind
(Id
) in E_Function | E_Procedure
14631 and then Present
(Protected_Subprogram
(Id
));
14632 end Is_Protected_Body_Subp
;
14638 function Is_Scenario
(N
: Node_Id
) return Boolean is
14641 when N_Assignment_Statement
14642 | N_Attribute_Reference
14644 | N_Entry_Call_Statement
14647 | N_Function_Instantiation
14649 | N_Package_Instantiation
14650 | N_Procedure_Call_Statement
14651 | N_Procedure_Instantiation
14652 | N_Requeue_Statement
14661 ------------------------------
14662 -- Is_SPARK_Semantic_Target --
14663 ------------------------------
14665 function Is_SPARK_Semantic_Target
(Id
: Entity_Id
) return Boolean is
14668 Is_Default_Initial_Condition_Proc
(Id
)
14669 or else Is_Initial_Condition_Proc
(Id
);
14670 end Is_SPARK_Semantic_Target
;
14672 ------------------------
14673 -- Is_Subprogram_Inst --
14674 ------------------------
14676 function Is_Subprogram_Inst
(Id
: Entity_Id
) return Boolean is
14678 -- To qualify, the entity must denote a function or a procedure which
14679 -- is hidden within an anonymous package, and is a generic instance.
14682 Ekind
(Id
) in E_Function | E_Procedure
14683 and then Is_Hidden
(Id
)
14684 and then Is_Generic_Instance
(Id
);
14685 end Is_Subprogram_Inst
;
14687 ------------------------------
14688 -- Is_Suitable_Access_Taken --
14689 ------------------------------
14691 function Is_Suitable_Access_Taken
(N
: Node_Id
) return Boolean is
14694 Subp_Id
: Entity_Id
;
14697 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
14699 if Debug_Flag_Dot_UU
then
14702 -- Nothing to do when the scenario is not an attribute reference
14704 elsif Nkind
(N
) /= N_Attribute_Reference
then
14707 -- Nothing to do for internally-generated attributes because they are
14708 -- assumed to be ABE safe.
14710 elsif not Comes_From_Source
(N
) then
14714 Nam
:= Attribute_Name
(N
);
14715 Pref
:= Prefix
(N
);
14717 -- Sanitize the prefix of the attribute
14719 if not Is_Entity_Name
(Pref
) then
14722 elsif No
(Entity
(Pref
)) then
14726 Subp_Id
:= Entity
(Pref
);
14728 if not Is_Subprogram_Or_Entry
(Subp_Id
) then
14732 -- Traverse a possible chain of renamings to obtain the original
14733 -- entry or subprogram which the prefix may rename.
14735 Subp_Id
:= Get_Renamed_Entity
(Subp_Id
);
14737 -- To qualify, the attribute must meet the following prerequisites:
14741 -- The prefix must denote a source entry, operator, or subprogram
14742 -- which is not imported.
14744 Comes_From_Source
(Subp_Id
)
14745 and then Is_Subprogram_Or_Entry
(Subp_Id
)
14746 and then not Is_Bodiless_Subprogram
(Subp_Id
)
14748 -- The attribute name must be one of the 'Access forms. Note that
14749 -- 'Unchecked_Access cannot apply to a subprogram.
14751 and then Nam
in Name_Access | Name_Unrestricted_Access
;
14752 end Is_Suitable_Access_Taken
;
14754 ----------------------
14755 -- Is_Suitable_Call --
14756 ----------------------
14758 function Is_Suitable_Call
(N
: Node_Id
) return Boolean is
14760 -- Entry and subprogram calls are intentionally ignored because they
14761 -- may undergo expansion depending on the compilation mode, previous
14762 -- errors, generic context, etc. Call markers play the role of calls
14763 -- and provide a uniform foundation for ABE processing.
14765 return Nkind
(N
) = N_Call_Marker
;
14766 end Is_Suitable_Call
;
14768 -------------------------------
14769 -- Is_Suitable_Instantiation --
14770 -------------------------------
14772 function Is_Suitable_Instantiation
(N
: Node_Id
) return Boolean is
14773 Inst
: constant Node_Id
:= Scenario
(N
);
14776 -- To qualify, the instantiation must come from source
14779 Comes_From_Source
(Inst
)
14780 and then Nkind
(Inst
) in N_Generic_Instantiation
;
14781 end Is_Suitable_Instantiation
;
14783 ------------------------------------
14784 -- Is_Suitable_SPARK_Derived_Type --
14785 ------------------------------------
14787 function Is_Suitable_SPARK_Derived_Type
(N
: Node_Id
) return Boolean is
14792 -- To qualify, the type declaration must denote a derived tagged type
14793 -- with primitive operations, subject to pragma SPARK_Mode On.
14795 if Nkind
(N
) = N_Full_Type_Declaration
14796 and then Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
14798 Typ
:= Defining_Entity
(N
);
14799 Prag
:= SPARK_Pragma
(Typ
);
14802 Is_Tagged_Type
(Typ
)
14803 and then Has_Primitive_Operations
(Typ
)
14804 and then Present
(Prag
)
14805 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
;
14809 end Is_Suitable_SPARK_Derived_Type
;
14811 -------------------------------------
14812 -- Is_Suitable_SPARK_Instantiation --
14813 -------------------------------------
14815 function Is_Suitable_SPARK_Instantiation
(N
: Node_Id
) return Boolean is
14816 Inst
: constant Node_Id
:= Scenario
(N
);
14818 Gen_Id
: Entity_Id
;
14822 -- To qualify, both the instantiation and the generic must be subject
14823 -- to SPARK_Mode On.
14825 if Is_Suitable_Instantiation
(N
) then
14826 Gen_Id
:= Instantiated_Generic
(Inst
);
14827 Prag
:= SPARK_Pragma
(Gen_Id
);
14830 Is_SPARK_Mode_On_Node
(Inst
)
14831 and then Present
(Prag
)
14832 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
;
14836 end Is_Suitable_SPARK_Instantiation
;
14838 --------------------------------------------
14839 -- Is_Suitable_SPARK_Refined_State_Pragma --
14840 --------------------------------------------
14842 function Is_Suitable_SPARK_Refined_State_Pragma
14843 (N
: Node_Id
) return Boolean
14846 -- To qualfy, the pragma must denote Refined_State
14849 Nkind
(N
) = N_Pragma
14850 and then Pragma_Name
(N
) = Name_Refined_State
;
14851 end Is_Suitable_SPARK_Refined_State_Pragma
;
14853 -------------------------------------
14854 -- Is_Suitable_Variable_Assignment --
14855 -------------------------------------
14857 function Is_Suitable_Variable_Assignment
(N
: Node_Id
) return Boolean is
14859 N_Unit_Id
: Entity_Id
;
14861 Var_Decl
: Node_Id
;
14862 Var_Id
: Entity_Id
;
14863 Var_Unit
: Node_Id
;
14864 Var_Unit_Id
: Entity_Id
;
14867 -- Nothing to do when the scenario is not an assignment
14869 if Nkind
(N
) /= N_Assignment_Statement
then
14872 -- Nothing to do for internally-generated assignments because they
14873 -- are assumed to be ABE safe.
14875 elsif not Comes_From_Source
(N
) then
14878 -- Assignments are ignored in GNAT mode on the assumption that
14879 -- they are ABE-safe. This behavior parallels that of the old
14882 elsif GNAT_Mode
then
14886 Nam
:= Assignment_Target
(N
);
14888 -- Sanitize the left hand side of the assignment
14890 if not Is_Entity_Name
(Nam
) then
14893 elsif No
(Entity
(Nam
)) then
14897 Var_Id
:= Entity
(Nam
);
14899 -- Sanitize the variable
14901 if Var_Id
= Any_Id
then
14904 elsif Ekind
(Var_Id
) /= E_Variable
then
14908 Var_Decl
:= Declaration_Node
(Var_Id
);
14910 if Nkind
(Var_Decl
) /= N_Object_Declaration
then
14914 N_Unit_Id
:= Find_Top_Unit
(N
);
14915 N_Unit
:= Unit_Declaration_Node
(N_Unit_Id
);
14917 Var_Unit_Id
:= Find_Top_Unit
(Var_Decl
);
14918 Var_Unit
:= Unit_Declaration_Node
(Var_Unit_Id
);
14920 -- To qualify, the assignment must meet the following prerequisites:
14923 Comes_From_Source
(Var_Id
)
14925 -- The variable must be declared in the spec of compilation unit
14928 and then Nkind
(Var_Unit
) = N_Package_Declaration
14929 and then Find_Enclosing_Level
(Var_Decl
) = Library_Spec_Level
14931 -- The assignment must occur in the body of compilation unit U
14933 and then Nkind
(N_Unit
) = N_Package_Body
14934 and then Present
(Corresponding_Body
(Var_Unit
))
14935 and then Corresponding_Body
(Var_Unit
) = N_Unit_Id
;
14936 end Is_Suitable_Variable_Assignment
;
14938 ------------------------------------
14939 -- Is_Suitable_Variable_Reference --
14940 ------------------------------------
14942 function Is_Suitable_Variable_Reference
(N
: Node_Id
) return Boolean is
14944 -- Expanded names and identifiers are intentionally ignored because
14945 -- they be folded, optimized away, etc. Variable references markers
14946 -- play the role of variable references and provide a uniform
14947 -- foundation for ABE processing.
14949 return Nkind
(N
) = N_Variable_Reference_Marker
;
14950 end Is_Suitable_Variable_Reference
;
14952 -------------------
14953 -- Is_Task_Entry --
14954 -------------------
14956 function Is_Task_Entry
(Id
: Entity_Id
) return Boolean is
14958 -- To qualify, the entity must denote an entry defined in a task type
14961 Is_Entry
(Id
) and then Is_Task_Type
(Non_Private_View
(Scope
(Id
)));
14964 ------------------------
14965 -- Is_Up_Level_Target --
14966 ------------------------
14968 function Is_Up_Level_Target
14969 (Targ_Decl
: Node_Id
;
14970 In_State
: Processing_In_State
) return Boolean
14972 Root
: constant Node_Id
:= Root_Scenario
;
14973 Root_Rep
: constant Scenario_Rep_Id
:=
14974 Scenario_Representation_Of
(Root
, In_State
);
14977 -- The root appears within the declaratons of a block statement,
14978 -- entry body, subprogram body, or task body ignoring enclosing
14979 -- packages. The root is always within the main unit.
14981 if not In_State
.Suppress_Up_Level_Targets
14982 and then Level
(Root_Rep
) = Declaration_Level
14984 -- The target is within the main unit. It acts as an up-level
14985 -- target when it appears within a context which encloses the
14988 -- package body Main_Unit is
14989 -- function Func ...; -- target
14991 -- procedure Proc is
14992 -- X : ... := Func; -- root scenario
14994 if In_Extended_Main_Code_Unit
(Targ_Decl
) then
14995 return not In_Same_Context
(Root
, Targ_Decl
, Nested_OK
=> True);
14997 -- Otherwise the target is external to the main unit which makes
14998 -- it an up-level target.
15006 end Is_Up_Level_Target
;
15009 ---------------------------
15010 -- Set_Elaboration_Phase --
15011 ---------------------------
15013 procedure Set_Elaboration_Phase
(Status
: Elaboration_Phase_Status
) is
15015 Elaboration_Phase
:= Status
;
15016 end Set_Elaboration_Phase
;
15018 ---------------------
15019 -- SPARK_Processor --
15020 ---------------------
15022 package body SPARK_Processor
is
15024 -----------------------
15025 -- Local subprograms --
15026 -----------------------
15028 procedure Process_SPARK_Derived_Type
15029 (Typ_Decl
: Node_Id
;
15030 Typ_Rep
: Scenario_Rep_Id
;
15031 In_State
: Processing_In_State
);
15032 pragma Inline
(Process_SPARK_Derived_Type
);
15033 -- Verify that the freeze node of a derived type denoted by declaration
15034 -- Typ_Decl is within the early call region of each overriding primitive
15035 -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is
15036 -- the representation of the type. In_State denotes the current state of
15037 -- the Processing phase.
15039 procedure Process_SPARK_Instantiation
15041 Inst_Rep
: Scenario_Rep_Id
;
15042 In_State
: Processing_In_State
);
15043 pragma Inline
(Process_SPARK_Instantiation
);
15044 -- Verify that instantiation Inst does not precede the generic body it
15045 -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the
15046 -- instantiation. In_State is the current state of the Processing phase.
15048 procedure Process_SPARK_Refined_State_Pragma
15050 Prag_Rep
: Scenario_Rep_Id
;
15051 In_State
: Processing_In_State
);
15052 pragma Inline
(Process_SPARK_Refined_State_Pragma
);
15053 -- Verify that each constituent of Refined_State pragma Prag which
15054 -- belongs to abstract state mentioned in pragma Initializes has prior
15055 -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)).
15056 -- Prag_Rep is the representation of the pragma. In_State denotes the
15057 -- current state of the Processing phase.
15059 procedure Process_SPARK_Scenario
15061 In_State
: Processing_In_State
);
15062 pragma Inline
(Process_SPARK_Scenario
);
15063 -- Top-level dispatcher for verifying SPARK scenarios which are not
15064 -- always executable during elaboration but still need elaboration-
15065 -- related checks. In_State is the current state of the Processing
15068 ---------------------------------
15069 -- Check_SPARK_Model_In_Effect --
15070 ---------------------------------
15072 SPARK_Model_Warning_Posted
: Boolean := False;
15073 -- This flag prevents the same SPARK model-related warning from being
15074 -- emitted multiple times.
15076 procedure Check_SPARK_Model_In_Effect
is
15077 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Main_Unit_Entity
);
15080 -- Do not emit the warning multiple times as this creates useless
15083 if SPARK_Model_Warning_Posted
then
15086 -- SPARK rule verification requires the "strict" static model
15088 elsif Static_Elaboration_Checks
15089 and not Relaxed_Elaboration_Checks
15093 -- Any other combination of models does not guarantee the absence of
15094 -- ABE problems for SPARK rule verification purposes. Note that there
15095 -- is no need to check for the presence of the legacy ABE mechanism
15096 -- because the legacy code has its own dedicated processing for SPARK
15100 SPARK_Model_Warning_Posted
:= True;
15103 ("??SPARK elaboration checks require static elaboration model",
15106 if Dynamic_Elaboration_Checks
then
15108 ("\dynamic elaboration model is in effect", Spec_Id
);
15111 pragma Assert
(Relaxed_Elaboration_Checks
);
15113 ("\relaxed elaboration model is in effect", Spec_Id
);
15116 end Check_SPARK_Model_In_Effect
;
15118 ---------------------------
15119 -- Check_SPARK_Scenarios --
15120 ---------------------------
15122 procedure Check_SPARK_Scenarios
is
15123 Iter
: NE_Set
.Iterator
;
15127 Iter
:= Iterate_SPARK_Scenarios
;
15128 while NE_Set
.Has_Next
(Iter
) loop
15129 NE_Set
.Next
(Iter
, N
);
15131 Process_SPARK_Scenario
15133 In_State
=> SPARK_State
);
15135 end Check_SPARK_Scenarios
;
15137 --------------------------------
15138 -- Process_SPARK_Derived_Type --
15139 --------------------------------
15141 procedure Process_SPARK_Derived_Type
15142 (Typ_Decl
: Node_Id
;
15143 Typ_Rep
: Scenario_Rep_Id
;
15144 In_State
: Processing_In_State
)
15146 pragma Unreferenced
(In_State
);
15148 Typ
: constant Entity_Id
:= Target
(Typ_Rep
);
15150 Stop_Check
: exception;
15151 -- This exception is raised when the freeze node violates the
15152 -- placement rules.
15154 procedure Check_Overriding_Primitive
15157 pragma Inline
(Check_Overriding_Primitive
);
15158 -- Verify that freeze node FNode is within the early call region of
15159 -- overriding primitive Prim's body.
15161 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
;
15162 pragma Inline
(Freeze_Node_Location
);
15163 -- Return a more accurate source location associated with freeze node
15166 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean;
15167 pragma Inline
(Precedes_Source_Construct
);
15168 -- Determine whether arbitrary node N appears prior to some source
15171 procedure Suggest_Elaborate_Body
15173 Body_Decl
: Node_Id
;
15174 Error_Nod
: Node_Id
);
15175 pragma Inline
(Suggest_Elaborate_Body
);
15176 -- Suggest the use of pragma Elaborate_Body when the pragma will
15177 -- allow for node N to appear within the early call region of
15178 -- subprogram body Body_Decl. The suggestion is attached to
15179 -- Error_Nod as a continuation error.
15181 --------------------------------
15182 -- Check_Overriding_Primitive --
15183 --------------------------------
15185 procedure Check_Overriding_Primitive
15189 Prim_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Prim
);
15190 Body_Decl
: Node_Id
;
15191 Body_Id
: Entity_Id
;
15195 -- Nothing to do for predefined primitives because they are
15196 -- artifacts of tagged type expansion and cannot override source
15197 -- primitives. Nothing to do as well for inherited primitives, as
15198 -- the check concerns overriding ones. Finally, nothing to do for
15199 -- abstract subprograms, because they have no body that could be
15202 if Is_Predefined_Dispatching_Operation
(Prim
)
15203 or else not Is_Overriding_Subprogram
(Prim
)
15204 or else Is_Abstract_Subprogram
(Prim
)
15209 Body_Id
:= Corresponding_Body
(Prim_Decl
);
15211 -- Nothing to do when the primitive does not have a corresponding
15212 -- body. This can happen when the unit with the bodies is not the
15213 -- main unit subjected to ABE checks.
15215 if No
(Body_Id
) then
15218 -- The primitive overrides a parent or progenitor primitive
15220 elsif Present
(Overridden_Operation
(Prim
)) then
15222 -- Nothing to do when overriding an interface primitive happens
15223 -- by inheriting a non-interface primitive as the check would
15224 -- be done on the parent primitive.
15226 if Present
(Alias
(Prim
)) then
15230 -- Nothing to do when the primitive is not overriding. The body of
15231 -- such a primitive cannot be targeted by a dispatching call which
15232 -- is executable during elaboration, and cannot cause an ABE.
15238 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
15239 Region
:= Find_Early_Call_Region
(Body_Decl
);
15241 -- The freeze node appears prior to the early call region of the
15244 -- IMPORTANT: This check must always be performed even when
15245 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
15246 -- specified because the static model cannot guarantee the absence
15247 -- of ABEs in the presence of dispatching calls.
15249 if Earlier_In_Extended_Unit
(FNode
, Region
) then
15250 Error_Msg_Node_2
:= Prim
;
15251 Error_Msg_Code
:= GEC_Type_Early_Call_Region
;
15253 ("first freezing point of type & must appear within early "
15254 & "call region of primitive body '[[]']",
15257 Error_Msg_Sloc
:= Sloc
(Region
);
15258 Error_Msg_N
("\region starts #", Typ_Decl
);
15260 Error_Msg_Sloc
:= Sloc
(Body_Decl
);
15261 Error_Msg_N
("\region ends #", Typ_Decl
);
15263 Error_Msg_Sloc
:= Freeze_Node_Location
(FNode
);
15264 Error_Msg_N
("\first freezing point #", Typ_Decl
);
15266 -- If applicable, suggest the use of pragma Elaborate_Body in
15267 -- the associated package spec.
15269 Suggest_Elaborate_Body
15271 Body_Decl
=> Body_Decl
,
15272 Error_Nod
=> Typ_Decl
);
15276 end Check_Overriding_Primitive
;
15278 --------------------------
15279 -- Freeze_Node_Location --
15280 --------------------------
15282 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
is
15283 Context
: constant Node_Id
:= Parent
(FNode
);
15284 Loc
: constant Source_Ptr
:= Sloc
(FNode
);
15286 Prv_Decls
: List_Id
;
15287 Vis_Decls
: List_Id
;
15290 -- In general, the source location of the freeze node is as close
15291 -- as possible to the real freeze point, except when the freeze
15292 -- node is at the "bottom" of a package spec.
15294 if Nkind
(Context
) = N_Package_Specification
then
15295 Prv_Decls
:= Private_Declarations
(Context
);
15296 Vis_Decls
:= Visible_Declarations
(Context
);
15298 -- The freeze node appears in the private declarations of the
15301 if Present
(Prv_Decls
)
15302 and then List_Containing
(FNode
) = Prv_Decls
15306 -- The freeze node appears in the visible declarations of the
15307 -- package and there are no private declarations.
15309 elsif Present
(Vis_Decls
)
15310 and then List_Containing
(FNode
) = Vis_Decls
15311 and then Is_Empty_List
(Prv_Decls
)
15315 -- Otherwise the freeze node is not in the "last" declarative
15316 -- list of the package. Use the existing source location of the
15323 -- The freeze node appears at the "bottom" of the package when
15324 -- it is in the "last" declarative list and is either the last
15325 -- in the list or is followed by internal constructs only. In
15326 -- that case the more appropriate source location is that of
15327 -- the package end label.
15329 if not Precedes_Source_Construct
(FNode
) then
15330 return Sloc
(End_Label
(Context
));
15335 end Freeze_Node_Location
;
15337 -------------------------------
15338 -- Precedes_Source_Construct --
15339 -------------------------------
15341 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean is
15346 while Present
(Decl
) loop
15347 if Comes_From_Source
(Decl
) then
15350 -- A generated body for a source expression function is treated
15351 -- as a source construct.
15353 elsif Nkind
(Decl
) = N_Subprogram_Body
15354 and then Was_Expression_Function
(Decl
)
15355 and then Comes_From_Source
(Original_Node
(Decl
))
15364 end Precedes_Source_Construct
;
15366 ----------------------------
15367 -- Suggest_Elaborate_Body --
15368 ----------------------------
15370 procedure Suggest_Elaborate_Body
15372 Body_Decl
: Node_Id
;
15373 Error_Nod
: Node_Id
)
15375 Unit_Id
: constant Node_Id
:= Unit
(Cunit
(Main_Unit
));
15379 -- The suggestion applies only when the subprogram body resides in
15380 -- a compilation package body, and a pragma Elaborate_Body would
15381 -- allow for the node to appear in the early call region of the
15382 -- subprogram body. This implies that all code from the subprogram
15383 -- body up to the node is preelaborable.
15385 if Nkind
(Unit_Id
) = N_Package_Body
then
15387 -- Find the start of the early call region again assuming that
15388 -- the package spec has pragma Elaborate_Body. Note that the
15389 -- internal data structures are intentionally not updated
15390 -- because this is a speculative search.
15393 Find_Early_Call_Region
15394 (Body_Decl
=> Body_Decl
,
15395 Assume_Elab_Body
=> True,
15396 Skip_Memoization
=> True);
15398 -- If the node appears within the early call region, assuming
15399 -- that the package spec carries pragma Elaborate_Body, then it
15400 -- is safe to suggest the pragma.
15402 if Earlier_In_Extended_Unit
(Region
, N
) then
15403 Error_Msg_Name_1
:= Name_Elaborate_Body
;
15405 ("\consider adding pragma % in spec of unit &",
15406 Error_Nod
, Defining_Entity
(Unit_Id
));
15409 end Suggest_Elaborate_Body
;
15413 FNode
: constant Node_Id
:= Freeze_Node
(Typ
);
15414 Prims
: constant Elist_Id
:= Direct_Primitive_Operations
(Typ
);
15416 Prim_Elmt
: Elmt_Id
;
15418 -- Start of processing for Process_SPARK_Derived_Type
15421 -- A type should have its freeze node set by the time SPARK scenarios
15422 -- are being verified.
15424 pragma Assert
(Present
(FNode
));
15426 -- Verify that the freeze node of the derived type is within the
15427 -- early call region of each overriding primitive body
15428 -- (SPARK RM 7.7(8)).
15430 if Present
(Prims
) then
15431 Prim_Elmt
:= First_Elmt
(Prims
);
15432 while Present
(Prim_Elmt
) loop
15433 Check_Overriding_Primitive
15434 (Prim
=> Node
(Prim_Elmt
),
15437 Next_Elmt
(Prim_Elmt
);
15444 end Process_SPARK_Derived_Type
;
15446 ---------------------------------
15447 -- Process_SPARK_Instantiation --
15448 ---------------------------------
15450 procedure Process_SPARK_Instantiation
15452 Inst_Rep
: Scenario_Rep_Id
;
15453 In_State
: Processing_In_State
)
15455 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
15456 Gen_Rep
: constant Target_Rep_Id
:=
15457 Target_Representation_Of
(Gen_Id
, In_State
);
15458 Body_Decl
: constant Node_Id
:= Body_Declaration
(Gen_Rep
);
15461 -- The instantiation and the generic body are both in the main unit
15463 if Present
(Body_Decl
)
15464 and then In_Extended_Main_Code_Unit
(Body_Decl
)
15466 -- If the instantiation appears prior to the generic body, then the
15467 -- instantiation is illegal (SPARK RM 7.7(6)).
15469 -- IMPORTANT: This check must always be performed even when
15470 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
15471 -- specified because the rule prevents use-before-declaration of
15472 -- objects that may precede the generic body.
15474 and then Earlier_In_Extended_Unit
(Inst
, Body_Decl
)
15477 ("cannot instantiate & before body seen", Inst
, Gen_Id
);
15479 end Process_SPARK_Instantiation
;
15481 ----------------------------
15482 -- Process_SPARK_Scenario --
15483 ----------------------------
15485 procedure Process_SPARK_Scenario
15487 In_State
: Processing_In_State
)
15489 Scen
: constant Node_Id
:= Scenario
(N
);
15492 -- Ensure that a suitable elaboration model is in effect for SPARK
15493 -- rule verification.
15495 Check_SPARK_Model_In_Effect
;
15497 -- Add the current scenario to the stack of active scenarios
15499 Push_Active_Scenario
(Scen
);
15503 if Is_Suitable_SPARK_Derived_Type
(Scen
) then
15504 Process_SPARK_Derived_Type
15506 Typ_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
15507 In_State
=> In_State
);
15511 elsif Is_Suitable_SPARK_Instantiation
(Scen
) then
15512 Process_SPARK_Instantiation
15514 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
15515 In_State
=> In_State
);
15517 -- Refined_State pragma
15519 elsif Is_Suitable_SPARK_Refined_State_Pragma
(Scen
) then
15520 Process_SPARK_Refined_State_Pragma
15522 Prag_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
15523 In_State
=> In_State
);
15526 -- Remove the current scenario from the stack of active scenarios
15527 -- once all ABE diagnostics and checks have been performed.
15529 Pop_Active_Scenario
(Scen
);
15530 end Process_SPARK_Scenario
;
15532 ----------------------------------------
15533 -- Process_SPARK_Refined_State_Pragma --
15534 ----------------------------------------
15536 procedure Process_SPARK_Refined_State_Pragma
15538 Prag_Rep
: Scenario_Rep_Id
;
15539 In_State
: Processing_In_State
)
15541 pragma Unreferenced
(Prag_Rep
);
15543 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
);
15544 pragma Inline
(Check_SPARK_Constituent
);
15545 -- Ensure that a single constituent Constit_Id is elaborated prior to
15548 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
);
15549 pragma Inline
(Check_SPARK_Constituents
);
15550 -- Ensure that all constituents found in list Constits are elaborated
15551 -- prior to the main unit.
15553 procedure Check_SPARK_Initialized_State
(State
: Node_Id
);
15554 pragma Inline
(Check_SPARK_Initialized_State
);
15555 -- Ensure that the constituents of single abstract state State are
15556 -- elaborated prior to the main unit.
15558 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
);
15559 pragma Inline
(Check_SPARK_Initialized_States
);
15560 -- Ensure that the constituents of all abstract states which appear
15561 -- in the Initializes pragma of package Pack_Id are elaborated prior
15562 -- to the main unit.
15564 -----------------------------
15565 -- Check_SPARK_Constituent --
15566 -----------------------------
15568 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
) is
15572 -- Nothing to do for "null" constituents
15574 if Nkind
(Constit_Id
) = N_Null
then
15577 -- Nothing to do for illegal constituents
15579 elsif Error_Posted
(Constit_Id
) then
15583 SM_Prag
:= SPARK_Pragma
(Constit_Id
);
15585 -- The check applies only when the constituent is subject to
15586 -- pragma SPARK_Mode On.
15588 if Present
(SM_Prag
)
15589 and then Get_SPARK_Mode_From_Annotation
(SM_Prag
) = On
15591 -- An external constituent of an abstract state which appears
15592 -- in the Initializes pragma of a package spec imposes an
15593 -- Elaborate requirement on the context of the main unit.
15594 -- Determine whether the context has a pragma strong enough to
15595 -- meet the requirement.
15597 -- IMPORTANT: This check is performed only when -gnatd.v
15598 -- (enforce SPARK elaboration rules in SPARK code) is in effect
15599 -- because the static model can ensure the prior elaboration of
15600 -- the unit which contains a constituent by installing implicit
15601 -- Elaborate pragma.
15603 if Debug_Flag_Dot_V
then
15604 Meet_Elaboration_Requirement
15606 Targ_Id
=> Constit_Id
,
15607 Req_Nam
=> Name_Elaborate
,
15608 In_State
=> In_State
);
15610 -- Otherwise ensure that the unit with the external constituent
15611 -- is elaborated prior to the main unit.
15614 Ensure_Prior_Elaboration
15616 Unit_Id
=> Find_Top_Unit
(Constit_Id
),
15617 Prag_Nam
=> Name_Elaborate
,
15618 In_State
=> In_State
);
15621 end Check_SPARK_Constituent
;
15623 ------------------------------
15624 -- Check_SPARK_Constituents --
15625 ------------------------------
15627 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
) is
15628 Constit_Elmt
: Elmt_Id
;
15631 if Present
(Constits
) then
15632 Constit_Elmt
:= First_Elmt
(Constits
);
15633 while Present
(Constit_Elmt
) loop
15634 Check_SPARK_Constituent
(Node
(Constit_Elmt
));
15635 Next_Elmt
(Constit_Elmt
);
15638 end Check_SPARK_Constituents
;
15640 -----------------------------------
15641 -- Check_SPARK_Initialized_State --
15642 -----------------------------------
15644 procedure Check_SPARK_Initialized_State
(State
: Node_Id
) is
15646 State_Id
: Entity_Id
;
15649 -- Nothing to do for "null" initialization items
15651 if Nkind
(State
) = N_Null
then
15654 -- Nothing to do for illegal states
15656 elsif Error_Posted
(State
) then
15660 State_Id
:= Entity_Of
(State
);
15662 -- Sanitize the state
15664 if No
(State_Id
) then
15667 elsif Error_Posted
(State_Id
) then
15670 elsif Ekind
(State_Id
) /= E_Abstract_State
then
15674 -- The check is performed only when the abstract state is subject
15675 -- to SPARK_Mode On.
15677 SM_Prag
:= SPARK_Pragma
(State_Id
);
15679 if Present
(SM_Prag
)
15680 and then Get_SPARK_Mode_From_Annotation
(SM_Prag
) = On
15682 Check_SPARK_Constituents
(Refinement_Constituents
(State_Id
));
15684 end Check_SPARK_Initialized_State
;
15686 ------------------------------------
15687 -- Check_SPARK_Initialized_States --
15688 ------------------------------------
15690 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
) is
15691 Init_Prag
: constant Node_Id
:=
15692 Get_Pragma
(Pack_Id
, Pragma_Initializes
);
15698 if Present
(Init_Prag
) then
15699 Inits
:= Expression
(Get_Argument
(Init_Prag
, Pack_Id
));
15701 -- Avoid processing a "null" initialization list. The only
15702 -- other alternative is an aggregate.
15704 if Nkind
(Inits
) = N_Aggregate
then
15706 -- The initialization items appear in list form:
15708 -- (state1, state2)
15710 if Present
(Expressions
(Inits
)) then
15711 Init
:= First
(Expressions
(Inits
));
15712 while Present
(Init
) loop
15713 Check_SPARK_Initialized_State
(Init
);
15718 -- The initialization items appear in associated form:
15720 -- (state1 => item1,
15721 -- state2 => (item2, item3))
15723 if Present
(Component_Associations
(Inits
)) then
15724 Init
:= First
(Component_Associations
(Inits
));
15725 while Present
(Init
) loop
15726 Check_SPARK_Initialized_State
(Init
);
15732 end Check_SPARK_Initialized_States
;
15736 Pack_Body
: constant Node_Id
:= Find_Related_Package_Or_Body
(Prag
);
15738 -- Start of processing for Process_SPARK_Refined_State_Pragma
15741 -- Pragma Refined_State must be associated with a package body
15744 (Present
(Pack_Body
) and then Nkind
(Pack_Body
) = N_Package_Body
);
15746 -- Verify that each external contitunent of an abstract state
15747 -- mentioned in pragma Initializes is properly elaborated.
15749 Check_SPARK_Initialized_States
(Unique_Defining_Entity
(Pack_Body
));
15750 end Process_SPARK_Refined_State_Pragma
;
15751 end SPARK_Processor
;
15753 -------------------------------
15754 -- Spec_And_Body_From_Entity --
15755 -------------------------------
15757 procedure Spec_And_Body_From_Entity
15759 Spec_Decl
: out Node_Id
;
15760 Body_Decl
: out Node_Id
)
15763 Spec_And_Body_From_Node
15764 (N
=> Unit_Declaration_Node
(Id
),
15765 Spec_Decl
=> Spec_Decl
,
15766 Body_Decl
=> Body_Decl
);
15767 end Spec_And_Body_From_Entity
;
15769 -----------------------------
15770 -- Spec_And_Body_From_Node --
15771 -----------------------------
15773 procedure Spec_And_Body_From_Node
15775 Spec_Decl
: out Node_Id
;
15776 Body_Decl
: out Node_Id
)
15778 Body_Id
: Entity_Id
;
15779 Spec_Id
: Entity_Id
;
15782 -- Assume that the construct lacks spec and body
15784 Body_Decl
:= Empty
;
15785 Spec_Decl
:= Empty
;
15789 if Nkind
(N
) in N_Package_Body
15791 | N_Subprogram_Body
15794 Spec_Id
:= Corresponding_Spec
(N
);
15796 -- The body completes a previous declaration
15798 if Present
(Spec_Id
) then
15799 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
15801 -- Otherwise the body acts as the initial declaration, and is both a
15802 -- spec and body. There is no need to look for an optional body.
15812 elsif Nkind
(N
) in N_Entry_Declaration
15813 | N_Generic_Package_Declaration
15814 | N_Generic_Subprogram_Declaration
15815 | N_Package_Declaration
15816 | N_Protected_Type_Declaration
15817 | N_Subprogram_Declaration
15818 | N_Task_Type_Declaration
15822 -- Expression function
15824 elsif Nkind
(N
) = N_Expression_Function
then
15825 Spec_Id
:= Corresponding_Spec
(N
);
15826 pragma Assert
(Present
(Spec_Id
));
15828 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
15832 elsif Nkind
(N
) in N_Generic_Instantiation
then
15833 Spec_Decl
:= Instance_Spec
(N
);
15834 pragma Assert
(Present
(Spec_Decl
));
15838 elsif Nkind
(N
) in N_Body_Stub
then
15839 Spec_Id
:= Corresponding_Spec_Of_Stub
(N
);
15841 -- The stub completes a previous declaration
15843 if Present
(Spec_Id
) then
15844 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
15846 -- Otherwise the stub acts as a spec
15853 -- Obtain an optional or mandatory body
15855 if Present
(Spec_Decl
) then
15856 Body_Id
:= Corresponding_Body
(Spec_Decl
);
15858 if Present
(Body_Id
) then
15859 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
15862 end Spec_And_Body_From_Node
;
15864 -------------------------------
15865 -- Static_Elaboration_Checks --
15866 -------------------------------
15868 function Static_Elaboration_Checks
return Boolean is
15870 return not Dynamic_Elaboration_Checks
;
15871 end Static_Elaboration_Checks
;
15877 function Unit_Entity
(Unit_Id
: Entity_Id
) return Entity_Id
is
15878 function Is_Subunit
(Id
: Entity_Id
) return Boolean;
15879 pragma Inline
(Is_Subunit
);
15880 -- Determine whether the entity of an initial declaration denotes a
15887 function Is_Subunit
(Id
: Entity_Id
) return Boolean is
15888 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Id
);
15892 Nkind
(Decl
) in N_Generic_Package_Declaration
15893 | N_Generic_Subprogram_Declaration
15894 | N_Package_Declaration
15895 | N_Protected_Type_Declaration
15896 | N_Subprogram_Declaration
15897 | N_Task_Type_Declaration
15898 and then Present
(Corresponding_Body
(Decl
))
15899 and then Nkind
(Parent
(Unit_Declaration_Node
15900 (Corresponding_Body
(Decl
)))) = N_Subunit
;
15907 -- Start of processing for Unit_Entity
15910 Id
:= Unique_Entity
(Unit_Id
);
15912 -- Skip all subunits found in the scope chain which ends at the input
15915 while Is_Subunit
(Id
) loop
15922 ---------------------------------
15923 -- Update_Elaboration_Scenario --
15924 ---------------------------------
15926 procedure Update_Elaboration_Scenario
(New_N
: Node_Id
; Old_N
: Node_Id
) is
15928 -- Nothing to do when the elaboration phase of the compiler is not
15931 if not Elaboration_Phase_Active
then
15934 -- Nothing to do when the old and new scenarios are one and the same
15936 elsif Old_N
= New_N
then
15940 -- A scenario is being transformed by Atree.Rewrite. Update all relevant
15941 -- internal data structures to reflect this change. This ensures that a
15942 -- potential run-time conditional ABE check or a guaranteed ABE failure
15943 -- is inserted at the proper place in the tree.
15945 if Is_Scenario
(Old_N
) then
15946 Replace_Scenario
(Old_N
, New_N
);
15948 end Update_Elaboration_Scenario
;
15950 ---------------------------------------------------------------------------
15952 -- 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 --
15954 -- M E C H A N I S M --
15956 ---------------------------------------------------------------------------
15958 -- This section contains the implementation of the pre-18.x legacy ABE
15959 -- mechanism. The mechanism can be activated using switch -gnatH (legacy
15960 -- elaboration checking mode enabled).
15962 -----------------------------
15963 -- Description of Approach --
15964 -----------------------------
15966 -- Every non-static call that is encountered by Sem_Res results in a call
15967 -- to Check_Elab_Call, with N being the call node, and Outer set to its
15968 -- default value of True. In addition X'Access is treated like a call
15969 -- for the access-to-procedure case, and in SPARK mode only we also
15970 -- check variable references.
15972 -- The goal of Check_Elab_Call is to determine whether or not the reference
15973 -- in question can generate an access before elaboration error (raising
15974 -- Program_Error) either by directly calling a subprogram whose body
15975 -- has not yet been elaborated, or indirectly, by calling a subprogram
15976 -- whose body has been elaborated, but which contains a call to such a
15979 -- In addition, in SPARK mode, we are checking for a variable reference in
15980 -- another package, which requires an explicit Elaborate_All pragma.
15982 -- The only references that we need to look at the outer level are
15983 -- references that occur in elaboration code. There are two cases. The
15984 -- reference can be at the outer level of elaboration code, or it can
15985 -- be within another unit, e.g. the elaboration code of a subprogram.
15987 -- In the case of an elaboration call at the outer level, we must trace
15988 -- all calls to outer level routines either within the current unit or to
15989 -- other units that are with'ed. For calls within the current unit, we can
15990 -- determine if the body has been elaborated or not, and if it has not,
15991 -- then a warning is generated.
15993 -- Note that there are two subcases. If the original call directly calls a
15994 -- subprogram whose body has not been elaborated, then we know that an ABE
15995 -- will take place, and we replace the call by a raise of Program_Error.
15996 -- If the call is indirect, then we don't know that the PE will be raised,
15997 -- since the call might be guarded by a conditional. In this case we set
15998 -- Do_Elab_Check on the call so that a dynamic check is generated, and
15999 -- output a warning.
16001 -- For calls to a subprogram in a with'ed unit or a 'Access or variable
16002 -- reference (SPARK mode case), we require that a pragma Elaborate_All
16003 -- or pragma Elaborate be present, or that the referenced unit have a
16004 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
16005 -- of these conditions is met, then a warning is generated that a pragma
16006 -- Elaborate_All may be needed (error in the SPARK case), or an implicit
16007 -- pragma is generated.
16009 -- For the case of an elaboration call at some inner level, we are
16010 -- interested in tracing only calls to subprograms at the same level, i.e.
16011 -- those that can be called during elaboration. Any calls to outer level
16012 -- routines cannot cause ABE's as a result of the original call (there
16013 -- might be an outer level call to the subprogram from outside that causes
16014 -- the ABE, but that gets analyzed separately).
16016 -- Note that we never trace calls to inner level subprograms, since these
16017 -- cannot result in ABE's unless there is an elaboration problem at a lower
16018 -- level, which will be separately detected.
16020 -- Note on pragma Elaborate. The checking here assumes that a pragma
16021 -- Elaborate on a with'ed unit guarantees that subprograms within the unit
16022 -- can be called without causing an ABE. This is not in fact the case since
16023 -- pragma Elaborate does not guarantee the transitive coverage guaranteed
16024 -- by Elaborate_All. However, we decide to trust the user in this case.
16026 --------------------------------------
16027 -- Instantiation Elaboration Errors --
16028 --------------------------------------
16030 -- A special case arises when an instantiation appears in a context that is
16031 -- known to be before the body is elaborated, e.g.
16033 -- generic package x is ...
16035 -- package xx is new x;
16037 -- package body x is ...
16039 -- In this situation it is certain that an elaboration error will occur,
16040 -- and an unconditional raise Program_Error statement is inserted before
16041 -- the instantiation, and a warning generated.
16043 -- The problem is that in this case we have no place to put the body of
16044 -- the instantiation. We can't put it in the normal place, because it is
16045 -- too early, and will cause errors to occur as a result of referencing
16046 -- entities before they are declared.
16048 -- Our approach in this case is simply to avoid creating the body of the
16049 -- instantiation in such a case. The instantiation spec is modified to
16050 -- include dummy bodies for all subprograms, so that the resulting code
16051 -- does not contain subprogram specs with no corresponding bodies.
16053 -- The following table records the recursive call chain for output in the
16054 -- Output routine. Each entry records the call node and the entity of the
16055 -- called routine. The number of entries in the table (i.e. the value of
16056 -- Elab_Call.Last) indicates the current depth of recursion and is used to
16057 -- identify the outer level.
16059 type Elab_Call_Element
is record
16064 package Elab_Call
is new Table
.Table
16065 (Table_Component_Type
=> Elab_Call_Element
,
16066 Table_Index_Type
=> Int
,
16067 Table_Low_Bound
=> 1,
16068 Table_Initial
=> 50,
16069 Table_Increment
=> 100,
16070 Table_Name
=> "Elab_Call");
16072 -- The following table records all calls that have been processed starting
16073 -- from an outer level call. The table prevents both infinite recursion and
16074 -- useless reanalysis of calls within the same context. The use of context
16075 -- is important because it allows for proper checks in more complex code:
16078 -- Call; -- requires a check
16079 -- Call; -- does not need a check thanks to the table
16081 -- Call; -- requires a check, different context
16084 -- Call; -- requires a check, different context
16086 type Visited_Element
is record
16087 Subp_Id
: Entity_Id
;
16088 -- The entity of the subprogram being called
16091 -- The context where the call to the subprogram occurs
16094 package Elab_Visited
is new Table
.Table
16095 (Table_Component_Type
=> Visited_Element
,
16096 Table_Index_Type
=> Int
,
16097 Table_Low_Bound
=> 1,
16098 Table_Initial
=> 200,
16099 Table_Increment
=> 100,
16100 Table_Name
=> "Elab_Visited");
16102 -- The following table records delayed calls which must be examined after
16103 -- all generic bodies have been instantiated.
16105 type Delay_Element
is record
16107 -- The parameter N from the call to Check_Internal_Call. Note that this
16108 -- node may get rewritten over the delay period by expansion in the call
16109 -- case (but not in the instantiation case).
16112 -- The parameter E from the call to Check_Internal_Call
16114 Orig_Ent
: Entity_Id
;
16115 -- The parameter Orig_Ent from the call to Check_Internal_Call
16117 Curscop
: Entity_Id
;
16118 -- The current scope of the call. This is restored when we complete the
16119 -- delayed call, so that we do this in the right scope.
16121 Outer_Scope
: Entity_Id
;
16122 -- Save scope of outer level call
16124 From_Elab_Code
: Boolean;
16125 -- Save indication of whether this call is from elaboration code
16127 In_Task_Activation
: Boolean;
16128 -- Save indication of whether this call is from a task body. Tasks are
16129 -- activated at the "begin", which is after all local procedure bodies,
16130 -- so calls to those procedures can't fail, even if they occur after the
16133 From_SPARK_Code
: Boolean;
16134 -- Save indication of whether this call is under SPARK_Mode => On
16137 package Delay_Check
is new Table
.Table
16138 (Table_Component_Type
=> Delay_Element
,
16139 Table_Index_Type
=> Int
,
16140 Table_Low_Bound
=> 1,
16141 Table_Initial
=> 1000,
16142 Table_Increment
=> 100,
16143 Table_Name
=> "Delay_Check");
16145 C_Scope
: Entity_Id
;
16146 -- Top-level scope of current scope. Compute this only once at the outer
16147 -- level, i.e. for a call to Check_Elab_Call from outside this unit.
16149 Outer_Level_Sloc
: Source_Ptr
;
16150 -- Save Sloc value for outer level call node for comparisons of source
16151 -- locations. A body is too late if it appears after the *outer* level
16152 -- call, not the particular call that is being analyzed.
16154 From_Elab_Code
: Boolean;
16155 -- This flag shows whether the outer level call currently being examined
16156 -- is or is not in elaboration code. We are only interested in calls to
16157 -- routines in other units if this flag is True.
16159 In_Task_Activation
: Boolean := False;
16160 -- This flag indicates whether we are performing elaboration checks on task
16161 -- bodies, at the point of activation. If true, we do not raise
16162 -- Program_Error for calls to local procedures, because all local bodies
16163 -- are known to be elaborated. However, we still need to trace such calls,
16164 -- because a local procedure could call a procedure in another package,
16165 -- so we might need an implicit Elaborate_All.
16167 Delaying_Elab_Checks
: Boolean := True;
16168 -- This is set True till the compilation is complete, including the
16169 -- insertion of all instance bodies. Then when Check_Elab_Calls is called,
16170 -- the delay table is used to make the delayed calls and this flag is reset
16171 -- to False, so that the calls are processed.
16173 -----------------------
16174 -- Local Subprograms --
16175 -----------------------
16177 -- Note: Outer_Scope in all following specs represents the scope of
16178 -- interest of the outer level call. If it is set to Standard_Standard,
16179 -- then it means the outer level call was at elaboration level, and that
16180 -- thus all calls are of interest. If it was set to some other scope,
16181 -- then the original call was an inner call, and we are not interested
16182 -- in calls that go outside this scope.
16184 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
);
16185 -- Analysis of construct N shows that we should set Elaborate_All_Desirable
16186 -- for the WITH clause for unit U (which will always be present). A special
16187 -- case is when N is a function or procedure instantiation, in which case
16188 -- it is sufficient to set Elaborate_Desirable, since in this case there is
16189 -- no possibility of transitive elaboration issues.
16191 procedure Check_A_Call
16194 Outer_Scope
: Entity_Id
;
16195 Inter_Unit_Only
: Boolean;
16196 Generate_Warnings
: Boolean := True;
16197 In_Init_Proc
: Boolean := False);
16198 -- This is the internal recursive routine that is called to check for
16199 -- possible elaboration error. The argument N is a subprogram call or
16200 -- generic instantiation, or 'Access attribute reference to be checked, and
16201 -- E is the entity of the called subprogram, or instantiated generic unit,
16202 -- or subprogram referenced by 'Access.
16204 -- In SPARK mode, N can also be a variable reference, since in SPARK this
16205 -- also triggers a requirement for Elaborate_All, and in this case E is the
16206 -- entity being referenced.
16208 -- Outer_Scope is the outer level scope for the original reference.
16209 -- Inter_Unit_Only is set if the call is only to be checked in the
16210 -- case where it is to another unit (and skipped if within a unit).
16211 -- Generate_Warnings is set to False to suppress warning messages about
16212 -- missing pragma Elaborate_All's. These messages are not wanted for
16213 -- inner calls in the dynamic model. Note that an instance of the Access
16214 -- attribute applied to a subprogram also generates a call to this
16215 -- procedure (since the referenced subprogram may be called later
16216 -- indirectly). Flag In_Init_Proc should be set whenever the current
16217 -- context is a type init proc.
16219 -- Note: this might better be called Check_A_Reference to recognize the
16220 -- variable case for SPARK, but we prefer to retain the historical name
16221 -- since in practice this is mostly about checking calls for the possible
16222 -- occurrence of an access-before-elaboration exception.
16224 procedure Check_Bad_Instantiation
(N
: Node_Id
);
16225 -- N is a node for an instantiation (if called with any other node kind,
16226 -- Check_Bad_Instantiation ignores the call). This subprogram checks for
16227 -- the special case of a generic instantiation of a generic spec in the
16228 -- same declarative part as the instantiation where a body is present and
16229 -- has not yet been seen. This is an obvious error, but needs to be checked
16230 -- specially at the time of the instantiation, since it is a case where we
16231 -- cannot insert the body anywhere. If this case is detected, warnings are
16232 -- generated, and a raise of Program_Error is inserted. In addition any
16233 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation
16234 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this
16235 -- flag as an indication that no attempt should be made to insert an
16238 procedure Check_Internal_Call
16241 Outer_Scope
: Entity_Id
;
16242 Orig_Ent
: Entity_Id
);
16243 -- N is a function call or procedure statement call node and E is the
16244 -- entity of the called function, which is within the current compilation
16245 -- unit (where subunits count as part of the parent). This call checks if
16246 -- this call, or any call within any accessed body could cause an ABE, and
16247 -- if so, outputs a warning. Orig_Ent differs from E only in the case of
16248 -- renamings, and points to the original name of the entity. This is used
16249 -- for error messages. Outer_Scope is the outer level scope for the
16252 procedure Check_Internal_Call_Continue
16255 Outer_Scope
: Entity_Id
;
16256 Orig_Ent
: Entity_Id
);
16257 -- The processing for Check_Internal_Call is divided up into two phases,
16258 -- and this represents the second phase. The second phase is delayed if
16259 -- Delaying_Elab_Checks is set to True. In this delayed case, the first
16260 -- phase makes an entry in the Delay_Check table, which is processed when
16261 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
16262 -- Check_Internal_Call. Outer_Scope is the outer level scope for the
16265 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
;
16266 -- N is either a function or procedure call or an access attribute that
16267 -- references a subprogram. This call retrieves the relevant entity. If
16268 -- this is a call to a protected subprogram, the entity is a selected
16269 -- component. The callable entity may be absent, in which case Empty is
16270 -- returned. This happens with non-analyzed calls in nested generics.
16272 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable
16273 -- entity, in which case, the value returned is simply this entity.
16275 function Has_Generic_Body
(N
: Node_Id
) return Boolean;
16276 -- N is a generic package instantiation node, and this routine determines
16277 -- if this package spec does in fact have a generic body. If so, then
16278 -- True is returned, otherwise False. Note that this is not at all the
16279 -- same as checking if the unit requires a body, since it deals with
16280 -- the case of optional bodies accurately (i.e. if a body is optional,
16281 -- then it looks to see if a body is actually present). Note: this
16282 -- function can only do a fully correct job if in generating code mode
16283 -- where all bodies have to be present. If we are operating in semantics
16284 -- check only mode, then in some cases of optional bodies, a result of
16285 -- False may incorrectly be given. In practice this simply means that
16286 -- some cases of warnings for incorrect order of elaboration will only
16287 -- be given when generating code, which is not a big problem (and is
16288 -- inevitable, given the optional body semantics of Ada).
16290 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
);
16291 -- Given code for an elaboration check (or unconditional raise if the check
16292 -- is not needed), inserts the code in the appropriate place. N is the call
16293 -- or instantiation node for which the check code is required. C is the
16294 -- test whose failure triggers the raise.
16296 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean;
16297 -- Returns True if node N is a call to a generic formal subprogram
16299 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean;
16300 -- Determine whether entity Id denotes a [Deep_]Finalize procedure
16302 procedure Output_Calls
16304 Check_Elab_Flag
: Boolean);
16305 -- Outputs chain of calls stored in the Elab_Call table. The caller has
16306 -- already generated the main warning message, so the warnings generated
16307 -- are all continuation messages. The argument is the call node at which
16308 -- the messages are to be placed. When Check_Elab_Flag is set, calls are
16309 -- enumerated only when flag Elab_Warning is set for the dynamic case or
16310 -- when flag Elab_Info_Messages is set for the static case.
16312 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean;
16313 -- Given two scopes, determine whether they are the same scope from an
16314 -- elaboration point of view, i.e. packages and blocks are ignored.
16316 procedure Set_C_Scope
;
16317 -- On entry C_Scope is set to some scope. On return, C_Scope is reset
16318 -- to be the enclosing compilation unit of this scope.
16320 procedure Set_Elaboration_Constraint
16324 -- The current unit U may depend semantically on some unit P that is not
16325 -- in the current context. If there is an elaboration call that reaches P,
16326 -- we need to indicate that P requires an Elaborate_All, but this is not
16327 -- effective in U's ali file, if there is no with_clause for P. In this
16328 -- case we add the Elaborate_All on the unit Q that directly or indirectly
16329 -- makes P available. This can happen in two cases:
16331 -- a) Q declares a subtype of a type declared in P, and the call is an
16332 -- initialization call for an object of that subtype.
16334 -- b) Q declares an object of some tagged type whose root type is
16335 -- declared in P, and the initialization call uses object notation on
16336 -- that object to reach a primitive operation or a classwide operation
16339 -- If P appears in the context of U, the current processing is correct.
16340 -- Otherwise we must identify these two cases to retrieve Q and place the
16341 -- Elaborate_All_Desirable on it.
16343 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
;
16344 -- Given a compilation unit entity, if it is a spec entity, it is returned
16345 -- unchanged. If it is a body entity, then the spec for the corresponding
16346 -- spec is returned
16348 function Within
(E1
, E2
: Entity_Id
) return Boolean;
16349 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
16350 -- of its contained scopes, False otherwise.
16352 function Within_Elaborate_All
16353 (Unit
: Unit_Number_Type
;
16354 E
: Entity_Id
) return Boolean;
16355 -- Return True if we are within the scope of an Elaborate_All for E, or if
16356 -- we are within the scope of an Elaborate_All for some other unit U, and U
16357 -- with's E. This prevents spurious warnings when the called entity is
16358 -- renamed within U, or in case of generic instances.
16360 --------------------------------------
16361 -- Activate_Elaborate_All_Desirable --
16362 --------------------------------------
16364 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
) is
16365 UN
: constant Unit_Number_Type
:= Get_Code_Unit
(N
);
16366 CU
: constant Node_Id
:= Cunit
(UN
);
16367 UE
: constant Entity_Id
:= Cunit_Entity
(UN
);
16368 Unm
: constant Unit_Name_Type
:= Unit_Name
(UN
);
16369 CI
: constant List_Id
:= Context_Items
(CU
);
16373 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
);
16374 -- This procedure is called when the elaborate indication must be
16375 -- applied to a unit not in the context of the referencing unit. The
16376 -- unit gets added to the context as an implicit with.
16378 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean;
16379 -- UEs is the spec entity of a unit. If the unit to be marked is
16380 -- in the context item list of this unit spec, then the call returns
16381 -- True and Itm is left set to point to the relevant N_With_Clause node.
16383 procedure Set_Elab_Flag
(Itm
: Node_Id
);
16384 -- Sets Elaborate_[All_]Desirable as appropriate on Itm
16386 -----------------------------
16387 -- Add_To_Context_And_Mark --
16388 -----------------------------
16390 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
) is
16391 CW
: constant Node_Id
:=
16392 Make_With_Clause
(Sloc
(Itm
),
16393 Name
=> Name
(Itm
));
16396 Set_Library_Unit
(CW
, Library_Unit
(Itm
));
16397 Set_Implicit_With
(CW
);
16399 -- Set elaborate all desirable on copy and then append the copy to
16400 -- the list of body with's and we are done.
16402 Set_Elab_Flag
(CW
);
16403 Append_To
(CI
, CW
);
16404 end Add_To_Context_And_Mark
;
16410 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean is
16411 UNs
: constant Unit_Number_Type
:= Get_Source_Unit
(UEs
);
16412 CUs
: constant Node_Id
:= Cunit
(UNs
);
16413 CIs
: constant List_Id
:= Context_Items
(CUs
);
16416 Itm
:= First
(CIs
);
16417 while Present
(Itm
) loop
16418 if Nkind
(Itm
) = N_With_Clause
then
16420 Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
16433 -------------------
16434 -- Set_Elab_Flag --
16435 -------------------
16437 procedure Set_Elab_Flag
(Itm
: Node_Id
) is
16439 if Nkind
(N
) in N_Subprogram_Instantiation
then
16440 Set_Elaborate_Desirable
(Itm
);
16442 Set_Elaborate_All_Desirable
(Itm
);
16446 -- Start of processing for Activate_Elaborate_All_Desirable
16449 -- Do not set binder indication if expansion is disabled, as when
16450 -- compiling a generic unit.
16452 if not Expander_Active
then
16456 -- If an instance of a generic package contains a controlled object (so
16457 -- we're calling Initialize at elaboration time), and the instance is in
16458 -- a package body P that says "with P;", then we need to return without
16459 -- adding "pragma Elaborate_All (P);" to P.
16461 if U
= Main_Unit_Entity
then
16466 while Present
(Itm
) loop
16467 if Nkind
(Itm
) = N_With_Clause
then
16468 Ent
:= Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
16470 -- If we find it, then mark elaborate all desirable and return
16473 Set_Elab_Flag
(Itm
);
16481 -- If we fall through then the with clause is not present in the
16482 -- current unit. One legitimate possibility is that the with clause
16483 -- is present in the spec when we are a body.
16485 if Is_Body_Name
(Unm
)
16486 and then In_Withs_Of
(Spec_Entity
(UE
))
16488 Add_To_Context_And_Mark
(Itm
);
16492 -- Similarly, we may be in the spec or body of a child unit, where
16493 -- the unit in question is with'ed by some ancestor of the child unit.
16495 if Is_Child_Name
(Unm
) then
16502 Pkg
:= Scope
(Pkg
);
16503 exit when Pkg
= Standard_Standard
;
16505 if In_Withs_Of
(Pkg
) then
16506 Add_To_Context_And_Mark
(Itm
);
16513 -- Here if we do not find with clause on spec or body. We just ignore
16514 -- this case; it means that the elaboration involves some other unit
16515 -- than the unit being compiled, and will be caught elsewhere.
16516 end Activate_Elaborate_All_Desirable
;
16522 procedure Check_A_Call
16525 Outer_Scope
: Entity_Id
;
16526 Inter_Unit_Only
: Boolean;
16527 Generate_Warnings
: Boolean := True;
16528 In_Init_Proc
: Boolean := False)
16530 Access_Case
: constant Boolean := Nkind
(N
) = N_Attribute_Reference
;
16531 -- Indicates if we have Access attribute case
16533 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean;
16534 -- True if we're calling an instance of a generic subprogram, or a
16535 -- subprogram in an instance of a generic package, and the call is
16536 -- outside that instance.
16538 procedure Elab_Warning
16541 Ent
: Node_Or_Entity_Id
);
16542 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
16543 -- dynamic or static elaboration model), N and Ent. Msg_D is a real
16544 -- warning (output if Msg_D is non-null and Elab_Warnings is set),
16545 -- Msg_S is an info message (output if Elab_Info_Messages is set).
16547 function Find_W_Scope
return Entity_Id
;
16548 -- Find top-level scope for called entity (not following renamings
16549 -- or derivations). This is where the Elaborate_All will go if it is
16550 -- needed. We start with the called entity, except in the case of an
16551 -- initialization procedure outside the current package, where the init
16552 -- proc is in the root package, and we start from the entity of the name
16555 -----------------------------------
16556 -- Call_To_Instance_From_Outside --
16557 -----------------------------------
16559 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean is
16560 Scop
: Entity_Id
:= Id
;
16564 if Scop
= Standard_Standard
then
16568 if Is_Generic_Instance
(Scop
) then
16569 return not In_Open_Scopes
(Scop
);
16572 Scop
:= Scope
(Scop
);
16574 end Call_To_Instance_From_Outside
;
16580 procedure Elab_Warning
16583 Ent
: Node_Or_Entity_Id
)
16586 -- Dynamic elaboration checks, real warning
16588 if Dynamic_Elaboration_Checks
then
16589 if not Access_Case
then
16590 if Msg_D
/= "" and then Elab_Warnings
then
16591 Error_Msg_NE
(Msg_D
, N
, Ent
);
16594 -- In the access case emit first warning message as well,
16595 -- otherwise list of calls will appear as errors.
16597 elsif Elab_Warnings
then
16598 Error_Msg_NE
(Msg_S
, N
, Ent
);
16601 -- Static elaboration checks, info message
16604 if Elab_Info_Messages
then
16605 Error_Msg_NE
(Msg_S
, N
, Ent
);
16614 function Find_W_Scope
return Entity_Id
is
16615 Refed_Ent
: constant Entity_Id
:= Get_Referenced_Ent
(N
);
16616 W_Scope
: Entity_Id
;
16619 if Is_Init_Proc
(Refed_Ent
)
16620 and then not In_Same_Extended_Unit
(N
, Refed_Ent
)
16622 W_Scope
:= Scope
(Refed_Ent
);
16627 -- Now loop through scopes to get to the enclosing compilation unit
16629 while not Is_Compilation_Unit
(W_Scope
) loop
16630 W_Scope
:= Scope
(W_Scope
);
16638 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
16639 -- Indicates if we have instantiation case
16641 Loc
: constant Source_Ptr
:= Sloc
(N
);
16643 Variable_Case
: constant Boolean :=
16644 Nkind
(N
) in N_Has_Entity
16645 and then Present
(Entity
(N
))
16646 and then Ekind
(Entity
(N
)) = E_Variable
;
16647 -- Indicates if we have variable reference case
16649 W_Scope
: constant Entity_Id
:= Find_W_Scope
;
16650 -- Top-level scope of directly called entity for subprogram. This
16651 -- differs from E_Scope in the case where renamings or derivations
16652 -- are involved, since it does not follow these links. W_Scope is
16653 -- generally in a visible unit, and it is this scope that may require
16654 -- an Elaborate_All. However, there are some cases (initialization
16655 -- calls and calls involving object notation) where W_Scope might not
16656 -- be in the context of the current unit, and there is an intermediate
16657 -- package that is, in which case the Elaborate_All has to be placed
16658 -- on this intermediate package. These special cases are handled in
16659 -- Set_Elaboration_Constraint.
16662 Callee_Unit_Internal
: Boolean;
16663 Caller_Unit_Internal
: Boolean;
16665 Inst_Callee
: Source_Ptr
;
16666 Inst_Caller
: Source_Ptr
;
16667 Unit_Callee
: Unit_Number_Type
;
16668 Unit_Caller
: Unit_Number_Type
;
16670 Body_Acts_As_Spec
: Boolean;
16671 -- Set to true if call is to body acting as spec (no separate spec)
16673 Cunit_SC
: Boolean := False;
16674 -- Set to suppress dynamic elaboration checks where one of the
16675 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
16676 -- if a pragma Elaborate[_All] applies to that scope, in which case
16677 -- warnings on the scope are also suppressed. For the internal case,
16678 -- we ignore this flag.
16680 E_Scope
: Entity_Id
;
16681 -- Top-level scope of entity for called subprogram. This value includes
16682 -- following renamings and derivations, so this scope can be in a
16683 -- non-visible unit. This is the scope that is to be investigated to
16684 -- see whether an elaboration check is required.
16687 -- Flag set when the subprogram being invoked is the procedure generated
16688 -- for pragma Default_Initial_Condition.
16690 SPARK_Elab_Errors
: Boolean;
16691 -- Flag set when an entity is called or a variable is read during SPARK
16692 -- dynamic elaboration.
16694 -- Start of processing for Check_A_Call
16697 -- If the call is known to be within a local Suppress Elaboration
16698 -- pragma, nothing to check. This can happen in task bodies. But
16699 -- we ignore this for a call to a generic formal.
16701 if Nkind
(N
) in N_Subprogram_Call
16702 and then No_Elaboration_Check
(N
)
16703 and then not Is_Call_Of_Generic_Formal
(N
)
16707 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to
16708 -- check, we don't mind in this case if the call occurs before the body
16709 -- since this is all generated code.
16711 elsif Nkind
(Original_Node
(N
)) = N_Attribute_Reference
16712 and then Attribute_Name
(Original_Node
(N
)) = Name_Valid_Scalars
16716 -- Intrinsics such as instances of Unchecked_Deallocation do not have
16717 -- any body, so elaboration checking is not needed, and would be wrong.
16719 elsif Is_Intrinsic_Subprogram
(E
) then
16722 -- Do not consider references to internal variables for SPARK semantics
16724 elsif Variable_Case
and then not Comes_From_Source
(E
) then
16728 -- Proceed with check
16732 -- For a variable reference, just set Body_Acts_As_Spec to False
16734 if Variable_Case
then
16735 Body_Acts_As_Spec
:= False;
16737 -- Additional checks for all other cases
16740 -- Go to parent for derived subprogram, or to original subprogram in
16741 -- the case of a renaming (Alias covers both these cases).
16744 if (Suppress_Elaboration_Warnings
(Ent
)
16745 or else Elaboration_Checks_Suppressed
(Ent
))
16746 and then (Inst_Case
or else No
(Alias
(Ent
)))
16751 -- Nothing to do for imported entities
16753 if Is_Imported
(Ent
) then
16757 exit when Inst_Case
or else No
(Alias
(Ent
));
16758 Ent
:= Alias
(Ent
);
16761 Decl
:= Unit_Declaration_Node
(Ent
);
16763 if Nkind
(Decl
) = N_Subprogram_Body
then
16764 Body_Acts_As_Spec
:= True;
16766 elsif Nkind
(Decl
) in
16767 N_Subprogram_Declaration | N_Subprogram_Body_Stub
16770 Body_Acts_As_Spec
:= False;
16772 -- If we have none of an instantiation, subprogram body or subprogram
16773 -- declaration, or in the SPARK case, a variable reference, then
16774 -- it is not a case that we want to check. (One case is a call to a
16775 -- generic formal subprogram, where we do not want the check in the
16785 if Elaboration_Checks_Suppressed
(E_Scope
)
16786 or else Suppress_Elaboration_Warnings
(E_Scope
)
16791 -- Exit when we get to compilation unit, not counting subunits
16793 exit when Is_Compilation_Unit
(E_Scope
)
16794 and then (Is_Child_Unit
(E_Scope
)
16795 or else Scope
(E_Scope
) = Standard_Standard
);
16797 pragma Assert
(E_Scope
/= Standard_Standard
);
16799 -- Move up a scope looking for compilation unit
16801 E_Scope
:= Scope
(E_Scope
);
16804 -- No checks needed for pure or preelaborated compilation units
16806 if Is_Pure
(E_Scope
) or else Is_Preelaborated
(E_Scope
) then
16810 -- If the generic entity is within a deeper instance than we are, then
16811 -- either the instantiation to which we refer itself caused an ABE, in
16812 -- which case that will be handled separately, or else we know that the
16813 -- body we need appears as needed at the point of the instantiation.
16814 -- However, this assumption is only valid if we are in static mode.
16816 if not Dynamic_Elaboration_Checks
16818 Instantiation_Depth
(Sloc
(Ent
)) > Instantiation_Depth
(Sloc
(N
))
16823 -- Do not give a warning for a package with no body
16825 if Ekind
(Ent
) = E_Generic_Package
and then not Has_Generic_Body
(N
) then
16829 -- Case of entity is in same unit as call or instantiation. In the
16830 -- instantiation case, W_Scope may be different from E_Scope; we want
16831 -- the unit in which the instantiation occurs, since we're analyzing
16832 -- based on the expansion.
16834 if W_Scope
= C_Scope
then
16835 if not Inter_Unit_Only
then
16836 Check_Internal_Call
(N
, Ent
, Outer_Scope
, E
);
16842 -- Case of entity is not in current unit (i.e. with'ed unit case)
16844 -- We are only interested in such calls if the outer call was from
16845 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
16847 if not From_Elab_Code
and then not Dynamic_Elaboration_Checks
then
16851 -- Nothing to do if some scope said that no checks were required
16857 -- Nothing to do for a generic instance, because a call to an instance
16858 -- cannot fail the elaboration check, because the body of the instance
16859 -- is always elaborated immediately after the spec.
16861 if Call_To_Instance_From_Outside
(Ent
) then
16865 -- Nothing to do if subprogram with no separate spec. However, a call
16866 -- to Deep_Initialize may result in a call to a user-defined Initialize
16867 -- procedure, which imposes a body dependency. This happens only if the
16868 -- type is controlled and the Initialize procedure is not inherited.
16870 if Body_Acts_As_Spec
then
16871 if Is_TSS
(Ent
, TSS_Deep_Initialize
) then
16873 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Ent
));
16877 if not Is_Controlled
(Typ
) then
16880 Init
:= Find_Controlled_Prim_Op
(Typ
, Name_Initialize
);
16882 if Comes_From_Source
(Init
) then
16895 -- Check cases of internal units
16897 Callee_Unit_Internal
:= In_Internal_Unit
(E_Scope
);
16899 -- Do not give a warning if the with'ed unit is internal and this is
16900 -- the generic instantiation case (this saves a lot of hassle dealing
16901 -- with the Text_IO special child units)
16903 if Callee_Unit_Internal
and Inst_Case
then
16907 if C_Scope
= Standard_Standard
then
16908 Caller_Unit_Internal
:= False;
16910 Caller_Unit_Internal
:= In_Internal_Unit
(C_Scope
);
16913 -- Do not give a warning if the with'ed unit is internal and the caller
16914 -- is not internal (since the binder always elaborates internal units
16917 if Callee_Unit_Internal
and not Caller_Unit_Internal
then
16921 -- For now, if debug flag -gnatdE is not set, do no checking for one
16922 -- internal unit withing another. This fixes the problem with the sgi
16923 -- build and storage errors. To be resolved later ???
16925 if (Callee_Unit_Internal
and Caller_Unit_Internal
)
16926 and not Debug_Flag_EE
16931 if Is_TSS
(E
, TSS_Deep_Initialize
) then
16935 -- If the call is in an instance, and the called entity is not
16936 -- defined in the same instance, then the elaboration issue focuses
16937 -- around the unit containing the template, it is this unit that
16938 -- requires an Elaborate_All.
16940 -- However, if we are doing dynamic elaboration, we need to chase the
16941 -- call in the usual manner.
16943 -- We also need to chase the call in the usual manner if it is a call
16944 -- to a generic formal parameter, since that case was not handled as
16945 -- part of the processing of the template.
16947 Inst_Caller
:= Instantiation
(Get_Source_File_Index
(Sloc
(N
)));
16948 Inst_Callee
:= Instantiation
(Get_Source_File_Index
(Sloc
(Ent
)));
16950 if Inst_Caller
= No_Location
then
16951 Unit_Caller
:= No_Unit
;
16953 Unit_Caller
:= Get_Source_Unit
(N
);
16956 if Inst_Callee
= No_Location
then
16957 Unit_Callee
:= No_Unit
;
16959 Unit_Callee
:= Get_Source_Unit
(Ent
);
16962 if Unit_Caller
/= No_Unit
16963 and then Unit_Callee
/= Unit_Caller
16964 and then not Dynamic_Elaboration_Checks
16965 and then not Is_Call_Of_Generic_Formal
(N
)
16967 E_Scope
:= Spec_Entity
(Cunit_Entity
(Unit_Caller
));
16969 -- If we don't get a spec entity, just ignore call. Not quite
16970 -- clear why this check is necessary. ???
16972 if No
(E_Scope
) then
16976 -- Otherwise step to enclosing compilation unit
16978 while not Is_Compilation_Unit
(E_Scope
) loop
16979 E_Scope
:= Scope
(E_Scope
);
16982 -- For the case where N is not an instance, and is not a call within
16983 -- instance to other than a generic formal, we recompute E_Scope
16984 -- for the error message, since we do NOT want to go to the unit
16985 -- that has the ultimate declaration in the case of renaming and
16986 -- derivation and we also want to go to the generic unit in the
16987 -- case of an instance, and no further.
16990 -- Loop to carefully follow renamings and derivations one step
16991 -- outside the current unit, but not further.
16993 if not (Inst_Case
or Variable_Case
)
16994 and then Present
(Alias
(Ent
))
16996 E_Scope
:= Alias
(Ent
);
17002 while not Is_Compilation_Unit
(E_Scope
) loop
17003 E_Scope
:= Scope
(E_Scope
);
17006 -- If E_Scope is the same as C_Scope, it means that there
17007 -- definitely was a local renaming or derivation, and we
17008 -- are not yet out of the current unit.
17010 exit when E_Scope
/= C_Scope
;
17011 Ent
:= Alias
(Ent
);
17014 -- If no alias, there could be a previous error, but not if we've
17015 -- already reached the outermost level (Standard).
17023 if Within_Elaborate_All
(Current_Sem_Unit
, E_Scope
) then
17027 -- Determine whether the Default_Initial_Condition procedure of some
17028 -- type is being invoked.
17030 Is_DIC
:= Ekind
(Ent
) = E_Procedure
and then Is_DIC_Procedure
(Ent
);
17032 -- Checks related to Default_Initial_Condition fall under the SPARK
17033 -- umbrella because this is a SPARK-specific annotation.
17035 SPARK_Elab_Errors
:=
17036 SPARK_Mode
= On
and (Is_DIC
or Dynamic_Elaboration_Checks
);
17038 -- Now check if an Elaborate_All (or dynamic check) is needed
17040 if (Elab_Info_Messages
or Elab_Warnings
or SPARK_Elab_Errors
)
17041 and then Generate_Warnings
17042 and then not Suppress_Elaboration_Warnings
(Ent
)
17043 and then not Elaboration_Checks_Suppressed
(Ent
)
17044 and then not Suppress_Elaboration_Warnings
(E_Scope
)
17045 and then not Elaboration_Checks_Suppressed
(E_Scope
)
17047 -- Instantiation case
17050 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
17052 ("instantiation of & during elaboration in SPARK", N
, Ent
);
17055 ("instantiation of & may raise Program_Error?l?",
17056 "info: instantiation of & during elaboration?$?", Ent
);
17059 -- Indirect call case, info message only in static elaboration
17060 -- case, because the attribute reference itself cannot raise an
17061 -- exception. Note that SPARK does not permit indirect calls.
17063 elsif Access_Case
then
17064 Elab_Warning
("", "info: access to & during elaboration?$?", Ent
);
17066 -- Variable reference in SPARK mode
17068 elsif Variable_Case
then
17069 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
17071 ("reference to & during elaboration in SPARK", N
, Ent
);
17074 -- Subprogram call case
17077 if Nkind
(Name
(N
)) in N_Has_Entity
17078 and then Is_Init_Proc
(Entity
(Name
(N
)))
17079 and then Comes_From_Source
(Ent
)
17082 ("implicit call to & may raise Program_Error?l?",
17083 "info: implicit call to & during elaboration?$?",
17086 elsif SPARK_Elab_Errors
then
17088 -- Emit a specialized error message when the elaboration of an
17089 -- object of a private type evaluates the expression of pragma
17090 -- Default_Initial_Condition. This prevents the internal name
17091 -- of the procedure from appearing in the error message.
17095 ("call to Default_Initial_Condition during elaboration in "
17099 ("call to & during elaboration in SPARK", N
, Ent
);
17104 ("call to & may raise Program_Error?l?",
17105 "info: call to & during elaboration?$?",
17110 Error_Msg_Qual_Level
:= Nat
'Last;
17112 -- Case of Elaborate_All not present and required, for SPARK this
17113 -- is an error, so give an error message.
17115 if SPARK_Elab_Errors
then
17116 Error_Msg_NE
-- CODEFIX
17117 ("\Elaborate_All pragma required for&", N
, W_Scope
);
17119 -- Otherwise we generate an implicit pragma. For a subprogram
17120 -- instantiation, Elaborate is good enough, since no transitive
17121 -- call is possible at elaboration time in this case.
17123 elsif Nkind
(N
) in N_Subprogram_Instantiation
then
17125 ("\missing pragma Elaborate for&?l?",
17126 "\implicit pragma Elaborate for& generated?$?",
17129 -- For all other cases, we need an implicit Elaborate_All
17133 ("\missing pragma Elaborate_All for&?l?",
17134 "\implicit pragma Elaborate_All for & generated?$?",
17138 Error_Msg_Qual_Level
:= 0;
17140 -- Take into account the flags related to elaboration warning
17141 -- messages when enumerating the various calls involved. This
17142 -- ensures the proper pairing of the main warning and the
17143 -- clarification messages generated by Output_Calls.
17145 Output_Calls
(N
, Check_Elab_Flag
=> True);
17147 -- Set flag to prevent further warnings for same unit unless in
17148 -- All_Errors_Mode.
17150 if not All_Errors_Mode
and not Dynamic_Elaboration_Checks
then
17151 Set_Suppress_Elaboration_Warnings
(W_Scope
);
17155 -- Check for runtime elaboration check required
17157 if Dynamic_Elaboration_Checks
then
17158 if not Elaboration_Checks_Suppressed
(Ent
)
17159 and then not Elaboration_Checks_Suppressed
(W_Scope
)
17160 and then not Elaboration_Checks_Suppressed
(E_Scope
)
17161 and then not Cunit_SC
17163 -- Runtime elaboration check required. Generate check of the
17164 -- elaboration Boolean for the unit containing the entity.
17166 -- Note that for this case, we do check the real unit (the one
17167 -- from following renamings, since that is the issue).
17169 -- Could this possibly miss a useless but required PE???
17171 Insert_Elab_Check
(N
,
17172 Make_Attribute_Reference
(Loc
,
17173 Attribute_Name
=> Name_Elaborated
,
17175 New_Occurrence_Of
(Spec_Entity
(E_Scope
), Loc
)));
17177 -- Prevent duplicate elaboration checks on the same call, which
17178 -- can happen if the body enclosing the call appears itself in a
17179 -- call whose elaboration check is delayed.
17181 if Nkind
(N
) in N_Subprogram_Call
then
17182 Set_No_Elaboration_Check
(N
);
17186 -- Case of static elaboration model
17189 -- Do not do anything if elaboration checks suppressed. Note that
17190 -- we check Ent here, not E, since we want the real entity for the
17191 -- body to see if checks are suppressed for it, not the dummy
17192 -- entry for renamings or derivations.
17194 if Elaboration_Checks_Suppressed
(Ent
)
17195 or else Elaboration_Checks_Suppressed
(E_Scope
)
17196 or else Elaboration_Checks_Suppressed
(W_Scope
)
17200 -- Do not generate an Elaborate_All for finalization routines
17201 -- that perform partial clean up as part of initialization.
17203 elsif In_Init_Proc
and then Is_Finalization_Procedure
(Ent
) then
17206 -- Here we need to generate an implicit elaborate all
17209 -- Generate Elaborate_All warning unless suppressed
17211 if (Elab_Info_Messages
and Generate_Warnings
and not Inst_Case
)
17212 and then not Suppress_Elaboration_Warnings
(Ent
)
17213 and then not Suppress_Elaboration_Warnings
(E_Scope
)
17214 and then not Suppress_Elaboration_Warnings
(W_Scope
)
17216 Error_Msg_Node_2
:= W_Scope
;
17218 ("info: call to& in elaboration code requires pragma "
17219 & "Elaborate_All on&?$?", N
, E
);
17222 -- Set indication for binder to generate Elaborate_All
17224 Set_Elaboration_Constraint
(N
, E
, W_Scope
);
17229 -----------------------------
17230 -- Check_Bad_Instantiation --
17231 -----------------------------
17233 procedure Check_Bad_Instantiation
(N
: Node_Id
) is
17237 -- Nothing to do if we do not have an instantiation (happens in some
17238 -- error cases, and also in the formal package declaration case)
17240 if Nkind
(N
) not in N_Generic_Instantiation
then
17243 -- Nothing to do if serious errors detected (avoid cascaded errors)
17245 elsif Serious_Errors_Detected
/= 0 then
17248 -- Nothing to do if not in full analysis mode
17250 elsif not Full_Analysis
then
17253 -- Nothing to do if inside a generic template
17255 elsif Inside_A_Generic
then
17258 -- Nothing to do if a library level instantiation
17260 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
17263 -- Nothing to do if we are compiling a proper body for semantic
17264 -- purposes only. The generic body may be in another proper body.
17267 Nkind
(Parent
(Unit_Declaration_Node
(Main_Unit_Entity
))) = N_Subunit
17272 Ent
:= Get_Generic_Entity
(N
);
17274 -- The case we are interested in is when the generic spec is in the
17275 -- current declarative part
17277 if not Same_Elaboration_Scope
(Current_Scope
, Scope
(Ent
))
17278 or else not In_Same_Extended_Unit
(N
, Ent
)
17283 -- If the generic entity is within a deeper instance than we are, then
17284 -- either the instantiation to which we refer itself caused an ABE, in
17285 -- which case that will be handled separately. Otherwise, we know that
17286 -- the body we need appears as needed at the point of the instantiation.
17287 -- If they are both at the same level but not within the same instance
17288 -- then the body of the generic will be in the earlier instance.
17291 D1
: constant Nat
:= Instantiation_Depth
(Sloc
(Ent
));
17292 D2
: constant Nat
:= Instantiation_Depth
(Sloc
(N
));
17299 and then Is_Generic_Instance
(Scope
(Ent
))
17300 and then not In_Open_Scopes
(Scope
(Ent
))
17306 -- Now we can proceed, if the entity being called has a completion,
17307 -- then we are definitely OK, since we have already seen the body.
17309 if Has_Completion
(Ent
) then
17313 -- If there is no body, then nothing to do
17315 if not Has_Generic_Body
(N
) then
17319 -- Here we definitely have a bad instantiation
17321 Error_Msg_Warn
:= SPARK_Mode
/= On
;
17322 Error_Msg_NE
("cannot instantiate& before body seen<<", N
, Ent
);
17323 Error_Msg_N
("\Program_Error [<<", N
);
17325 Insert_Elab_Check
(N
);
17326 Set_Is_Known_Guaranteed_ABE
(N
);
17327 end Check_Bad_Instantiation
;
17329 ---------------------
17330 -- Check_Elab_Call --
17331 ---------------------
17333 procedure Check_Elab_Call
17335 Outer_Scope
: Entity_Id
:= Empty
;
17336 In_Init_Proc
: Boolean := False)
17342 pragma Assert
(Legacy_Elaboration_Checks
);
17344 -- If the reference is not in the main unit, there is nothing to check.
17345 -- Elaboration call from units in the context of the main unit will lead
17346 -- to semantic dependencies when those units are compiled.
17348 if not In_Extended_Main_Code_Unit
(N
) then
17352 -- For an entry call, check relevant restriction
17354 if Nkind
(N
) = N_Entry_Call_Statement
17355 and then not In_Subprogram_Or_Concurrent_Unit
17357 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, N
);
17359 -- Nothing to do if this is not an expected type of reference (happens
17360 -- in some error conditions, and in some cases where rewriting occurs).
17362 elsif Nkind
(N
) not in N_Subprogram_Call
17363 and then Nkind
(N
) /= N_Attribute_Reference
17364 and then (SPARK_Mode
/= On
17365 or else Nkind
(N
) not in N_Has_Entity
17366 or else No
(Entity
(N
))
17367 or else Ekind
(Entity
(N
)) /= E_Variable
)
17371 -- Nothing to do if this is a call already rewritten for elab checking.
17372 -- Such calls appear as the targets of If_Expressions.
17374 -- This check MUST be wrong, it catches far too much
17376 elsif Nkind
(Parent
(N
)) = N_If_Expression
then
17379 -- Nothing to do if inside a generic template
17381 elsif Inside_A_Generic
17382 and then No
(Enclosing_Generic_Body
(N
))
17386 -- Nothing to do if call is being preanalyzed, as when within a
17387 -- pre/postcondition, a predicate, or an invariant.
17389 elsif In_Spec_Expression
then
17393 -- Nothing to do if this is a call to a postcondition, which is always
17394 -- within a subprogram body, even though the current scope may be the
17395 -- enclosing scope of the subprogram.
17397 if Nkind
(N
) = N_Procedure_Call_Statement
17398 and then Is_Entity_Name
(Name
(N
))
17399 and then Chars
(Entity
(Name
(N
))) = Name_uWrapped_Statements
17404 -- Here we have a reference at elaboration time that must be checked
17406 if Debug_Flag_Underscore_LL
then
17407 Write_Str
(" Check_Elab_Ref: ");
17409 if Nkind
(N
) = N_Attribute_Reference
then
17410 if not Is_Entity_Name
(Prefix
(N
)) then
17411 Write_Str
("<<not entity name>>");
17413 Write_Name
(Chars
(Entity
(Prefix
(N
))));
17416 Write_Str
("'Access");
17418 elsif No
(Name
(N
)) or else not Is_Entity_Name
(Name
(N
)) then
17419 Write_Str
("<<not entity name>> ");
17422 Write_Name
(Chars
(Entity
(Name
(N
))));
17425 Write_Str
(" reference at ");
17426 Write_Location
(Sloc
(N
));
17430 -- Climb up the tree to make sure we are not inside default expression
17431 -- of a parameter specification or a record component, since in both
17432 -- these cases, we will be doing the actual reference later, not now,
17433 -- and it is at the time of the actual reference (statically speaking)
17434 -- that we must do our static check, not at the time of its initial
17437 -- However, we have to check references within component definitions
17438 -- (e.g. a function call that determines an array component bound),
17439 -- so we terminate the loop in that case.
17442 while Present
(P
) loop
17443 if Nkind
(P
) in N_Parameter_Specification | N_Component_Declaration
17447 -- The reference occurs within the constraint of a component,
17448 -- so it must be checked.
17450 elsif Nkind
(P
) = N_Component_Definition
then
17458 -- Stuff that happens only at the outer level
17460 if No
(Outer_Scope
) then
17461 Elab_Visited
.Set_Last
(0);
17463 -- Nothing to do if current scope is Standard (this is a bit odd, but
17464 -- it happens in the case of generic instantiations).
17466 C_Scope
:= Current_Scope
;
17468 if C_Scope
= Standard_Standard
then
17472 -- First case, we are in elaboration code
17474 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
17476 if From_Elab_Code
then
17478 -- Complain if ref that comes from source in preelaborated unit
17479 -- and we are not inside a subprogram (i.e. we are in elab code).
17481 -- Ada 2022 (AI12-0175): Calls to certain functions that are
17482 -- essentially unchecked conversions are preelaborable.
17484 if Comes_From_Source
(N
)
17485 and then In_Preelaborated_Unit
17486 and then not In_Inlined_Body
17487 and then Nkind
(N
) /= N_Attribute_Reference
17488 and then not (Ada_Version
>= Ada_2022
17489 and then Is_Preelaborable_Construct
(N
))
17491 Error_Preelaborated_Call
(N
);
17495 -- Second case, we are inside a subprogram or concurrent unit, which
17496 -- means we are not in elaboration code.
17499 -- In this case, the issue is whether we are inside the
17500 -- declarative part of the unit in which we live, or inside its
17501 -- statements. In the latter case, there is no issue of ABE calls
17502 -- at this level (a call from outside to the unit in which we live
17503 -- might cause an ABE, but that will be detected when we analyze
17504 -- that outer level call, as it recurses into the called unit).
17506 -- Climb up the tree, doing this test, and also testing for being
17507 -- inside a default expression, which, as discussed above, is not
17508 -- checked at this stage.
17517 -- If we find a parentless subtree, it seems safe to assume
17518 -- that we are not in a declarative part and that no
17519 -- checking is required.
17525 if Is_List_Member
(P
) then
17526 L
:= List_Containing
(P
);
17533 exit when Nkind
(P
) = N_Subunit
;
17535 -- Filter out case of default expressions, where we do not
17536 -- do the check at this stage.
17539 N_Parameter_Specification | N_Component_Declaration
17544 -- A protected body has no elaboration code and contains
17545 -- only other bodies.
17547 if Nkind
(P
) = N_Protected_Body
then
17550 elsif Nkind
(P
) in N_Subprogram_Body
17552 | N_Block_Statement
17555 if L
= Declarations
(P
) then
17558 -- We are not in elaboration code, but we are doing
17559 -- dynamic elaboration checks, in this case, we still
17560 -- need to do the reference, since the subprogram we are
17561 -- in could be called from another unit, also in dynamic
17562 -- elaboration check mode, at elaboration time.
17564 elsif Dynamic_Elaboration_Checks
then
17566 -- We provide a debug flag to disable this check. That
17567 -- way we have an easy work around for regressions
17568 -- that are caused by this new check. This debug flag
17569 -- can be removed later.
17571 if Debug_Flag_DD
then
17575 -- Do the check in this case
17579 elsif Nkind
(P
) = N_Task_Body
then
17581 -- The check is deferred until Check_Task_Activation
17582 -- but we need to capture local suppress pragmas
17583 -- that may inhibit checks on this call.
17585 Ent
:= Get_Referenced_Ent
(N
);
17590 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
17591 or else Elaboration_Checks_Suppressed
(Ent
)
17592 or else Elaboration_Checks_Suppressed
(Scope
(Ent
))
17594 if Nkind
(N
) in N_Subprogram_Call
then
17595 Set_No_Elaboration_Check
(N
);
17601 -- Static model, call is not in elaboration code, we
17602 -- never need to worry, because in the static model the
17603 -- top-level caller always takes care of things.
17614 Ent
:= Get_Referenced_Ent
(N
);
17620 -- Determine whether a prior call to the same subprogram was already
17621 -- examined within the same context. If this is the case, then there is
17622 -- no need to proceed with the various warnings and checks because the
17623 -- work was already done for the previous call.
17626 Self
: constant Visited_Element
:=
17627 (Subp_Id
=> Ent
, Context
=> Parent
(N
));
17630 for Index
in 1 .. Elab_Visited
.Last
loop
17631 if Self
= Elab_Visited
.Table
(Index
) then
17637 -- See if we need to analyze this reference. We analyze it if either of
17638 -- the following conditions is met:
17640 -- It is an inner level call (since in this case it was triggered
17641 -- by an outer level call from elaboration code), but only if the
17642 -- call is within the scope of the original outer level call.
17644 -- It is an outer level reference from elaboration code, or a call to
17645 -- an entity is in the same elaboration scope.
17647 -- And in these cases, we will check both inter-unit calls and
17648 -- intra-unit (within a single unit) calls.
17650 C_Scope
:= Current_Scope
;
17652 -- If not outer level reference, then we follow it if it is within the
17653 -- original scope of the outer reference.
17655 if Present
(Outer_Scope
)
17656 and then Within
(Scope
(Ent
), Outer_Scope
)
17662 Outer_Scope
=> Outer_Scope
,
17663 Inter_Unit_Only
=> False,
17664 In_Init_Proc
=> In_Init_Proc
);
17666 -- Nothing to do if elaboration checks suppressed for this scope.
17667 -- However, an interesting exception, the fact that elaboration checks
17668 -- are suppressed within an instance (because we can trace the body when
17669 -- we process the template) does not extend to calls to generic formal
17672 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
17673 and then not Is_Call_Of_Generic_Formal
(N
)
17677 elsif From_Elab_Code
then
17679 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
17681 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
17683 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
17685 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
17686 -- is set, then we will do the check, but only in the inter-unit case
17687 -- (this is to accommodate unguarded elaboration calls from other units
17688 -- in which this same mode is set). We don't want warnings in this case,
17689 -- it would generate warnings having nothing to do with elaboration.
17691 elsif Dynamic_Elaboration_Checks
then
17697 Inter_Unit_Only
=> True,
17698 Generate_Warnings
=> False);
17700 -- Otherwise nothing to do
17706 -- A call to an Init_Proc in elaboration code may bring additional
17707 -- dependencies, if some of the record components thereof have
17708 -- initializations that are function calls that come from source. We
17709 -- treat the current node as a call to each of these functions, to check
17710 -- their elaboration impact.
17712 if Is_Init_Proc
(Ent
) and then From_Elab_Code
then
17713 Process_Init_Proc
: declare
17714 Unit_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
17716 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
;
17717 -- Find subprogram calls within body of Init_Proc for Traverse
17718 -- instantiation below.
17720 procedure Traverse_Body
is new Traverse_Proc
(Check_Init_Call
);
17721 -- Traversal procedure to find all calls with body of Init_Proc
17723 ---------------------
17724 -- Check_Init_Call --
17725 ---------------------
17727 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
is
17731 if Nkind
(Nod
) in N_Subprogram_Call
17732 and then Is_Entity_Name
(Name
(Nod
))
17734 Func
:= Entity
(Name
(Nod
));
17736 if Comes_From_Source
(Func
) then
17738 (N
, Func
, Standard_Standard
, Inter_Unit_Only
=> True);
17746 end Check_Init_Call
;
17748 -- Start of processing for Process_Init_Proc
17751 if Nkind
(Unit_Decl
) = N_Subprogram_Body
then
17752 Traverse_Body
(Handled_Statement_Sequence
(Unit_Decl
));
17754 end Process_Init_Proc
;
17756 end Check_Elab_Call
;
17758 -----------------------
17759 -- Check_Elab_Assign --
17760 -----------------------
17762 procedure Check_Elab_Assign
(N
: Node_Id
) is
17766 Pkg_Spec
: Entity_Id
;
17767 Pkg_Body
: Entity_Id
;
17770 pragma Assert
(Legacy_Elaboration_Checks
);
17772 -- For record or array component, check prefix. If it is an access type,
17773 -- then there is nothing to do (we do not know what is being assigned),
17774 -- but otherwise this is an assignment to the prefix.
17776 if Nkind
(N
) in N_Indexed_Component | N_Selected_Component | N_Slice
then
17777 if not Is_Access_Type
(Etype
(Prefix
(N
))) then
17778 Check_Elab_Assign
(Prefix
(N
));
17784 -- For type conversion, check expression
17786 if Nkind
(N
) = N_Type_Conversion
then
17787 Check_Elab_Assign
(Expression
(N
));
17791 -- Nothing to do if this is not an entity reference otherwise get entity
17793 if Is_Entity_Name
(N
) then
17799 -- What we are looking for is a reference in the body of a package that
17800 -- modifies a variable declared in the visible part of the package spec.
17803 and then Comes_From_Source
(N
)
17804 and then not Suppress_Elaboration_Warnings
(Ent
)
17805 and then Ekind
(Ent
) = E_Variable
17806 and then not In_Private_Part
(Ent
)
17807 and then Is_Library_Level_Entity
(Ent
)
17809 Scop
:= Current_Scope
;
17811 if No
(Scop
) or else Scop
= Standard_Standard
then
17813 elsif Ekind
(Scop
) = E_Package
17814 and then Is_Compilation_Unit
(Scop
)
17818 Scop
:= Scope
(Scop
);
17822 -- Here Scop points to the containing library package
17825 Pkg_Body
:= Body_Entity
(Pkg_Spec
);
17827 -- All OK if the package has an Elaborate_Body pragma
17829 if Has_Pragma_Elaborate_Body
(Scop
) then
17833 -- OK if entity being modified is not in containing package spec
17835 if not In_Same_Source_Unit
(Scop
, Ent
) then
17839 -- All OK if entity appears in generic package or generic instance.
17840 -- We just get too messed up trying to give proper warnings in the
17841 -- presence of generics. Better no message than a junk one.
17843 Scop
:= Scope
(Ent
);
17844 while Present
(Scop
) and then Scop
/= Pkg_Spec
loop
17845 if Ekind
(Scop
) = E_Generic_Package
then
17847 elsif Ekind
(Scop
) = E_Package
17848 and then Is_Generic_Instance
(Scop
)
17853 Scop
:= Scope
(Scop
);
17856 -- All OK if in task, don't issue warnings there
17858 if In_Task_Activation
then
17862 -- OK if no package body
17864 if No
(Pkg_Body
) then
17868 -- OK if reference is not in package body
17870 if not In_Same_Source_Unit
(Pkg_Body
, N
) then
17874 -- OK if package body has no handled statement sequence
17877 HSS
: constant Node_Id
:=
17878 Handled_Statement_Sequence
(Declaration_Node
(Pkg_Body
));
17880 if No
(HSS
) or else not Comes_From_Source
(HSS
) then
17885 -- We definitely have a case of a modification of an entity in
17886 -- the package spec from the elaboration code of the package body.
17887 -- We may not give the warning (because there are some additional
17888 -- checks to avoid too many false positives), but it would be a good
17889 -- idea for the binder to try to keep the body elaboration close to
17890 -- the spec elaboration.
17892 Set_Elaborate_Body_Desirable
(Pkg_Spec
);
17894 -- All OK in gnat mode (we know what we are doing)
17900 -- All OK if all warnings suppressed
17902 if Warning_Mode
= Suppress
then
17906 -- All OK if elaboration checks suppressed for entity
17908 if Checks_May_Be_Suppressed
(Ent
)
17909 and then Is_Check_Suppressed
(Ent
, Elaboration_Check
)
17914 -- OK if the entity is initialized. Note that the No_Initialization
17915 -- flag usually means that the initialization has been rewritten into
17916 -- assignments, but that still counts for us.
17919 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
17921 if Nkind
(Decl
) = N_Object_Declaration
17922 and then (Present
(Expression
(Decl
))
17923 or else No_Initialization
(Decl
))
17929 -- Here is where we give the warning
17931 -- All OK if warnings suppressed on the entity
17933 if not Has_Warnings_Off
(Ent
) then
17934 Error_Msg_Sloc
:= Sloc
(Ent
);
17937 ("??& can be accessed by clients before this initialization",
17940 ("\??add Elaborate_Body to spec to ensure & is initialized",
17944 if not All_Errors_Mode
then
17945 Set_Suppress_Elaboration_Warnings
(Ent
);
17948 end Check_Elab_Assign
;
17950 ----------------------
17951 -- Check_Elab_Calls --
17952 ----------------------
17954 -- WARNING: This routine manages SPARK regions
17956 procedure Check_Elab_Calls
is
17957 Saved_SM
: SPARK_Mode_Type
;
17958 Saved_SMP
: Node_Id
;
17961 pragma Assert
(Legacy_Elaboration_Checks
);
17963 -- If expansion is disabled, do not generate any checks, unless we
17964 -- are in GNATprove mode, so that errors are issued in GNATprove for
17965 -- violations of static elaboration rules in SPARK code. Also skip
17966 -- checks if any subunits are missing because in either case we lack the
17967 -- full information that we need, and no object file will be created in
17970 if (not Expander_Active
and not GNATprove_Mode
)
17971 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
17972 or else Subunits_Missing
17977 -- Skip delayed calls if we had any errors
17979 if Serious_Errors_Detected
= 0 then
17980 Delaying_Elab_Checks
:= False;
17981 Expander_Mode_Save_And_Set
(True);
17983 for J
in Delay_Check
.First
.. Delay_Check
.Last
loop
17984 Push_Scope
(Delay_Check
.Table
(J
).Curscop
);
17985 From_Elab_Code
:= Delay_Check
.Table
(J
).From_Elab_Code
;
17986 In_Task_Activation
:= Delay_Check
.Table
(J
).In_Task_Activation
;
17988 Saved_SM
:= SPARK_Mode
;
17989 Saved_SMP
:= SPARK_Mode_Pragma
;
17991 -- Set appropriate value of SPARK_Mode
17993 if Delay_Check
.Table
(J
).From_SPARK_Code
then
17997 Check_Internal_Call_Continue
17998 (N
=> Delay_Check
.Table
(J
).N
,
17999 E
=> Delay_Check
.Table
(J
).E
,
18000 Outer_Scope
=> Delay_Check
.Table
(J
).Outer_Scope
,
18001 Orig_Ent
=> Delay_Check
.Table
(J
).Orig_Ent
);
18003 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
18007 -- Set Delaying_Elab_Checks back on for next main compilation
18009 Expander_Mode_Restore
;
18010 Delaying_Elab_Checks
:= True;
18012 end Check_Elab_Calls
;
18014 ------------------------------
18015 -- Check_Elab_Instantiation --
18016 ------------------------------
18018 procedure Check_Elab_Instantiation
18020 Outer_Scope
: Entity_Id
:= Empty
)
18025 pragma Assert
(Legacy_Elaboration_Checks
);
18027 -- Check for and deal with bad instantiation case. There is some
18028 -- duplicated code here, but we will worry about this later ???
18030 Check_Bad_Instantiation
(N
);
18032 if Is_Known_Guaranteed_ABE
(N
) then
18036 -- Nothing to do if we do not have an instantiation (happens in some
18037 -- error cases, and also in the formal package declaration case)
18039 if Nkind
(N
) not in N_Generic_Instantiation
then
18043 -- Nothing to do if inside a generic template
18045 if Inside_A_Generic
then
18049 -- Nothing to do if the instantiation is not in the main unit
18051 if not In_Extended_Main_Code_Unit
(N
) then
18055 Ent
:= Get_Generic_Entity
(N
);
18056 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
18058 -- See if we need to analyze this instantiation. We analyze it if
18059 -- either of the following conditions is met:
18061 -- It is an inner level instantiation (since in this case it was
18062 -- triggered by an outer level call from elaboration code), but
18063 -- only if the instantiation is within the scope of the original
18064 -- outer level call.
18066 -- It is an outer level instantiation from elaboration code, or the
18067 -- instantiated entity is in the same elaboration scope.
18069 -- And in these cases, we will check both the inter-unit case and
18070 -- the intra-unit (within a single unit) case.
18072 C_Scope
:= Current_Scope
;
18074 if Present
(Outer_Scope
) and then Within
(Scope
(Ent
), Outer_Scope
) then
18076 Check_A_Call
(N
, Ent
, Outer_Scope
, Inter_Unit_Only
=> False);
18078 elsif From_Elab_Code
then
18080 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
18082 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
18084 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
18086 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is
18087 -- set, then we will do the check, but only in the inter-unit case (this
18088 -- is to accommodate unguarded elaboration calls from other units in
18089 -- which this same mode is set). We inhibit warnings in this case, since
18090 -- this instantiation is not occurring in elaboration code.
18092 elsif Dynamic_Elaboration_Checks
then
18098 Inter_Unit_Only
=> True,
18099 Generate_Warnings
=> False);
18104 end Check_Elab_Instantiation
;
18106 -------------------------
18107 -- Check_Internal_Call --
18108 -------------------------
18110 procedure Check_Internal_Call
18113 Outer_Scope
: Entity_Id
;
18114 Orig_Ent
: Entity_Id
)
18116 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean;
18117 -- Determine whether call Call occurs within pragma Initial_Condition or
18118 -- pragma Check with check_kind set to Initial_Condition.
18120 ------------------------------
18121 -- Within_Initial_Condition --
18122 ------------------------------
18124 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean is
18130 -- Traverse the parent chain looking for an enclosing pragma
18133 while Present
(Par
) loop
18134 if Nkind
(Par
) = N_Pragma
then
18135 Nam
:= Pragma_Name
(Par
);
18137 -- Pragma Initial_Condition appears in its alternative from as
18138 -- Check (Initial_Condition, ...).
18140 if Nam
= Name_Check
then
18141 Args
:= Pragma_Argument_Associations
(Par
);
18143 -- Pragma Check should have at least two arguments
18145 pragma Assert
(Present
(Args
));
18148 Chars
(Expression
(First
(Args
))) = Name_Initial_Condition
;
18152 elsif Nam
= Name_Initial_Condition
then
18155 -- Since pragmas are never nested within other pragmas, stop
18162 -- Prevent the search from going too far
18164 elsif Is_Body_Or_Package_Declaration
(Par
) then
18168 Par
:= Parent
(Par
);
18170 -- If assertions are not enabled, the check pragma is rewritten
18171 -- as an if_statement in sem_prag, to generate various warnings
18172 -- on boolean expressions. Retrieve the original pragma.
18174 if Nkind
(Original_Node
(Par
)) = N_Pragma
then
18175 Par
:= Original_Node
(Par
);
18180 end Within_Initial_Condition
;
18184 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
18186 -- Start of processing for Check_Internal_Call
18189 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the
18190 -- node comes from source.
18192 if Nkind
(N
) = N_Attribute_Reference
18193 and then ((not Warn_On_Elab_Access
and then not Debug_Flag_Dot_O
)
18194 or else not Comes_From_Source
(N
))
18198 -- If not function or procedure call, instantiation, or 'Access, then
18199 -- ignore call (this happens in some error cases and rewriting cases).
18201 elsif Nkind
(N
) not in N_Attribute_Reference
18203 | N_Procedure_Call_Statement
18204 and then not Inst_Case
18208 -- Nothing to do if this is a call or instantiation that has already
18209 -- been found to be a sure ABE.
18211 elsif Nkind
(N
) /= N_Attribute_Reference
18212 and then Is_Known_Guaranteed_ABE
(N
)
18216 -- Nothing to do if errors already detected (avoid cascaded errors)
18218 elsif Serious_Errors_Detected
/= 0 then
18221 -- Nothing to do if not in full analysis mode
18223 elsif not Full_Analysis
then
18226 -- Nothing to do if analyzing in special spec-expression mode, since the
18227 -- call is not actually being made at this time.
18229 elsif In_Spec_Expression
then
18232 -- Nothing to do for call to intrinsic subprogram
18234 elsif Is_Intrinsic_Subprogram
(E
) then
18237 -- Nothing to do if call is within a generic unit
18239 elsif Inside_A_Generic
then
18242 -- Nothing to do when the call appears within pragma Initial_Condition.
18243 -- The pragma is part of the elaboration statements of a package body
18244 -- and may only call external subprograms or subprograms whose body is
18245 -- already available.
18247 elsif Within_Initial_Condition
(N
) then
18251 -- Delay this call if we are still delaying calls
18253 if Delaying_Elab_Checks
then
18257 Orig_Ent
=> Orig_Ent
,
18258 Curscop
=> Current_Scope
,
18259 Outer_Scope
=> Outer_Scope
,
18260 From_Elab_Code
=> From_Elab_Code
,
18261 In_Task_Activation
=> In_Task_Activation
,
18262 From_SPARK_Code
=> SPARK_Mode
= On
));
18265 -- Otherwise, call phase 2 continuation right now
18268 Check_Internal_Call_Continue
(N
, E
, Outer_Scope
, Orig_Ent
);
18270 end Check_Internal_Call
;
18272 ----------------------------------
18273 -- Check_Internal_Call_Continue --
18274 ----------------------------------
18276 procedure Check_Internal_Call_Continue
18279 Outer_Scope
: Entity_Id
;
18280 Orig_Ent
: Entity_Id
)
18282 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
;
18283 -- Function applied to each node as we traverse the body. Checks for
18284 -- call or entity reference that needs checking, and if so checks it.
18285 -- Always returns OK, so entire tree is traversed, except that as
18286 -- described below subprogram bodies are skipped for now.
18288 procedure Traverse
is new Atree
.Traverse_Proc
(Find_Elab_Reference
);
18289 -- Traverse procedure using above Find_Elab_Reference function
18291 -------------------------
18292 -- Find_Elab_Reference --
18293 -------------------------
18295 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
is
18299 -- If user has specified that there are no entry calls in elaboration
18300 -- code, do not trace past an accept statement, because the rendez-
18301 -- vous will happen after elaboration.
18303 if Nkind
(Original_Node
(N
)) in
18304 N_Accept_Statement | N_Selective_Accept
18305 and then Restriction_Active
(No_Entry_Calls_In_Elaboration_Code
)
18309 -- If we have a function call, check it
18311 elsif Nkind
(N
) = N_Function_Call
then
18312 Check_Elab_Call
(N
, Outer_Scope
);
18315 -- If we have a procedure call, check the call, and also check
18316 -- arguments that are assignments (OUT or IN OUT mode formals).
18318 elsif Nkind
(N
) = N_Procedure_Call_Statement
then
18319 Check_Elab_Call
(N
, Outer_Scope
, In_Init_Proc
=> Is_Init_Proc
(E
));
18321 Actual
:= First_Actual
(N
);
18322 while Present
(Actual
) loop
18323 if Known_To_Be_Assigned
(Actual
) then
18324 Check_Elab_Assign
(Actual
);
18327 Next_Actual
(Actual
);
18332 -- If we have an access attribute for a subprogram, check it.
18333 -- Suppress this behavior under debug flag.
18335 elsif not Debug_Flag_Dot_UU
18336 and then Nkind
(N
) = N_Attribute_Reference
18338 Attribute_Name
(N
) in Name_Access | Name_Unrestricted_Access
18339 and then Is_Entity_Name
(Prefix
(N
))
18340 and then Is_Subprogram
(Entity
(Prefix
(N
)))
18342 Check_Elab_Call
(N
, Outer_Scope
);
18345 -- In SPARK mode, if we have an entity reference to a variable, then
18346 -- check it. For now we consider any reference.
18348 elsif SPARK_Mode
= On
18349 and then Nkind
(N
) in N_Has_Entity
18350 and then Present
(Entity
(N
))
18351 and then Ekind
(Entity
(N
)) = E_Variable
18353 Check_Elab_Call
(N
, Outer_Scope
);
18356 -- If we have a generic instantiation, check it
18358 elsif Nkind
(N
) in N_Generic_Instantiation
then
18359 Check_Elab_Instantiation
(N
, Outer_Scope
);
18362 -- Skip subprogram bodies that come from source (wait for call to
18363 -- analyze these). The reason for the come from source test is to
18364 -- avoid catching task bodies.
18366 -- For task bodies, we should really avoid these too, waiting for the
18367 -- task activation, but that's too much trouble to catch for now, so
18368 -- we go in unconditionally. This is not so terrible, it means the
18369 -- error backtrace is not quite complete, and we are too eager to
18370 -- scan bodies of tasks that are unused, but this is hardly very
18373 elsif Nkind
(N
) = N_Subprogram_Body
18374 and then Comes_From_Source
(N
)
18378 elsif Nkind
(N
) = N_Assignment_Statement
18379 and then Comes_From_Source
(N
)
18381 Check_Elab_Assign
(Name
(N
));
18387 end Find_Elab_Reference
;
18389 Inst_Case
: constant Boolean := Is_Generic_Unit
(E
);
18390 Loc
: constant Source_Ptr
:= Sloc
(N
);
18395 -- Start of processing for Check_Internal_Call_Continue
18398 -- Save outer level call if at outer level
18400 if Elab_Call
.Last
= 0 then
18401 Outer_Level_Sloc
:= Loc
;
18404 -- If the call is to a function that renames a literal, no check needed
18406 if Ekind
(E
) = E_Enumeration_Literal
then
18410 -- Register the subprogram as examined within this particular context.
18411 -- This ensures that calls to the same subprogram but in different
18412 -- contexts receive warnings and checks of their own since the calls
18413 -- may be reached through different flow paths.
18415 Elab_Visited
.Append
((Subp_Id
=> E
, Context
=> Parent
(N
)));
18417 Sbody
:= Unit_Declaration_Node
(E
);
18419 if Nkind
(Sbody
) not in N_Subprogram_Body | N_Package_Body
then
18420 Ebody
:= Corresponding_Body
(Sbody
);
18425 Sbody
:= Unit_Declaration_Node
(Ebody
);
18429 -- If the body appears after the outer level call or instantiation then
18430 -- we have an error case handled below.
18432 if Earlier_In_Extended_Unit
(Outer_Level_Sloc
, Sloc
(Sbody
))
18433 and then not In_Task_Activation
18437 -- If we have the instantiation case we are done, since we now know that
18438 -- the body of the generic appeared earlier.
18440 elsif Inst_Case
then
18443 -- Otherwise we have a call, so we trace through the called body to see
18444 -- if it has any problems.
18447 pragma Assert
(Nkind
(Sbody
) = N_Subprogram_Body
);
18449 Elab_Call
.Append
((Cloc
=> Loc
, Ent
=> E
));
18451 if Debug_Flag_Underscore_LL
then
18452 Write_Str
("Elab_Call.Last = ");
18453 Write_Int
(Int
(Elab_Call
.Last
));
18454 Write_Str
(" Ent = ");
18455 Write_Name
(Chars
(E
));
18456 Write_Str
(" at ");
18457 Write_Location
(Sloc
(N
));
18461 -- Now traverse declarations and statements of subprogram body. Note
18462 -- that we cannot simply Traverse (Sbody), since traverse does not
18463 -- normally visit subprogram bodies.
18468 Decl
:= First
(Declarations
(Sbody
));
18469 while Present
(Decl
) loop
18475 Traverse
(Handled_Statement_Sequence
(Sbody
));
18477 Elab_Call
.Decrement_Last
;
18481 -- Here is the case of calling a subprogram where the body has not yet
18482 -- been encountered. A warning message is needed, except if this is the
18483 -- case of appearing within an aspect specification that results in
18484 -- a check call, we do not really have such a situation, so no warning
18485 -- is needed (e.g. the case of a precondition, where the call appears
18486 -- textually before the body, but in actual fact is moved to the
18487 -- appropriate subprogram body and so does not need a check).
18496 -- Keep looking at parents if we are still in the subexpression
18498 if Nkind
(P
) in N_Subexpr
then
18501 -- Here P is the parent of the expression, check for special case
18504 O
:= Original_Node
(P
);
18506 -- Definitely not the special case if orig node is not a pragma
18508 exit when Nkind
(O
) /= N_Pragma
;
18510 -- Check we have an If statement or a null statement (happens
18511 -- when the If has been expanded to be True).
18513 exit when Nkind
(P
) not in N_If_Statement | N_Null_Statement
;
18515 -- Our special case will be indicated either by the pragma
18516 -- coming from an aspect ...
18518 if Present
(Corresponding_Aspect
(O
)) then
18521 -- Or, in the case of an initial condition, specifically by a
18522 -- Check pragma specifying an Initial_Condition check.
18524 elsif Pragma_Name
(O
) = Name_Check
18527 (Expression
(First
(Pragma_Argument_Associations
(O
)))) =
18528 Name_Initial_Condition
18532 -- For anything else, we have an error
18541 -- Not that special case, warning and dynamic check is required
18543 -- If we have nothing in the call stack, then this is at the outer
18544 -- level, and the ABE is bound to occur, unless it's a 'Access, or
18545 -- it's a renaming.
18547 if Elab_Call
.Last
= 0 then
18548 Error_Msg_Warn
:= SPARK_Mode
/= On
;
18551 Insert_Check
: Boolean := True;
18552 -- This flag is set to True if an elaboration check should be
18556 if In_Task_Activation
then
18557 Insert_Check
:= False;
18559 elsif Inst_Case
then
18561 ("cannot instantiate& before body seen<<", N
, Orig_Ent
);
18563 elsif Nkind
(N
) = N_Attribute_Reference
then
18565 ("Access attribute of & before body seen<<", N
, Orig_Ent
);
18567 ("\possible Program_Error on later references<<", N
);
18568 Insert_Check
:= False;
18570 elsif Nkind
(Unit_Declaration_Node
(Orig_Ent
)) /=
18571 N_Subprogram_Renaming_Declaration
18572 or else Is_Generic_Actual_Subprogram
(Orig_Ent
)
18575 ("cannot call& before body seen<<", N
, Orig_Ent
);
18577 Insert_Check
:= False;
18580 if Insert_Check
then
18581 Error_Msg_N
("\Program_Error [<<", N
);
18582 Insert_Elab_Check
(N
);
18586 -- Call is not at outer level
18589 -- Do not generate elaboration checks in GNATprove mode because the
18590 -- elaboration counter and the check are both forms of expansion.
18592 if GNATprove_Mode
then
18595 -- Generate an elaboration check
18597 elsif not Elaboration_Checks_Suppressed
(E
) then
18598 Set_Elaboration_Entity_Required
(E
);
18600 -- Create a declaration of the elaboration entity, and insert it
18601 -- prior to the subprogram or the generic unit, within the same
18602 -- scope. Since the subprogram may be overloaded, create a unique
18605 if No
(Elaboration_Entity
(E
)) then
18607 Loce
: constant Source_Ptr
:= Sloc
(E
);
18608 Ent
: constant Entity_Id
:=
18609 Make_Defining_Identifier
(Loc
,
18610 New_External_Name
(Chars
(E
), 'E', -1));
18613 Set_Elaboration_Entity
(E
, Ent
);
18614 Push_Scope
(Scope
(E
));
18616 Insert_Action
(Declaration_Node
(E
),
18617 Make_Object_Declaration
(Loce
,
18618 Defining_Identifier
=> Ent
,
18619 Object_Definition
=>
18620 New_Occurrence_Of
(Standard_Short_Integer
, Loce
),
18622 Make_Integer_Literal
(Loc
, Uint_0
)));
18624 -- Set elaboration flag at the point of the body
18626 Set_Elaboration_Flag
(Sbody
, E
);
18628 -- Kill current value indication. This is necessary because
18629 -- the tests of this flag are inserted out of sequence and
18630 -- must not pick up bogus indications of the wrong constant
18631 -- value. Also, this is never a true constant, since one way
18632 -- or another, it gets reset.
18634 Set_Current_Value
(Ent
, Empty
);
18635 Set_Last_Assignment
(Ent
, Empty
);
18636 Set_Is_True_Constant
(Ent
, False);
18643 -- raise Program_Error with "access before elaboration";
18646 Insert_Elab_Check
(N
,
18647 Make_Attribute_Reference
(Loc
,
18648 Attribute_Name
=> Name_Elaborated
,
18649 Prefix
=> New_Occurrence_Of
(E
, Loc
)));
18652 -- Generate the warning
18654 if not Suppress_Elaboration_Warnings
(E
)
18655 and then not Elaboration_Checks_Suppressed
(E
)
18657 -- Suppress this warning if we have a function call that occurred
18658 -- within an assertion expression, since we can get false warnings
18659 -- in this case, due to the out of order handling in this case.
18662 (Nkind
(Original_Node
(N
)) /= N_Function_Call
18663 or else not In_Assertion_Expression_Pragma
(Original_Node
(N
)))
18665 Error_Msg_Warn
:= SPARK_Mode
/= On
;
18669 ("instantiation of& may occur before body is seen<l<",
18672 -- A rather specific check: for Adjust/Finalize/Initialize, if
18673 -- the type has Warnings_Off set, suppress the warning.
18675 if Is_Controlled_Procedure
(E
, Name_Adjust
)
18676 or else Is_Controlled_Procedure
(E
, Name_Finalize
)
18677 or else Is_Controlled_Procedure
(E
, Name_Initialize
)
18680 T
: constant Entity_Id
:= Etype
(First_Formal
(E
));
18683 if Has_Warnings_Off
(T
)
18684 or else (Ekind
(T
) = E_Private_Type
18685 and then Has_Warnings_Off
(Full_View
(T
)))
18692 -- Go ahead and give warning if not this special case
18695 ("call to& may occur before body is seen<l<", N
, Orig_Ent
);
18698 Error_Msg_N
("\Program_Error ]<l<", N
);
18700 -- There is no need to query the elaboration warning message flags
18701 -- because the main message is an error, not a warning, therefore
18702 -- all the clarification messages produces by Output_Calls must be
18703 -- emitted unconditionally.
18707 Output_Calls
(N
, Check_Elab_Flag
=> False);
18710 end Check_Internal_Call_Continue
;
18712 ---------------------------
18713 -- Check_Task_Activation --
18714 ---------------------------
18716 procedure Check_Task_Activation
(N
: Node_Id
) is
18717 Loc
: constant Source_Ptr
:= Sloc
(N
);
18718 Inter_Procs
: constant Elist_Id
:= New_Elmt_List
;
18719 Intra_Procs
: constant Elist_Id
:= New_Elmt_List
;
18722 Task_Scope
: Entity_Id
;
18723 Cunit_SC
: Boolean := False;
18726 Enclosing
: Entity_Id
;
18728 procedure Add_Task_Proc
(Typ
: Entity_Id
);
18729 -- Add to Task_Procs the task body procedure(s) of task types in Typ.
18730 -- For record types, this procedure recurses over component types.
18732 procedure Collect_Tasks
(Decls
: List_Id
);
18733 -- Collect the types of the tasks that are to be activated in the given
18734 -- list of declarations, in order to perform elaboration checks on the
18735 -- corresponding task procedures that are called implicitly here.
18737 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
;
18738 -- find enclosing compilation unit of Entity, ignoring subunits, or
18739 -- else enclosing subprogram. If E is not a package, there is no need
18740 -- for inter-unit elaboration checks.
18742 -------------------
18743 -- Add_Task_Proc --
18744 -------------------
18746 procedure Add_Task_Proc
(Typ
: Entity_Id
) is
18748 Proc
: Entity_Id
:= Empty
;
18751 if Is_Task_Type
(Typ
) then
18752 Proc
:= Get_Task_Body_Procedure
(Typ
);
18754 elsif Is_Array_Type
(Typ
)
18755 and then Has_Task
(Base_Type
(Typ
))
18757 Add_Task_Proc
(Component_Type
(Typ
));
18759 elsif Is_Record_Type
(Typ
)
18760 and then Has_Task
(Base_Type
(Typ
))
18762 Comp
:= First_Component
(Typ
);
18763 while Present
(Comp
) loop
18764 Add_Task_Proc
(Etype
(Comp
));
18765 Next_Component
(Comp
);
18769 -- If the task type is another unit, we will perform the usual
18770 -- elaboration check on its enclosing unit. If the type is in the
18771 -- same unit, we can trace the task body as for an internal call,
18772 -- but we only need to examine other external calls, because at
18773 -- the point the task is activated, internal subprogram bodies
18774 -- will have been elaborated already. We keep separate lists for
18775 -- each kind of task.
18777 -- Skip this test if errors have occurred, since in this case
18778 -- we can get false indications.
18780 if Serious_Errors_Detected
/= 0 then
18784 if Present
(Proc
) then
18785 if Outer_Unit
(Scope
(Proc
)) = Enclosing
then
18787 if No
(Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
18789 (not Is_Generic_Instance
(Scope
(Proc
))
18790 or else Scope
(Proc
) = Scope
(Defining_Identifier
(Decl
)))
18792 Error_Msg_Warn
:= SPARK_Mode
/= On
;
18794 ("task will be activated before elaboration of its body<<",
18796 Error_Msg_N
("\Program_Error [<<", Decl
);
18799 (Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
18801 Append_Elmt
(Proc
, Intra_Procs
);
18805 -- No need for multiple entries of the same type
18807 Elmt
:= First_Elmt
(Inter_Procs
);
18808 while Present
(Elmt
) loop
18809 if Node
(Elmt
) = Proc
then
18816 Append_Elmt
(Proc
, Inter_Procs
);
18821 -------------------
18822 -- Collect_Tasks --
18823 -------------------
18825 procedure Collect_Tasks
(Decls
: List_Id
) is
18827 Decl
:= First
(Decls
);
18828 while Present
(Decl
) loop
18829 if Nkind
(Decl
) = N_Object_Declaration
18830 and then Has_Task
(Etype
(Defining_Identifier
(Decl
)))
18832 Add_Task_Proc
(Etype
(Defining_Identifier
(Decl
)));
18843 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
is
18848 while Present
(Outer
) loop
18849 if Elaboration_Checks_Suppressed
(Outer
) then
18853 exit when Is_Child_Unit
(Outer
)
18854 or else Scope
(Outer
) = Standard_Standard
18855 or else Ekind
(Outer
) /= E_Package
;
18856 Outer
:= Scope
(Outer
);
18862 -- Start of processing for Check_Task_Activation
18865 pragma Assert
(Legacy_Elaboration_Checks
);
18867 Enclosing
:= Outer_Unit
(Current_Scope
);
18869 -- Find all tasks declared in the current unit
18871 if Nkind
(N
) = N_Package_Body
then
18872 P
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
18874 Collect_Tasks
(Declarations
(N
));
18875 Collect_Tasks
(Visible_Declarations
(Specification
(P
)));
18876 Collect_Tasks
(Private_Declarations
(Specification
(P
)));
18878 elsif Nkind
(N
) = N_Package_Declaration
then
18879 Collect_Tasks
(Visible_Declarations
(Specification
(N
)));
18880 Collect_Tasks
(Private_Declarations
(Specification
(N
)));
18883 Collect_Tasks
(Declarations
(N
));
18886 -- We only perform detailed checks in all tasks that are library level
18887 -- entities. If the master is a subprogram or task, activation will
18888 -- depend on the activation of the master itself.
18890 -- Should dynamic checks be added in the more general case???
18892 if Ekind
(Enclosing
) /= E_Package
then
18896 -- For task types defined in other units, we want the unit containing
18897 -- the task body to be elaborated before the current one.
18899 Elmt
:= First_Elmt
(Inter_Procs
);
18900 while Present
(Elmt
) loop
18901 Ent
:= Node
(Elmt
);
18902 Task_Scope
:= Outer_Unit
(Scope
(Ent
));
18904 if not Is_Compilation_Unit
(Task_Scope
) then
18907 elsif Suppress_Elaboration_Warnings
(Task_Scope
)
18908 or else Elaboration_Checks_Suppressed
(Task_Scope
)
18912 elsif Dynamic_Elaboration_Checks
then
18913 if not Elaboration_Checks_Suppressed
(Ent
)
18914 and then not Cunit_SC
18915 and then not Restriction_Active
18916 (No_Entry_Calls_In_Elaboration_Code
)
18918 -- Runtime elaboration check required. Generate check of the
18919 -- elaboration counter for the unit containing the entity.
18921 Insert_Elab_Check
(N
,
18922 Make_Attribute_Reference
(Loc
,
18924 New_Occurrence_Of
(Spec_Entity
(Task_Scope
), Loc
),
18925 Attribute_Name
=> Name_Elaborated
));
18929 -- Force the binder to elaborate other unit first
18931 if Elab_Info_Messages
18932 and then not Suppress_Elaboration_Warnings
(Ent
)
18933 and then not Elaboration_Checks_Suppressed
(Ent
)
18934 and then not Suppress_Elaboration_Warnings
(Task_Scope
)
18935 and then not Elaboration_Checks_Suppressed
(Task_Scope
)
18937 Error_Msg_Node_2
:= Task_Scope
;
18939 ("info: activation of an instance of task type & requires "
18940 & "pragma Elaborate_All on &?$?", N
, Ent
);
18943 Activate_Elaborate_All_Desirable
(N
, Task_Scope
);
18944 Set_Suppress_Elaboration_Warnings
(Task_Scope
);
18950 -- For tasks declared in the current unit, trace other calls within the
18951 -- task procedure bodies, which are available.
18953 if not Debug_Flag_Dot_Y
then
18954 In_Task_Activation
:= True;
18956 Elmt
:= First_Elmt
(Intra_Procs
);
18957 while Present
(Elmt
) loop
18958 Ent
:= Node
(Elmt
);
18959 Check_Internal_Call_Continue
(N
, Ent
, Enclosing
, Ent
);
18963 In_Task_Activation
:= False;
18965 end Check_Task_Activation
;
18967 ------------------------
18968 -- Get_Referenced_Ent --
18969 ------------------------
18971 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
is
18975 if Nkind
(N
) in N_Has_Entity
18976 and then Present
(Entity
(N
))
18977 and then Ekind
(Entity
(N
)) = E_Variable
18982 if Nkind
(N
) = N_Attribute_Reference
then
18990 elsif Nkind
(Nam
) = N_Selected_Component
then
18991 return Entity
(Selector_Name
(Nam
));
18992 elsif not Is_Entity_Name
(Nam
) then
18995 return Entity
(Nam
);
18997 end Get_Referenced_Ent
;
18999 ----------------------
19000 -- Has_Generic_Body --
19001 ----------------------
19003 function Has_Generic_Body
(N
: Node_Id
) return Boolean is
19004 Ent
: constant Entity_Id
:= Get_Generic_Entity
(N
);
19005 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
19008 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
;
19009 -- Determine if the list of nodes headed by N and linked by Next
19010 -- contains a package body for the package spec entity E, and if so
19011 -- return the package body. If not, then returns Empty.
19013 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
;
19014 -- This procedure is called load the unit whose name is given by Nam.
19015 -- This unit is being loaded to see whether it contains an optional
19016 -- generic body. The returned value is the loaded unit, which is always
19017 -- a package body (only package bodies can contain other entities in the
19018 -- sense in which Has_Generic_Body is interested). We only attempt to
19019 -- load bodies if we are generating code. If we are in semantics check
19020 -- only mode, then it would be wrong to load bodies that are not
19021 -- required from a semantic point of view, so in this case we return
19022 -- Empty. The result is that the caller may incorrectly decide that a
19023 -- generic spec does not have a body when in fact it does, but the only
19024 -- harm in this is that some warnings on elaboration problems may be
19025 -- lost in semantic checks only mode, which is not big loss. We also
19026 -- return Empty if we go for a body and it is not there.
19028 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
;
19029 -- PE is the entity for a package spec. This function locates the
19030 -- corresponding package body, returning Empty if none is found. The
19031 -- package body returned is fully parsed but may not yet be analyzed,
19032 -- so only syntactic fields should be referenced.
19038 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
is
19043 while Present
(Nod
) loop
19045 -- If we found the package body we are looking for, return it
19047 if Nkind
(Nod
) = N_Package_Body
19048 and then Chars
(Defining_Unit_Name
(Nod
)) = Chars
(E
)
19052 -- If we found the stub for the body, go after the subunit,
19053 -- loading it if necessary.
19055 elsif Nkind
(Nod
) = N_Package_Body_Stub
19056 and then Chars
(Defining_Identifier
(Nod
)) = Chars
(E
)
19058 if Present
(Library_Unit
(Nod
)) then
19059 return Unit
(Library_Unit
(Nod
));
19062 return Load_Package_Body
(Get_Unit_Name
(Nod
));
19065 -- If neither package body nor stub, keep looking on chain
19075 -----------------------
19076 -- Load_Package_Body --
19077 -----------------------
19079 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
is
19080 U
: Unit_Number_Type
;
19083 if Operating_Mode
/= Generate_Code
then
19093 if U
= No_Unit
then
19096 return Unit
(Cunit
(U
));
19099 end Load_Package_Body
;
19101 -------------------------------
19102 -- Locate_Corresponding_Body --
19103 -------------------------------
19105 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
is
19106 Spec
: constant Node_Id
:= Declaration_Node
(PE
);
19107 Decl
: constant Node_Id
:= Parent
(Spec
);
19108 Scop
: constant Entity_Id
:= Scope
(PE
);
19112 if Is_Library_Level_Entity
(PE
) then
19114 -- If package is a library unit that requires a body, we have no
19115 -- choice but to go after that body because it might contain an
19116 -- optional body for the original generic package.
19118 if Unit_Requires_Body
(PE
) then
19120 -- Load the body. Note that we are a little careful here to use
19121 -- Spec to get the unit number, rather than PE or Decl, since
19122 -- in the case where the package is itself a library level
19123 -- instantiation, Spec will properly reference the generic
19124 -- template, which is what we really want.
19128 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec
))));
19130 -- But if the package is a library unit that does NOT require
19131 -- a body, then no body is permitted, so we are sure that there
19132 -- is no body for the original generic package.
19138 -- Otherwise look and see if we are embedded in a further package
19140 elsif Is_Package_Or_Generic_Package
(Scop
) then
19142 -- If so, get the body of the enclosing package, and look in
19143 -- its package body for the package body we are looking for.
19145 PBody
:= Locate_Corresponding_Body
(Scop
);
19150 return Find_Body_In
(PE
, First
(Declarations
(PBody
)));
19153 -- If we are not embedded in a further package, then the body
19154 -- must be in the same declarative part as we are.
19157 return Find_Body_In
(PE
, Next
(Decl
));
19159 end Locate_Corresponding_Body
;
19161 -- Start of processing for Has_Generic_Body
19164 if Present
(Corresponding_Body
(Decl
)) then
19167 elsif Unit_Requires_Body
(Ent
) then
19170 -- Compilation units cannot have optional bodies
19172 elsif Is_Compilation_Unit
(Ent
) then
19175 -- Otherwise look at what scope we are in
19178 Scop
:= Scope
(Ent
);
19180 -- Case of entity is in other than a package spec, in this case
19181 -- the body, if present, must be in the same declarative part.
19183 if not Is_Package_Or_Generic_Package
(Scop
) then
19188 -- Declaration node may get us a spec, so if so, go to
19189 -- the parent declaration.
19191 P
:= Declaration_Node
(Ent
);
19192 while not Is_List_Member
(P
) loop
19196 return Present
(Find_Body_In
(Ent
, Next
(P
)));
19199 -- If the entity is in a package spec, then we have to locate
19200 -- the corresponding package body, and look there.
19204 PBody
: constant Node_Id
:= Locate_Corresponding_Body
(Scop
);
19212 (Find_Body_In
(Ent
, (First
(Declarations
(PBody
)))));
19217 end Has_Generic_Body
;
19219 -----------------------
19220 -- Insert_Elab_Check --
19221 -----------------------
19223 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
) is
19225 Loc
: constant Source_Ptr
:= Sloc
(N
);
19228 -- The check (N_Raise_Program_Error) node to be inserted
19231 -- If expansion is disabled, do not generate any checks. Also
19232 -- skip checks if any subunits are missing because in either
19233 -- case we lack the full information that we need, and no object
19234 -- file will be created in any case.
19236 if not Expander_Active
or else Subunits_Missing
then
19240 -- If we have a generic instantiation, where Instance_Spec is set,
19241 -- then this field points to a generic instance spec that has
19242 -- been inserted before the instantiation node itself, so that
19243 -- is where we want to insert a check.
19245 if Nkind
(N
) in N_Generic_Instantiation
19246 and then Present
(Instance_Spec
(N
))
19248 Nod
:= Instance_Spec
(N
);
19253 -- Build check node, possibly with condition
19256 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Access_Before_Elaboration
);
19258 if Present
(C
) then
19259 Set_Condition
(Chk
, Make_Op_Not
(Loc
, Right_Opnd
=> C
));
19262 -- If we are inserting at the top level, insert in Aux_Decls
19264 if Nkind
(Parent
(Nod
)) = N_Compilation_Unit
then
19266 ADN
: constant Node_Id
:= Aux_Decls_Node
(Parent
(Nod
));
19269 if No
(Declarations
(ADN
)) then
19270 Set_Declarations
(ADN
, New_List
(Chk
));
19272 Append_To
(Declarations
(ADN
), Chk
);
19278 -- Otherwise just insert as an action on the node in question
19281 Insert_Action
(Nod
, Chk
);
19283 end Insert_Elab_Check
;
19285 -------------------------------
19286 -- Is_Call_Of_Generic_Formal --
19287 -------------------------------
19289 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean is
19291 return Nkind
(N
) in N_Subprogram_Call
19293 -- Always return False if debug flag -gnatd.G is set
19295 and then not Debug_Flag_Dot_GG
19297 -- For now, we detect this by looking for the strange identifier
19298 -- node, whose Chars reflect the name of the generic formal, but
19299 -- the Chars of the Entity references the generic actual.
19301 and then Nkind
(Name
(N
)) = N_Identifier
19302 and then Chars
(Name
(N
)) /= Chars
(Entity
(Name
(N
)));
19303 end Is_Call_Of_Generic_Formal
;
19305 -----------------------------
19306 -- Is_Controlled_Procedure --
19307 -----------------------------
19309 function Is_Controlled_Procedure
19311 Nam
: Name_Id
) return Boolean
19314 -- To qualify, the subprogram must denote a source procedure with
19315 -- name Adjust, Finalize, or Initialize where the sole formal is
19316 -- in out and controlled.
19318 if Comes_From_Source
(Id
) and then Ekind
(Id
) = E_Procedure
then
19320 Formal_Id
: constant Entity_Id
:= First_Formal
(Id
);
19324 Present
(Formal_Id
)
19325 and then Ekind
(Formal_Id
) = E_In_Out_Parameter
19326 and then Is_Controlled
(Etype
(Formal_Id
))
19327 and then No
(Next_Formal
(Formal_Id
))
19328 and then Chars
(Id
) =
19329 Name_Of_Controlled_Prim_Op
(Etype
(Formal_Id
), Nam
);
19334 end Is_Controlled_Procedure
;
19336 -------------------------------
19337 -- Is_Finalization_Procedure --
19338 -------------------------------
19340 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean is
19342 -- Check whether Id is a procedure with at least one parameter
19344 if Ekind
(Id
) = E_Procedure
and then Present
(First_Formal
(Id
)) then
19346 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Id
));
19347 Deep_Fin
: Entity_Id
:= Empty
;
19348 Fin
: Entity_Id
:= Empty
;
19351 -- If the type of the first formal does not require finalization
19352 -- actions, then this is definitely not [Deep_]Finalize.
19354 if not Needs_Finalization
(Typ
) then
19358 -- At this point we have the following scenario:
19360 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
19362 -- Recover the two possible versions of [Deep_]Finalize using the
19363 -- type of the first parameter and compare with the input.
19365 Deep_Fin
:= TSS
(Typ
, TSS_Deep_Finalize
);
19367 if Is_Controlled
(Typ
) then
19368 Fin
:= Find_Controlled_Prim_Op
(Typ
, Name_Finalize
);
19371 return (Present
(Deep_Fin
) and then Id
= Deep_Fin
)
19372 or else (Present
(Fin
) and then Id
= Fin
);
19377 end Is_Finalization_Procedure
;
19383 procedure Output_Calls
19385 Check_Elab_Flag
: Boolean)
19387 function Emit
(Flag
: Boolean) return Boolean;
19388 -- Determine whether to emit an error message based on the combination
19389 -- of flags Check_Elab_Flag and Flag.
19391 function Is_Printable_Error_Name
return Boolean;
19392 -- An internal function, used to determine if a name, stored in the
19393 -- Name_Buffer, is either a non-internal name, or is an internal name
19394 -- that is printable by the error message circuits (i.e. it has a single
19395 -- upper case letter at the end).
19401 function Emit
(Flag
: Boolean) return Boolean is
19403 if Check_Elab_Flag
then
19410 -----------------------------
19411 -- Is_Printable_Error_Name --
19412 -----------------------------
19414 function Is_Printable_Error_Name
return Boolean is
19416 if not Is_Internal_Name
then
19419 elsif Name_Len
= 1 then
19423 Name_Len
:= Name_Len
- 1;
19424 return not Is_Internal_Name
;
19426 end Is_Printable_Error_Name
;
19432 -- Start of processing for Output_Calls
19435 for J
in reverse 1 .. Elab_Call
.Last
loop
19436 Error_Msg_Sloc
:= Elab_Call
.Table
(J
).Cloc
;
19438 Ent
:= Elab_Call
.Table
(J
).Ent
;
19439 Get_Name_String
(Chars
(Ent
));
19441 -- Dynamic elaboration model, warnings controlled by -gnatwl
19443 if Dynamic_Elaboration_Checks
then
19444 if Emit
(Elab_Warnings
) then
19445 if Is_Generic_Unit
(Ent
) then
19446 Error_Msg_NE
("\\?l?& instantiated #", N
, Ent
);
19447 elsif Is_Init_Proc
(Ent
) then
19448 Error_Msg_N
("\\?l?initialization procedure called #", N
);
19449 elsif Is_Printable_Error_Name
then
19450 Error_Msg_NE
("\\?l?& called #", N
, Ent
);
19452 Error_Msg_N
("\\?l?called #", N
);
19456 -- Static elaboration model, info messages controlled by -gnatel
19459 if Emit
(Elab_Info_Messages
) then
19460 if Is_Generic_Unit
(Ent
) then
19461 Error_Msg_NE
("\\?$?& instantiated #", N
, Ent
);
19462 elsif Is_Init_Proc
(Ent
) then
19463 Error_Msg_N
("\\?$?initialization procedure called #", N
);
19464 elsif Is_Printable_Error_Name
then
19465 Error_Msg_NE
("\\?$?& called #", N
, Ent
);
19467 Error_Msg_N
("\\?$?called #", N
);
19474 ----------------------------
19475 -- Same_Elaboration_Scope --
19476 ----------------------------
19478 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean is
19483 -- Find elaboration scope for Scop1
19484 -- This is either a subprogram or a compilation unit.
19487 while S1
/= Standard_Standard
19488 and then not Is_Compilation_Unit
(S1
)
19489 and then Ekind
(S1
) in E_Package | E_Protected_Type | E_Block
19494 -- Find elaboration scope for Scop2
19497 while S2
/= Standard_Standard
19498 and then not Is_Compilation_Unit
(S2
)
19499 and then Ekind
(S2
) in E_Package | E_Protected_Type | E_Block
19505 end Same_Elaboration_Scope
;
19511 procedure Set_C_Scope
is
19513 while not Is_Compilation_Unit
(C_Scope
) loop
19514 C_Scope
:= Scope
(C_Scope
);
19518 --------------------------------
19519 -- Set_Elaboration_Constraint --
19520 --------------------------------
19522 procedure Set_Elaboration_Constraint
19527 Elab_Unit
: Entity_Id
;
19529 -- Check whether this is a call to an Initialize subprogram for a
19530 -- controlled type. Note that Call can also be a 'Access attribute
19531 -- reference, which now generates an elaboration check.
19533 Init_Call
: constant Boolean :=
19534 Nkind
(Call
) = N_Procedure_Call_Statement
19535 and then Is_Controlled_Procedure
(Subp
, Name_Initialize
);
19538 -- If the unit is mentioned in a with_clause of the current unit, it is
19539 -- visible, and we can set the elaboration flag.
19541 if Is_Immediately_Visible
(Scop
)
19542 or else (Is_Child_Unit
(Scop
) and then Is_Visible_Lib_Unit
(Scop
))
19544 Activate_Elaborate_All_Desirable
(Call
, Scop
);
19545 Set_Suppress_Elaboration_Warnings
(Scop
);
19549 -- If this is not an initialization call or a call using object notation
19550 -- we know that the unit of the called entity is in the context, and we
19551 -- can set the flag as well. The unit need not be visible if the call
19552 -- occurs within an instantiation.
19554 if Is_Init_Proc
(Subp
)
19556 or else Nkind
(Original_Node
(Call
)) = N_Selected_Component
19558 null; -- detailed processing follows.
19561 Activate_Elaborate_All_Desirable
(Call
, Scop
);
19562 Set_Suppress_Elaboration_Warnings
(Scop
);
19566 -- If the unit is not in the context, there must be an intermediate unit
19567 -- that is, on which we need to place to elaboration flag. This happens
19568 -- with init proc calls.
19570 if Is_Init_Proc
(Subp
) or else Init_Call
then
19572 -- The initialization call is on an object whose type is not declared
19573 -- in the same scope as the subprogram. The type of the object must
19574 -- be a subtype of the type of operation. This object is the first
19575 -- actual in the call.
19578 Typ
: constant Entity_Id
:=
19579 Etype
(First
(Parameter_Associations
(Call
)));
19581 Elab_Unit
:= Scope
(Typ
);
19582 while Present
(Elab_Unit
)
19583 and then not Is_Compilation_Unit
(Elab_Unit
)
19585 Elab_Unit
:= Scope
(Elab_Unit
);
19589 -- If original node uses selected component notation, the prefix is
19590 -- visible and determines the scope that must be elaborated. After
19591 -- rewriting, the prefix is the first actual in the call.
19593 elsif Nkind
(Original_Node
(Call
)) = N_Selected_Component
then
19594 Elab_Unit
:= Scope
(Etype
(First
(Parameter_Associations
(Call
))));
19596 -- Not one of special cases above
19599 -- Using previously computed scope. If the elaboration check is
19600 -- done after analysis, the scope is not visible any longer, but
19601 -- must still be in the context.
19606 Activate_Elaborate_All_Desirable
(Call
, Elab_Unit
);
19607 Set_Suppress_Elaboration_Warnings
(Elab_Unit
);
19608 end Set_Elaboration_Constraint
;
19614 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
is
19618 -- Check for case of body entity
19619 -- Why is the check for E_Void needed???
19621 if Ekind
(E
) in E_Void | E_Subprogram_Body | E_Package_Body
then
19625 Decl
:= Parent
(Decl
);
19626 exit when Nkind
(Decl
) in N_Proper_Body
;
19629 return Corresponding_Spec
(Decl
);
19640 function Within
(E1
, E2
: Entity_Id
) return Boolean is
19647 elsif Scop
= Standard_Standard
then
19650 Scop
:= Scope
(Scop
);
19655 --------------------------
19656 -- Within_Elaborate_All --
19657 --------------------------
19659 function Within_Elaborate_All
19660 (Unit
: Unit_Number_Type
;
19661 E
: Entity_Id
) return Boolean
19663 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
19664 pragma Pack
(Unit_Number_Set
);
19666 Seen
: Unit_Number_Set
:= (others => False);
19667 -- Seen (X) is True after we have seen unit X in the walk. This is used
19668 -- to prevent processing the same unit more than once.
19670 Result
: Boolean := False;
19672 procedure Helper
(Unit
: Unit_Number_Type
);
19673 -- This helper procedure does all the work for Within_Elaborate_All. It
19674 -- walks the dependency graph, and sets Result to True if it finds an
19675 -- appropriate Elaborate_All.
19681 procedure Helper
(Unit
: Unit_Number_Type
) is
19682 CU
: constant Node_Id
:= Cunit
(Unit
);
19686 Elab_Id
: Entity_Id
;
19690 if Seen
(Unit
) then
19693 Seen
(Unit
) := True;
19696 -- First, check for Elaborate_Alls on this unit
19698 Item
:= First
(Context_Items
(CU
));
19699 while Present
(Item
) loop
19700 if Nkind
(Item
) = N_Pragma
19701 and then Pragma_Name
(Item
) = Name_Elaborate_All
19703 -- Return if some previous error on the pragma itself. The
19704 -- pragma may be unanalyzed, because of a previous error, or
19705 -- if it is the context of a subunit, inherited by its parent.
19707 if Error_Posted
(Item
) or else not Analyzed
(Item
) then
19713 (Expression
(First
(Pragma_Argument_Associations
(Item
))));
19715 if E
= Elab_Id
then
19720 Par
:= Parent
(Unit_Declaration_Node
(Elab_Id
));
19722 Item2
:= First
(Context_Items
(Par
));
19723 while Present
(Item2
) loop
19724 if Nkind
(Item2
) = N_With_Clause
19725 and then Entity
(Name
(Item2
)) = E
19726 and then not Limited_Present
(Item2
)
19739 -- Second, recurse on with's. We could do this as part of the above
19740 -- loop, but it's probably more efficient to have two loops, because
19741 -- the relevant Elaborate_All is likely to be on the initial unit. In
19742 -- other words, we're walking the with's breadth-first. This part is
19743 -- only necessary in the dynamic elaboration model.
19745 if Dynamic_Elaboration_Checks
then
19746 Item
:= First
(Context_Items
(CU
));
19747 while Present
(Item
) loop
19748 if Nkind
(Item
) = N_With_Clause
19749 and then not Limited_Present
(Item
)
19751 -- Note: the following call to Get_Cunit_Unit_Number does a
19752 -- linear search, which could be slow, but it's OK because
19753 -- we're about to give a warning anyway. Also, there might
19754 -- be hundreds of units, but not millions. If it turns out
19755 -- to be a problem, we could store the Get_Cunit_Unit_Number
19756 -- in each N_Compilation_Unit node, but that would involve
19757 -- rearranging N_Compilation_Unit_Aux to make room.
19759 Helper
(Get_Cunit_Unit_Number
(Library_Unit
(Item
)));
19771 -- Start of processing for Within_Elaborate_All
19776 end Within_Elaborate_All
;