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_Finalizer_Proc
(Id
: Entity_Id
) return Boolean;
1782 pragma Inline
(Is_Finalizer_Proc
);
1783 -- Determine whether arbitrary entity Id denotes internally generated
1784 -- routine _Finalizer.
1786 function Is_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean;
1787 pragma Inline
(Is_Initial_Condition_Proc
);
1788 -- Determine whether arbitrary entity Id denotes internally generated
1789 -- routine Initial_Condition.
1791 function Is_Initialized
(Obj_Decl
: Node_Id
) return Boolean;
1792 pragma Inline
(Is_Initialized
);
1793 -- Determine whether object declaration Obj_Decl is initialized
1795 function Is_Invariant_Proc
(Id
: Entity_Id
) return Boolean;
1796 pragma Inline
(Is_Invariant_Proc
);
1797 -- Determine whether arbitrary entity Id denotes an invariant procedure
1799 function Is_Non_Library_Level_Encapsulator
(N
: Node_Id
) return Boolean;
1800 pragma Inline
(Is_Non_Library_Level_Encapsulator
);
1801 -- Determine whether arbitrary node N is a non-library encapsulator
1803 function Is_Partial_Invariant_Proc
(Id
: Entity_Id
) return Boolean;
1804 pragma Inline
(Is_Partial_Invariant_Proc
);
1805 -- Determine whether arbitrary entity Id denotes a partial invariant
1808 function Is_Preelaborated_Unit
(Id
: Entity_Id
) return Boolean;
1809 pragma Inline
(Is_Preelaborated_Unit
);
1810 -- Determine whether arbitrary entity Id denotes a unit which is subject
1811 -- to one of the following pragmas:
1815 -- * Remote_Call_Interface
1819 function Is_Protected_Entry
(Id
: Entity_Id
) return Boolean;
1820 pragma Inline
(Is_Protected_Entry
);
1821 -- Determine whether arbitrary entity Id denotes a protected entry
1823 function Is_Protected_Subp
(Id
: Entity_Id
) return Boolean;
1824 pragma Inline
(Is_Protected_Subp
);
1825 -- Determine whether entity Id denotes a protected subprogram
1827 function Is_Protected_Body_Subp
(Id
: Entity_Id
) return Boolean;
1828 pragma Inline
(Is_Protected_Body_Subp
);
1829 -- Determine whether entity Id denotes the protected or unprotected
1830 -- version of a protected subprogram.
1832 function Is_Scenario
(N
: Node_Id
) return Boolean;
1833 pragma Inline
(Is_Scenario
);
1834 -- Determine whether attribute node N denotes a scenario. The scenario
1835 -- may not necessarily be eligible for ABE processing.
1837 function Is_SPARK_Semantic_Target
(Id
: Entity_Id
) return Boolean;
1838 pragma Inline
(Is_SPARK_Semantic_Target
);
1839 -- Determine whether arbitrary entity Id denotes a source or internally
1840 -- generated subprogram which emulates SPARK semantics.
1842 function Is_Subprogram_Inst
(Id
: Entity_Id
) return Boolean;
1843 pragma Inline
(Is_Subprogram_Inst
);
1844 -- Determine whether arbitrary entity Id denotes a subprogram instance
1846 function Is_Suitable_Access_Taken
(N
: Node_Id
) return Boolean;
1847 pragma Inline
(Is_Suitable_Access_Taken
);
1848 -- Determine whether arbitrary node N denotes a suitable attribute for
1851 function Is_Suitable_Call
(N
: Node_Id
) return Boolean;
1852 pragma Inline
(Is_Suitable_Call
);
1853 -- Determine whether arbitrary node N denotes a suitable call for ABE
1856 function Is_Suitable_Instantiation
(N
: Node_Id
) return Boolean;
1857 pragma Inline
(Is_Suitable_Instantiation
);
1858 -- Determine whether arbitrary node N is a suitable instantiation for
1861 function Is_Suitable_SPARK_Derived_Type
(N
: Node_Id
) return Boolean;
1862 pragma Inline
(Is_Suitable_SPARK_Derived_Type
);
1863 -- Determine whether arbitrary node N denotes a suitable derived type
1864 -- declaration for ABE processing using the SPARK rules.
1866 function Is_Suitable_SPARK_Instantiation
(N
: Node_Id
) return Boolean;
1867 pragma Inline
(Is_Suitable_SPARK_Instantiation
);
1868 -- Determine whether arbitrary node N denotes a suitable instantiation
1869 -- for ABE processing using the SPARK rules.
1871 function Is_Suitable_SPARK_Refined_State_Pragma
1872 (N
: Node_Id
) return Boolean;
1873 pragma Inline
(Is_Suitable_SPARK_Refined_State_Pragma
);
1874 -- Determine whether arbitrary node N denotes a suitable Refined_State
1875 -- pragma for ABE processing using the SPARK rules.
1877 function Is_Suitable_Variable_Assignment
(N
: Node_Id
) return Boolean;
1878 pragma Inline
(Is_Suitable_Variable_Assignment
);
1879 -- Determine whether arbitrary node N denotes a suitable assignment for
1882 function Is_Suitable_Variable_Reference
(N
: Node_Id
) return Boolean;
1883 pragma Inline
(Is_Suitable_Variable_Reference
);
1884 -- Determine whether arbitrary node N is a suitable variable reference
1885 -- for ABE processing.
1887 function Is_Task_Entry
(Id
: Entity_Id
) return Boolean;
1888 pragma Inline
(Is_Task_Entry
);
1889 -- Determine whether arbitrary entity Id denotes a task entry
1891 function Is_Up_Level_Target
1892 (Targ_Decl
: Node_Id
;
1893 In_State
: Processing_In_State
) return Boolean;
1894 pragma Inline
(Is_Up_Level_Target
);
1895 -- Determine whether the current root resides at the declaration level.
1896 -- If this is the case, determine whether a target with by declaration
1897 -- Target_Decl is within a context which encloses the current root or is
1898 -- in a different unit. In_State is the current state of the Processing
1904 -- The following package provides the main entry point for SPARK-related
1905 -- checks and diagnostics.
1907 package SPARK_Processor
is
1913 procedure Check_SPARK_Model_In_Effect
;
1914 pragma Inline
(Check_SPARK_Model_In_Effect
);
1915 -- Determine whether a suitable elaboration model is currently in effect
1916 -- for verifying SPARK rules. Emit a warning if this is not the case.
1918 procedure Check_SPARK_Scenarios
;
1919 pragma Inline
(Check_SPARK_Scenarios
);
1920 -- Examine SPARK scenarios which are not necessarily executable during
1921 -- elaboration, but still requires elaboration-related checks.
1923 end SPARK_Processor
;
1924 use SPARK_Processor
;
1926 -----------------------
1927 -- Local subprograms --
1928 -----------------------
1930 function Assignment_Target
(Asmt
: Node_Id
) return Node_Id
;
1931 pragma Inline
(Assignment_Target
);
1932 -- Obtain the target of assignment statement Asmt
1934 function Call_Name
(Call
: Node_Id
) return Node_Id
;
1935 pragma Inline
(Call_Name
);
1936 -- Obtain the name of an entry, operator, or subprogram call Call
1938 function Canonical_Subprogram
(Subp_Id
: Entity_Id
) return Entity_Id
;
1939 pragma Inline
(Canonical_Subprogram
);
1940 -- Obtain the uniform canonical entity of subprogram Subp_Id
1942 function Compilation_Unit
(Unit_Id
: Entity_Id
) return Node_Id
;
1943 pragma Inline
(Compilation_Unit
);
1944 -- Return the N_Compilation_Unit node of unit Unit_Id
1946 function Elaboration_Phase_Active
return Boolean;
1947 pragma Inline
(Elaboration_Phase_Active
);
1948 -- Determine whether the elaboration phase of the compilation has started
1950 procedure Error_Preelaborated_Call
(N
: Node_Id
);
1951 -- Give an error or warning for a non-static/non-preelaborable call in a
1952 -- preelaborated unit.
1954 procedure Finalize_All_Data_Structures
;
1955 pragma Inline
(Finalize_All_Data_Structures
);
1956 -- Destroy all internal data structures
1958 function Find_Enclosing_Instance
(N
: Node_Id
) return Node_Id
;
1959 pragma Inline
(Find_Enclosing_Instance
);
1960 -- Find the declaration or body of the nearest expanded instance which
1961 -- encloses arbitrary node N. Return Empty if no such instance exists.
1963 function Find_Top_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
;
1964 pragma Inline
(Find_Top_Unit
);
1965 -- Return the top unit which contains arbitrary node or entity N. The unit
1966 -- is obtained by logically unwinding instantiations and subunits when N
1967 -- resides within one.
1969 function Find_Unit_Entity
(N
: Node_Id
) return Entity_Id
;
1970 pragma Inline
(Find_Unit_Entity
);
1971 -- Return the entity of unit N
1973 function First_Formal_Type
(Subp_Id
: Entity_Id
) return Entity_Id
;
1974 pragma Inline
(First_Formal_Type
);
1975 -- Return the type of subprogram Subp_Id's first formal parameter. If the
1976 -- subprogram lacks formal parameters, return Empty.
1978 function Has_Body
(Pack_Decl
: Node_Id
) return Boolean;
1979 pragma Inline
(Has_Body
);
1980 -- Determine whether package declaration Pack_Decl has a corresponding body
1981 -- or would eventually have one.
1983 function In_External_Instance
1985 Target_Decl
: Node_Id
) return Boolean;
1986 pragma Inline
(In_External_Instance
);
1987 -- Determine whether a target desctibed by its declaration Target_Decl
1988 -- resides in a package instance which is external to scenario N.
1990 function In_Main_Context
(N
: Node_Id
) return Boolean;
1991 pragma Inline
(In_Main_Context
);
1992 -- Determine whether arbitrary node N appears within the main compilation
1995 function In_Same_Context
1998 Nested_OK
: Boolean := False) return Boolean;
1999 pragma Inline
(In_Same_Context
);
2000 -- Determine whether two arbitrary nodes N1 and N2 appear within the same
2001 -- context ignoring enclosing library levels. Nested_OK should be set when
2002 -- the context of N1 can enclose that of N2.
2004 procedure Initialize_All_Data_Structures
;
2005 pragma Inline
(Initialize_All_Data_Structures
);
2006 -- Create all internal data structures
2008 function Instantiated_Generic
(Inst
: Node_Id
) return Entity_Id
;
2009 pragma Inline
(Instantiated_Generic
);
2010 -- Obtain the generic instantiated by instance Inst
2012 function Is_Safe_Activation
2014 Task_Rep
: Target_Rep_Id
) return Boolean;
2015 pragma Inline
(Is_Safe_Activation
);
2016 -- Determine whether activation call Call which activates an object of a
2017 -- task type described by representation Task_Rep is always ABE-safe.
2019 function Is_Safe_Call
2021 Subp_Id
: Entity_Id
;
2022 Subp_Rep
: Target_Rep_Id
) return Boolean;
2023 pragma Inline
(Is_Safe_Call
);
2024 -- Determine whether call Call which invokes entry, operator, or subprogram
2025 -- Subp_Id is always ABE-safe. Subp_Rep is the representation of the entry,
2026 -- operator, or subprogram.
2028 function Is_Safe_Instantiation
2031 Gen_Rep
: Target_Rep_Id
) return Boolean;
2032 pragma Inline
(Is_Safe_Instantiation
);
2033 -- Determine whether instantiation Inst which instantiates generic Gen_Id
2034 -- is always ABE-safe. Gen_Rep is the representation of the generic.
2036 function Is_Same_Unit
2037 (Unit_1
: Entity_Id
;
2038 Unit_2
: Entity_Id
) return Boolean;
2039 pragma Inline
(Is_Same_Unit
);
2040 -- Determine whether entities Unit_1 and Unit_2 denote the same unit
2042 function Main_Unit_Entity
return Entity_Id
;
2043 pragma Inline
(Main_Unit_Entity
);
2044 -- Return the entity of the main unit
2046 function Non_Private_View
(Typ
: Entity_Id
) return Entity_Id
;
2047 pragma Inline
(Non_Private_View
);
2048 -- Return the full view of private type Typ if available, otherwise return
2051 function Scenario
(N
: Node_Id
) return Node_Id
;
2052 pragma Inline
(Scenario
);
2053 -- Return the appropriate scenario node for scenario N
2055 procedure Set_Elaboration_Phase
(Status
: Elaboration_Phase_Status
);
2056 pragma Inline
(Set_Elaboration_Phase
);
2057 -- Change the status of the elaboration phase of the compiler to Status
2059 procedure Spec_And_Body_From_Entity
2061 Spec_Decl
: out Node_Id
;
2062 Body_Decl
: out Node_Id
);
2063 pragma Inline
(Spec_And_Body_From_Entity
);
2064 -- Given arbitrary entity Id representing a construct with a spec and body,
2065 -- retrieve declaration of the spec in Spec_Decl and the declaration of the
2066 -- body in Body_Decl.
2068 procedure Spec_And_Body_From_Node
2070 Spec_Decl
: out Node_Id
;
2071 Body_Decl
: out Node_Id
);
2072 pragma Inline
(Spec_And_Body_From_Node
);
2073 -- Given arbitrary node N representing a construct with a spec and body,
2074 -- retrieve declaration of the spec in Spec_Decl and the declaration of
2075 -- the body in Body_Decl.
2077 function Static_Elaboration_Checks
return Boolean;
2078 pragma Inline
(Static_Elaboration_Checks
);
2079 -- Determine whether the static model is in effect
2081 function Unit_Entity
(Unit_Id
: Entity_Id
) return Entity_Id
;
2082 pragma Inline
(Unit_Entity
);
2083 -- Return the entity of the initial declaration for unit Unit_Id
2085 procedure Update_Elaboration_Scenario
(New_N
: Node_Id
; Old_N
: Node_Id
);
2086 pragma Inline
(Update_Elaboration_Scenario
);
2087 -- Update all relevant internal data structures when scenario Old_N is
2088 -- transformed into scenario New_N by Atree.Rewrite.
2090 ----------------------
2091 -- Active_Scenarios --
2092 ----------------------
2094 package body Active_Scenarios
is
2096 -----------------------
2097 -- Local subprograms --
2098 -----------------------
2100 procedure Output_Access_Taken
2102 Attr_Rep
: Scenario_Rep_Id
;
2103 Error_Nod
: Node_Id
);
2104 pragma Inline
(Output_Access_Taken
);
2105 -- Emit a specific diagnostic message for 'Access attribute reference
2106 -- Attr with representation Attr_Rep. The message is associated with
2109 procedure Output_Active_Scenario
2111 Error_Nod
: Node_Id
;
2112 In_State
: Processing_In_State
);
2113 pragma Inline
(Output_Active_Scenario
);
2114 -- Top level dispatcher for outputting a scenario. Emit a specific
2115 -- diagnostic message for scenario N. The message is associated with
2116 -- node Error_Nod. In_State is the current state of the Processing
2119 procedure Output_Call
2121 Call_Rep
: Scenario_Rep_Id
;
2122 Error_Nod
: Node_Id
);
2123 pragma Inline
(Output_Call
);
2124 -- Emit a diagnostic message for call Call with representation Call_Rep.
2125 -- The message is associated with node Error_Nod.
2127 procedure Output_Header
(Error_Nod
: Node_Id
);
2128 pragma Inline
(Output_Header
);
2129 -- Emit a specific diagnostic message for the unit of the root scenario.
2130 -- The message is associated with node Error_Nod.
2132 procedure Output_Instantiation
2134 Inst_Rep
: Scenario_Rep_Id
;
2135 Error_Nod
: Node_Id
);
2136 pragma Inline
(Output_Instantiation
);
2137 -- Emit a specific diagnostic message for instantiation Inst with
2138 -- representation Inst_Rep. The message is associated with node
2141 procedure Output_Refined_State_Pragma
2143 Prag_Rep
: Scenario_Rep_Id
;
2144 Error_Nod
: Node_Id
);
2145 pragma Inline
(Output_Refined_State_Pragma
);
2146 -- Emit a specific diagnostic message for Refined_State pragma Prag
2147 -- with representation Prag_Rep. The message is associated with node
2150 procedure Output_Task_Activation
2152 Call_Rep
: Scenario_Rep_Id
;
2153 Error_Nod
: Node_Id
);
2154 pragma Inline
(Output_Task_Activation
);
2155 -- Emit a specific diagnostic message for activation call Call
2156 -- with representation Call_Rep. The message is associated with
2159 procedure Output_Variable_Assignment
2161 Asmt_Rep
: Scenario_Rep_Id
;
2162 Error_Nod
: Node_Id
);
2163 pragma Inline
(Output_Variable_Assignment
);
2164 -- Emit a specific diagnostic message for assignment statement Asmt
2165 -- with representation Asmt_Rep. The message is associated with node
2168 procedure Output_Variable_Reference
2170 Ref_Rep
: Scenario_Rep_Id
;
2171 Error_Nod
: Node_Id
);
2172 pragma Inline
(Output_Variable_Reference
);
2173 -- Emit a specific diagnostic message for read reference Ref with
2174 -- representation Ref_Rep. The message is associated with node
2181 procedure Output_Access_Taken
2183 Attr_Rep
: Scenario_Rep_Id
;
2184 Error_Nod
: Node_Id
)
2186 Subp_Id
: constant Entity_Id
:= Target
(Attr_Rep
);
2189 Error_Msg_Name_1
:= Attribute_Name
(Attr
);
2190 Error_Msg_Sloc
:= Sloc
(Attr
);
2191 Error_Msg_NE
("\\ % of & taken #", Error_Nod
, Subp_Id
);
2192 end Output_Access_Taken
;
2194 ----------------------------
2195 -- Output_Active_Scenario --
2196 ----------------------------
2198 procedure Output_Active_Scenario
2200 Error_Nod
: Node_Id
;
2201 In_State
: Processing_In_State
)
2203 Scen
: constant Node_Id
:= Scenario
(N
);
2204 Scen_Rep
: Scenario_Rep_Id
;
2209 if Is_Suitable_Access_Taken
(Scen
) then
2212 Attr_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2213 Error_Nod
=> Error_Nod
);
2215 -- Call or task activation
2217 elsif Is_Suitable_Call
(Scen
) then
2218 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
2220 if Kind
(Scen_Rep
) = Call_Scenario
then
2223 Call_Rep
=> Scen_Rep
,
2224 Error_Nod
=> Error_Nod
);
2227 pragma Assert
(Kind
(Scen_Rep
) = Task_Activation_Scenario
);
2229 Output_Task_Activation
2231 Call_Rep
=> Scen_Rep
,
2232 Error_Nod
=> Error_Nod
);
2237 elsif Is_Suitable_Instantiation
(Scen
) then
2238 Output_Instantiation
2240 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2241 Error_Nod
=> Error_Nod
);
2243 -- Pragma Refined_State
2245 elsif Is_Suitable_SPARK_Refined_State_Pragma
(Scen
) then
2246 Output_Refined_State_Pragma
2248 Prag_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2249 Error_Nod
=> Error_Nod
);
2251 -- Variable assignment
2253 elsif Is_Suitable_Variable_Assignment
(Scen
) then
2254 Output_Variable_Assignment
2256 Asmt_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2257 Error_Nod
=> Error_Nod
);
2259 -- Variable reference
2261 elsif Is_Suitable_Variable_Reference
(Scen
) then
2262 Output_Variable_Reference
2264 Ref_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
2265 Error_Nod
=> Error_Nod
);
2267 end Output_Active_Scenario
;
2269 -----------------------------
2270 -- Output_Active_Scenarios --
2271 -----------------------------
2273 procedure Output_Active_Scenarios
2274 (Error_Nod
: Node_Id
;
2275 In_State
: Processing_In_State
)
2277 package Scenarios
renames Active_Scenario_Stack
;
2279 Header_Posted
: Boolean := False;
2282 -- Output the contents of the active scenario stack starting from the
2283 -- bottom, or the least recent scenario.
2285 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
2286 if not Header_Posted
then
2287 Output_Header
(Error_Nod
);
2288 Header_Posted
:= True;
2291 Output_Active_Scenario
2292 (N
=> Scenarios
.Table
(Index
),
2293 Error_Nod
=> Error_Nod
,
2294 In_State
=> In_State
);
2296 end Output_Active_Scenarios
;
2302 procedure Output_Call
2304 Call_Rep
: Scenario_Rep_Id
;
2305 Error_Nod
: Node_Id
)
2307 procedure Output_Accept_Alternative
(Alt_Id
: Entity_Id
);
2308 pragma Inline
(Output_Accept_Alternative
);
2309 -- Emit a specific diagnostic message concerning accept alternative
2310 -- with entity Alt_Id.
2312 procedure Output_Call
(Subp_Id
: Entity_Id
; Kind
: String);
2313 pragma Inline
(Output_Call
);
2314 -- Emit a specific diagnostic message concerning a call of kind Kind
2315 -- which invokes subprogram Subp_Id.
2317 procedure Output_Type_Actions
(Subp_Id
: Entity_Id
; Action
: String);
2318 pragma Inline
(Output_Type_Actions
);
2319 -- Emit a specific diagnostic message concerning action Action of a
2320 -- type performed by subprogram Subp_Id.
2322 procedure Output_Verification_Call
2326 pragma Inline
(Output_Verification_Call
);
2327 -- Emit a specific diagnostic message concerning the verification of
2328 -- predicate Pred applied to related entity Id with kind Id_Kind.
2330 -------------------------------
2331 -- Output_Accept_Alternative --
2332 -------------------------------
2334 procedure Output_Accept_Alternative
(Alt_Id
: Entity_Id
) is
2335 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Alt_Id
);
2338 pragma Assert
(Present
(Entry_Id
));
2340 Error_Msg_NE
("\\ entry & selected #", Error_Nod
, Entry_Id
);
2341 end Output_Accept_Alternative
;
2347 procedure Output_Call
(Subp_Id
: Entity_Id
; Kind
: String) is
2349 Error_Msg_NE
("\\ " & Kind
& " & called #", Error_Nod
, Subp_Id
);
2352 -------------------------
2353 -- Output_Type_Actions --
2354 -------------------------
2356 procedure Output_Type_Actions
2357 (Subp_Id
: Entity_Id
;
2360 Typ
: constant Entity_Id
:= First_Formal_Type
(Subp_Id
);
2363 pragma Assert
(Present
(Typ
));
2366 ("\\ " & Action
& " actions for type & #", Error_Nod
, Typ
);
2367 end Output_Type_Actions
;
2369 ------------------------------
2370 -- Output_Verification_Call --
2371 ------------------------------
2373 procedure Output_Verification_Call
2379 pragma Assert
(Present
(Id
));
2382 ("\\ " & Pred
& " of " & Id_Kind
& " & verified #",
2384 end Output_Verification_Call
;
2388 Subp_Id
: constant Entity_Id
:= Target
(Call_Rep
);
2390 -- Start of processing for Output_Call
2393 Error_Msg_Sloc
:= Sloc
(Call
);
2395 -- Accept alternative
2397 if Is_Accept_Alternative_Proc
(Subp_Id
) then
2398 Output_Accept_Alternative
(Subp_Id
);
2402 elsif Is_TSS
(Subp_Id
, TSS_Deep_Adjust
) then
2403 Output_Type_Actions
(Subp_Id
, "adjustment");
2405 -- Default_Initial_Condition
2407 elsif Is_Default_Initial_Condition_Proc
(Subp_Id
) then
2409 -- Only do output for a normal DIC procedure, since partial DIC
2410 -- procedures are subsidiary to those.
2412 if not Is_Partial_DIC_Procedure
(Subp_Id
) then
2413 Output_Verification_Call
2414 (Pred
=> "Default_Initial_Condition",
2415 Id
=> First_Formal_Type
(Subp_Id
),
2421 elsif Is_Protected_Entry
(Subp_Id
) then
2422 Output_Call
(Subp_Id
, "entry");
2424 -- Task entry calls are never processed because the entry being
2425 -- invoked does not have a corresponding "body", it has a select. A
2426 -- task entry call appears in the stack of active scenarios for the
2427 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
2430 elsif Is_Task_Entry
(Subp_Id
) then
2435 elsif Is_TSS
(Subp_Id
, TSS_Deep_Finalize
) then
2436 Output_Type_Actions
(Subp_Id
, "finalization");
2438 -- Calls to _Finalizer procedures must not appear in the output
2439 -- because this creates confusing noise.
2441 elsif Is_Finalizer_Proc
(Subp_Id
) then
2444 -- Initial_Condition
2446 elsif Is_Initial_Condition_Proc
(Subp_Id
) then
2447 Output_Verification_Call
2448 (Pred
=> "Initial_Condition",
2449 Id
=> Find_Enclosing_Scope
(Call
),
2450 Id_Kind
=> "package");
2454 elsif Is_Init_Proc
(Subp_Id
)
2455 or else Is_TSS
(Subp_Id
, TSS_Deep_Initialize
)
2457 Output_Type_Actions
(Subp_Id
, "initialization");
2461 elsif Is_Invariant_Proc
(Subp_Id
) then
2462 Output_Verification_Call
2463 (Pred
=> "invariants",
2464 Id
=> First_Formal_Type
(Subp_Id
),
2467 -- Partial invariant calls must not appear in the output because this
2468 -- creates confusing noise. Note that a partial invariant is always
2469 -- invoked by the "full" invariant which is already placed on the
2472 elsif Is_Partial_Invariant_Proc
(Subp_Id
) then
2475 -- Subprograms must come last because some of the previous cases fall
2476 -- under this category.
2478 elsif Ekind
(Subp_Id
) = E_Function
then
2479 Output_Call
(Subp_Id
, "function");
2481 elsif Ekind
(Subp_Id
) = E_Procedure
then
2482 Output_Call
(Subp_Id
, "procedure");
2485 pragma Assert
(False);
2494 procedure Output_Header
(Error_Nod
: Node_Id
) is
2495 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Root_Scenario
);
2498 if Ekind
(Unit_Id
) = E_Package
then
2499 Error_Msg_NE
("\\ spec of unit & elaborated", Error_Nod
, Unit_Id
);
2501 elsif Ekind
(Unit_Id
) = E_Package_Body
then
2502 Error_Msg_NE
("\\ body of unit & elaborated", Error_Nod
, Unit_Id
);
2505 Error_Msg_NE
("\\ in body of unit &", Error_Nod
, Unit_Id
);
2509 --------------------------
2510 -- Output_Instantiation --
2511 --------------------------
2513 procedure Output_Instantiation
2515 Inst_Rep
: Scenario_Rep_Id
;
2516 Error_Nod
: Node_Id
)
2518 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String);
2519 pragma Inline
(Output_Instantiation
);
2520 -- Emit a specific diagnostic message concerning an instantiation of
2521 -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
2523 --------------------------
2524 -- Output_Instantiation --
2525 --------------------------
2527 procedure Output_Instantiation
(Gen_Id
: Entity_Id
; Kind
: String) is
2530 ("\\ " & Kind
& " & instantiated as & #", Error_Nod
, Gen_Id
);
2531 end Output_Instantiation
;
2535 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
2537 -- Start of processing for Output_Instantiation
2540 Error_Msg_Node_2
:= Defining_Entity
(Inst
);
2541 Error_Msg_Sloc
:= Sloc
(Inst
);
2543 if Nkind
(Inst
) = N_Function_Instantiation
then
2544 Output_Instantiation
(Gen_Id
, "function");
2546 elsif Nkind
(Inst
) = N_Package_Instantiation
then
2547 Output_Instantiation
(Gen_Id
, "package");
2549 elsif Nkind
(Inst
) = N_Procedure_Instantiation
then
2550 Output_Instantiation
(Gen_Id
, "procedure");
2553 pragma Assert
(False);
2556 end Output_Instantiation
;
2558 ---------------------------------
2559 -- Output_Refined_State_Pragma --
2560 ---------------------------------
2562 procedure Output_Refined_State_Pragma
2564 Prag_Rep
: Scenario_Rep_Id
;
2565 Error_Nod
: Node_Id
)
2567 pragma Unreferenced
(Prag_Rep
);
2570 Error_Msg_Sloc
:= Sloc
(Prag
);
2571 Error_Msg_N
("\\ refinement constituents read #", Error_Nod
);
2572 end Output_Refined_State_Pragma
;
2574 ----------------------------
2575 -- Output_Task_Activation --
2576 ----------------------------
2578 procedure Output_Task_Activation
2580 Call_Rep
: Scenario_Rep_Id
;
2581 Error_Nod
: Node_Id
)
2583 pragma Unreferenced
(Call_Rep
);
2585 function Find_Activator
return Entity_Id
;
2586 -- Find the nearest enclosing construct which houses call Call
2588 --------------------
2589 -- Find_Activator --
2590 --------------------
2592 function Find_Activator
return Entity_Id
is
2596 -- Climb the parent chain looking for a package [body] or a
2597 -- construct with a statement sequence.
2599 Par
:= Parent
(Call
);
2600 while Present
(Par
) loop
2601 if Nkind
(Par
) in N_Package_Body | N_Package_Declaration
then
2602 return Defining_Entity
(Par
);
2604 elsif Nkind
(Par
) = N_Handled_Sequence_Of_Statements
then
2605 return Defining_Entity
(Parent
(Par
));
2608 Par
:= Parent
(Par
);
2616 Activator
: constant Entity_Id
:= Find_Activator
;
2618 -- Start of processing for Output_Task_Activation
2621 pragma Assert
(Present
(Activator
));
2623 Error_Msg_NE
("\\ local tasks of & activated", Error_Nod
, Activator
);
2624 end Output_Task_Activation
;
2626 --------------------------------
2627 -- Output_Variable_Assignment --
2628 --------------------------------
2630 procedure Output_Variable_Assignment
2632 Asmt_Rep
: Scenario_Rep_Id
;
2633 Error_Nod
: Node_Id
)
2635 Var_Id
: constant Entity_Id
:= Target
(Asmt_Rep
);
2638 Error_Msg_Sloc
:= Sloc
(Asmt
);
2639 Error_Msg_NE
("\\ variable & assigned #", Error_Nod
, Var_Id
);
2640 end Output_Variable_Assignment
;
2642 -------------------------------
2643 -- Output_Variable_Reference --
2644 -------------------------------
2646 procedure Output_Variable_Reference
2648 Ref_Rep
: Scenario_Rep_Id
;
2649 Error_Nod
: Node_Id
)
2651 Var_Id
: constant Entity_Id
:= Target
(Ref_Rep
);
2654 Error_Msg_Sloc
:= Sloc
(Ref
);
2655 Error_Msg_NE
("\\ variable & read #", Error_Nod
, Var_Id
);
2656 end Output_Variable_Reference
;
2658 -------------------------
2659 -- Pop_Active_Scenario --
2660 -------------------------
2662 procedure Pop_Active_Scenario
(N
: Node_Id
) is
2663 package Scenarios
renames Active_Scenario_Stack
;
2664 Top
: Node_Id
renames Scenarios
.Table
(Scenarios
.Last
);
2667 pragma Assert
(Top
= N
);
2668 Scenarios
.Decrement_Last
;
2669 end Pop_Active_Scenario
;
2671 --------------------------
2672 -- Push_Active_Scenario --
2673 --------------------------
2675 procedure Push_Active_Scenario
(N
: Node_Id
) is
2677 Active_Scenario_Stack
.Append
(N
);
2678 end Push_Active_Scenario
;
2684 function Root_Scenario
return Node_Id
is
2685 package Scenarios
renames Active_Scenario_Stack
;
2688 -- Ensure that the scenario stack has at least one active scenario in
2689 -- it. The one at the bottom (index First) is the root scenario.
2691 pragma Assert
(Scenarios
.Last
>= Scenarios
.First
);
2692 return Scenarios
.Table
(Scenarios
.First
);
2694 end Active_Scenarios
;
2696 --------------------------
2697 -- Activation_Processor --
2698 --------------------------
2700 package body Activation_Processor
is
2702 ------------------------
2703 -- Process_Activation --
2704 ------------------------
2706 procedure Process_Activation
2708 Call_Rep
: Scenario_Rep_Id
;
2709 Processor
: Activation_Processor_Ptr
;
2710 In_State
: Processing_In_State
)
2712 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
);
2713 pragma Inline
(Process_Task_Object
);
2714 -- Invoke Processor for task object Obj_Id of type Typ
2716 procedure Process_Task_Objects
2717 (Task_Objs
: NE_List
.Doubly_Linked_List
);
2718 pragma Inline
(Process_Task_Objects
);
2719 -- Invoke Processor for all task objects found in list Task_Objs
2721 procedure Traverse_List
2723 Task_Objs
: NE_List
.Doubly_Linked_List
);
2724 pragma Inline
(Traverse_List
);
2725 -- Traverse declarative or statement list List while searching for
2726 -- objects of a task type, or containing task components. If such an
2727 -- object is found, first save it in list Task_Objs and then invoke
2730 -------------------------
2731 -- Process_Task_Object --
2732 -------------------------
2734 procedure Process_Task_Object
(Obj_Id
: Entity_Id
; Typ
: Entity_Id
) is
2735 Root_Typ
: constant Entity_Id
:=
2736 Non_Private_View
(Root_Type
(Typ
));
2737 Comp_Id
: Entity_Id
;
2738 Obj_Rep
: Target_Rep_Id
;
2739 Root_Rep
: Target_Rep_Id
;
2741 New_In_State
: Processing_In_State
:= In_State
;
2742 -- Each step of the Processing phase constitutes a new state
2745 if Is_Task_Type
(Typ
) then
2746 Obj_Rep
:= Target_Representation_Of
(Obj_Id
, New_In_State
);
2747 Root_Rep
:= Target_Representation_Of
(Root_Typ
, New_In_State
);
2749 -- Warnings are suppressed when a prior scenario is already in
2750 -- that mode, or when the object, activation call, or task type
2751 -- have warnings suppressed. Update the state of the Processing
2752 -- phase to reflect this.
2754 New_In_State
.Suppress_Warnings
:=
2755 New_In_State
.Suppress_Warnings
2756 or else not Elaboration_Warnings_OK
(Call_Rep
)
2757 or else not Elaboration_Warnings_OK
(Obj_Rep
)
2758 or else not Elaboration_Warnings_OK
(Root_Rep
);
2760 -- Update the state of the Processing phase to indicate that
2761 -- any further traversal is now within a task body.
2763 New_In_State
.Within_Task_Body
:= True;
2765 -- Associate the current task type with the activation call
2767 Set_Activated_Task_Type
(Call_Rep
, Root_Typ
);
2769 -- Process the activation of the current task object by calling
2770 -- the supplied processor.
2774 Call_Rep
=> Call_Rep
,
2777 Task_Typ
=> Root_Typ
,
2778 Task_Rep
=> Root_Rep
,
2779 In_State
=> New_In_State
);
2781 -- Reset the association between the current task and the
2784 Set_Activated_Task_Type
(Call_Rep
, Empty
);
2786 -- Examine the component type when the object is an array
2788 elsif Is_Array_Type
(Typ
) and then Has_Task
(Root_Typ
) then
2791 Typ
=> Component_Type
(Typ
));
2793 -- Examine individual component types when the object is a record
2795 elsif Is_Record_Type
(Typ
) and then Has_Task
(Root_Typ
) then
2796 Comp_Id
:= First_Component
(Typ
);
2797 while Present
(Comp_Id
) loop
2800 Typ
=> Etype
(Comp_Id
));
2802 Next_Component
(Comp_Id
);
2805 end Process_Task_Object
;
2807 --------------------------
2808 -- Process_Task_Objects --
2809 --------------------------
2811 procedure Process_Task_Objects
2812 (Task_Objs
: NE_List
.Doubly_Linked_List
)
2814 Iter
: NE_List
.Iterator
;
2818 Iter
:= NE_List
.Iterate
(Task_Objs
);
2819 while NE_List
.Has_Next
(Iter
) loop
2820 NE_List
.Next
(Iter
, Obj_Id
);
2824 Typ
=> Etype
(Obj_Id
));
2826 end Process_Task_Objects
;
2832 procedure Traverse_List
2834 Task_Objs
: NE_List
.Doubly_Linked_List
)
2837 Item_Id
: Entity_Id
;
2838 Item_Typ
: Entity_Id
;
2841 -- Examine the contents of the list looking for an object
2842 -- declaration of a task type or one that contains a task
2845 Item
:= First
(List
);
2846 while Present
(Item
) loop
2847 if Nkind
(Item
) = N_Object_Declaration
then
2848 Item_Id
:= Defining_Entity
(Item
);
2849 Item_Typ
:= Etype
(Item_Id
);
2851 if Has_Task
(Item_Typ
) then
2853 -- The object is either of a task type, or contains a
2854 -- task component. Save it in the list of task objects
2855 -- associated with the activation call.
2857 NE_List
.Append
(Task_Objs
, Item_Id
);
2873 Task_Objs
: NE_List
.Doubly_Linked_List
;
2875 -- Start of processing for Process_Activation
2878 -- Nothing to do when the activation is a guaranteed ABE
2880 if Is_Known_Guaranteed_ABE
(Call
) then
2884 Task_Objs
:= Activated_Task_Objects
(Call_Rep
);
2886 -- The activation call has been processed at least once, and all
2887 -- task objects have already been collected. Directly process the
2888 -- objects without having to reexamine the context of the call.
2890 if NE_List
.Present
(Task_Objs
) then
2891 Process_Task_Objects
(Task_Objs
);
2893 -- Otherwise the activation call is being processed for the first
2894 -- time. Collect all task objects in case the call is reprocessed
2898 Task_Objs
:= NE_List
.Create
;
2899 Set_Activated_Task_Objects
(Call_Rep
, Task_Objs
);
2901 -- Find the context of the activation call where all task objects
2902 -- being activated are declared. This is usually the parent of the
2905 Context
:= Parent
(Call
);
2907 -- Handle the case where the activation call appears within the
2908 -- handled statements of a block or a body.
2910 if Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
2911 Context
:= Parent
(Context
);
2914 -- Process all task objects in both the spec and body when the
2915 -- activation call appears in a package body.
2917 if Nkind
(Context
) = N_Package_Body
then
2920 (Unit_Declaration_Node
(Corresponding_Spec
(Context
)));
2923 (List
=> Visible_Declarations
(Spec
),
2924 Task_Objs
=> Task_Objs
);
2927 (List
=> Private_Declarations
(Spec
),
2928 Task_Objs
=> Task_Objs
);
2931 (List
=> Declarations
(Context
),
2932 Task_Objs
=> Task_Objs
);
2934 -- Process all task objects in the spec when the activation call
2935 -- appears in a package spec.
2937 elsif Nkind
(Context
) = N_Package_Specification
then
2939 (List
=> Visible_Declarations
(Context
),
2940 Task_Objs
=> Task_Objs
);
2943 (List
=> Private_Declarations
(Context
),
2944 Task_Objs
=> Task_Objs
);
2946 -- Otherwise the context must be a block or a body. Process all
2947 -- task objects found in the declarations.
2952 N_Block_Statement | N_Entry_Body | N_Protected_Body |
2953 N_Subprogram_Body | N_Task_Body
);
2956 (List
=> Declarations
(Context
),
2957 Task_Objs
=> Task_Objs
);
2960 end Process_Activation
;
2961 end Activation_Processor
;
2963 -----------------------
2964 -- Assignment_Target --
2965 -----------------------
2967 function Assignment_Target
(Asmt
: Node_Id
) return Node_Id
is
2973 -- When the name denotes an array or record component, find the whole
2976 while Nkind
(Nam
) in
2977 N_Explicit_Dereference | N_Indexed_Component |
2978 N_Selected_Component | N_Slice
2980 Nam
:= Prefix
(Nam
);
2984 end Assignment_Target
;
2986 --------------------
2987 -- Body_Processor --
2988 --------------------
2990 package body Body_Processor
is
2992 ---------------------
2993 -- Data structures --
2994 ---------------------
2996 -- The following map relates scenario lists to subprogram bodies
2998 Nested_Scenarios_Map
: NE_List_Map
.Dynamic_Hash_Table
:= NE_List_Map
.Nil
;
3000 -- The following set contains all subprogram bodies that have been
3001 -- processed by routine Traverse_Body.
3003 Traversed_Bodies_Set
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
3005 -----------------------
3006 -- Local subprograms --
3007 -----------------------
3009 function Is_Traversed_Body
(N
: Node_Id
) return Boolean;
3010 pragma Inline
(Is_Traversed_Body
);
3011 -- Determine whether subprogram body N has already been traversed
3013 function Nested_Scenarios
3014 (N
: Node_Id
) return NE_List
.Doubly_Linked_List
;
3015 pragma Inline
(Nested_Scenarios
);
3016 -- Obtain the list of scenarios associated with subprogram body N
3018 procedure Set_Is_Traversed_Body
(N
: Node_Id
);
3019 pragma Inline
(Set_Is_Traversed_Body
);
3020 -- Mark subprogram body N as traversed
3022 procedure Set_Nested_Scenarios
3024 Scenarios
: NE_List
.Doubly_Linked_List
);
3025 pragma Inline
(Set_Nested_Scenarios
);
3026 -- Associate scenario list Scenarios with subprogram body N
3028 -----------------------------
3029 -- Finalize_Body_Processor --
3030 -----------------------------
3032 procedure Finalize_Body_Processor
is
3034 NE_List_Map
.Destroy
(Nested_Scenarios_Map
);
3035 NE_Set
.Destroy
(Traversed_Bodies_Set
);
3036 end Finalize_Body_Processor
;
3038 -------------------------------
3039 -- Initialize_Body_Processor --
3040 -------------------------------
3042 procedure Initialize_Body_Processor
is
3044 Nested_Scenarios_Map
:= NE_List_Map
.Create
(250);
3045 Traversed_Bodies_Set
:= NE_Set
.Create
(250);
3046 end Initialize_Body_Processor
;
3048 -----------------------
3049 -- Is_Traversed_Body --
3050 -----------------------
3052 function Is_Traversed_Body
(N
: Node_Id
) return Boolean is
3053 pragma Assert
(Present
(N
));
3055 return NE_Set
.Contains
(Traversed_Bodies_Set
, N
);
3056 end Is_Traversed_Body
;
3058 ----------------------
3059 -- Nested_Scenarios --
3060 ----------------------
3062 function Nested_Scenarios
3063 (N
: Node_Id
) return NE_List
.Doubly_Linked_List
3065 pragma Assert
(Present
(N
));
3066 pragma Assert
(Nkind
(N
) = N_Subprogram_Body
);
3069 return NE_List_Map
.Get
(Nested_Scenarios_Map
, N
);
3070 end Nested_Scenarios
;
3072 ----------------------------
3073 -- Reset_Traversed_Bodies --
3074 ----------------------------
3076 procedure Reset_Traversed_Bodies
is
3078 NE_Set
.Reset
(Traversed_Bodies_Set
);
3079 end Reset_Traversed_Bodies
;
3081 ---------------------------
3082 -- Set_Is_Traversed_Body --
3083 ---------------------------
3085 procedure Set_Is_Traversed_Body
(N
: Node_Id
) is
3086 pragma Assert
(Present
(N
));
3089 NE_Set
.Insert
(Traversed_Bodies_Set
, N
);
3090 end Set_Is_Traversed_Body
;
3092 --------------------------
3093 -- Set_Nested_Scenarios --
3094 --------------------------
3096 procedure Set_Nested_Scenarios
3098 Scenarios
: NE_List
.Doubly_Linked_List
)
3100 pragma Assert
(Present
(N
));
3102 NE_List_Map
.Put
(Nested_Scenarios_Map
, N
, Scenarios
);
3103 end Set_Nested_Scenarios
;
3109 procedure Traverse_Body
3111 Requires_Processing
: Scenario_Predicate_Ptr
;
3112 Processor
: Scenario_Processor_Ptr
;
3113 In_State
: Processing_In_State
)
3115 Scenarios
: NE_List
.Doubly_Linked_List
:= NE_List
.Nil
;
3116 -- The list of scenarios that appear within the declarations and
3117 -- statement of subprogram body N. The variable is intentionally
3118 -- global because Is_Potential_Scenario needs to populate it.
3120 function In_Task_Body
(Nod
: Node_Id
) return Boolean;
3121 pragma Inline
(In_Task_Body
);
3122 -- Determine whether arbitrary node Nod appears within a task body
3124 function Is_Synchronous_Suspension_Call
3125 (Nod
: Node_Id
) return Boolean;
3126 pragma Inline
(Is_Synchronous_Suspension_Call
);
3127 -- Determine whether arbitrary node Nod denotes a call to one of
3130 -- Ada.Synchronous_Barriers.Wait_For_Release
3131 -- Ada.Synchronous_Task_Control.Suspend_Until_True
3133 procedure Traverse_Collected_Scenarios
;
3134 pragma Inline
(Traverse_Collected_Scenarios
);
3135 -- Traverse the already collected scenarios in list Scenarios by
3136 -- invoking Processor on each individual one.
3138 procedure Traverse_List
(List
: List_Id
);
3139 pragma Inline
(Traverse_List
);
3140 -- Invoke Traverse_Potential_Scenarios on each node in list List
3142 function Traverse_Potential_Scenario
3143 (Scen
: Node_Id
) return Traverse_Result
;
3144 pragma Inline
(Traverse_Potential_Scenario
);
3145 -- Determine whether arbitrary node Scen is a suitable scenario using
3146 -- predicate Is_Scenario and traverse it by invoking Processor on it.
3148 procedure Traverse_Potential_Scenarios
is
3149 new Traverse_Proc
(Traverse_Potential_Scenario
);
3155 function In_Task_Body
(Nod
: Node_Id
) return Boolean is
3159 -- Climb the parent chain looking for a task body [procedure]
3162 while Present
(Par
) loop
3163 if Nkind
(Par
) = N_Task_Body
then
3166 elsif Nkind
(Par
) = N_Subprogram_Body
3167 and then Is_Task_Body_Procedure
(Par
)
3171 -- Prevent the search from going too far. Note that this test
3172 -- shares nodes with the two cases above, and must come last.
3174 elsif Is_Body_Or_Package_Declaration
(Par
) then
3178 Par
:= Parent
(Par
);
3184 ------------------------------------
3185 -- Is_Synchronous_Suspension_Call --
3186 ------------------------------------
3188 function Is_Synchronous_Suspension_Call
3189 (Nod
: Node_Id
) return Boolean
3191 Subp_Id
: Entity_Id
;
3194 -- To qualify, the call must invoke one of the runtime routines
3195 -- which perform synchronous suspension.
3197 if Is_Suitable_Call
(Nod
) then
3198 Subp_Id
:= Target
(Nod
);
3201 Is_RTE
(Subp_Id
, RE_Suspend_Until_True
)
3203 Is_RTE
(Subp_Id
, RE_Wait_For_Release
);
3207 end Is_Synchronous_Suspension_Call
;
3209 ----------------------------------
3210 -- Traverse_Collected_Scenarios --
3211 ----------------------------------
3213 procedure Traverse_Collected_Scenarios
is
3214 Iter
: NE_List
.Iterator
;
3218 Iter
:= NE_List
.Iterate
(Scenarios
);
3219 while NE_List
.Has_Next
(Iter
) loop
3220 NE_List
.Next
(Iter
, Scen
);
3222 -- The current scenario satisfies the input predicate, process
3225 if Requires_Processing
.all (Scen
) then
3226 Processor
.all (Scen
, In_State
);
3229 end Traverse_Collected_Scenarios
;
3235 procedure Traverse_List
(List
: List_Id
) is
3239 Scen
:= First
(List
);
3240 while Present
(Scen
) loop
3241 Traverse_Potential_Scenarios
(Scen
);
3246 ---------------------------------
3247 -- Traverse_Potential_Scenario --
3248 ---------------------------------
3250 function Traverse_Potential_Scenario
3251 (Scen
: Node_Id
) return Traverse_Result
3256 -- Skip constructs which do not have elaboration of their own and
3257 -- need to be elaborated by other means such as invocation, task
3260 if Is_Non_Library_Level_Encapsulator
(Scen
) then
3263 -- Terminate the traversal of a task body when encountering an
3264 -- accept or select statement, and
3266 -- * Entry calls during elaboration are not allowed. In this
3267 -- case the accept or select statement will cause the task
3268 -- to block at elaboration time because there are no entry
3269 -- calls to unblock it.
3273 -- * Switch -gnatd_a (stop elaboration checks on accept or
3274 -- select statement) is in effect.
3276 elsif (Debug_Flag_Underscore_A
3277 or else Restriction_Active
3278 (No_Entry_Calls_In_Elaboration_Code
))
3279 and then Nkind
(Original_Node
(Scen
)) in
3280 N_Accept_Statement | N_Selective_Accept
3284 -- Terminate the traversal of a task body when encountering a
3285 -- suspension call, and
3287 -- * Entry calls during elaboration are not allowed. In this
3288 -- case the suspension call emulates an entry call and will
3289 -- cause the task to block at elaboration time.
3293 -- * Switch -gnatd_s (stop elaboration checks on synchronous
3294 -- suspension) is in effect.
3296 -- Note that the guard should not be checking the state of flag
3297 -- Within_Task_Body because only suspension calls which appear
3298 -- immediately within the statements of the task are supported.
3299 -- Flag Within_Task_Body carries over to deeper levels of the
3302 elsif (Debug_Flag_Underscore_S
3303 or else Restriction_Active
3304 (No_Entry_Calls_In_Elaboration_Code
))
3305 and then Is_Synchronous_Suspension_Call
(Scen
)
3306 and then In_Task_Body
(Scen
)
3310 -- Certain nodes carry semantic lists which act as repositories
3311 -- until expansion transforms the node and relocates the contents.
3312 -- Examine these lists in case expansion is disabled.
3314 elsif Nkind
(Scen
) in N_And_Then | N_Or_Else
then
3315 Traverse_List
(Actions
(Scen
));
3317 elsif Nkind
(Scen
) in N_Elsif_Part | N_Iteration_Scheme
then
3318 Traverse_List
(Condition_Actions
(Scen
));
3320 elsif Nkind
(Scen
) = N_If_Expression
then
3321 Traverse_List
(Then_Actions
(Scen
));
3322 Traverse_List
(Else_Actions
(Scen
));
3324 elsif Nkind
(Scen
) in
3325 N_Component_Association
3326 | N_Iterated_Component_Association
3327 | N_Iterated_Element_Association
3329 Traverse_List
(Loop_Actions
(Scen
));
3333 -- The current node satisfies the input predicate, process it
3335 elsif Requires_Processing
.all (Scen
) then
3336 Processor
.all (Scen
, In_State
);
3339 -- Save a general scenario regardless of whether it satisfies the
3340 -- input predicate. This allows for quick subsequent traversals of
3341 -- general scenarios, even with different predicates.
3343 if Is_Suitable_Access_Taken
(Scen
)
3344 or else Is_Suitable_Call
(Scen
)
3345 or else Is_Suitable_Instantiation
(Scen
)
3346 or else Is_Suitable_Variable_Assignment
(Scen
)
3347 or else Is_Suitable_Variable_Reference
(Scen
)
3349 NE_List
.Append
(Scenarios
, Scen
);
3353 end Traverse_Potential_Scenario
;
3355 -- Start of processing for Traverse_Body
3358 -- Nothing to do when the traversal is suppressed
3360 if In_State
.Traversal
= No_Traversal
then
3363 -- Nothing to do when there is no input
3368 -- Nothing to do when the input is not a subprogram body
3370 elsif Nkind
(N
) /= N_Subprogram_Body
then
3373 -- Nothing to do if the subprogram body was already traversed
3375 elsif Is_Traversed_Body
(N
) then
3379 -- Mark the subprogram body as traversed
3381 Set_Is_Traversed_Body
(N
);
3383 Scenarios
:= Nested_Scenarios
(N
);
3385 -- The subprogram body has been traversed at least once, and all
3386 -- scenarios that appear within its declarations and statements
3387 -- have already been collected. Directly retraverse the scenarios
3388 -- without having to retraverse the subprogram body subtree.
3390 if NE_List
.Present
(Scenarios
) then
3391 Traverse_Collected_Scenarios
;
3393 -- Otherwise the subprogram body is being traversed for the first
3394 -- time. Collect all scenarios that appear within its declarations
3395 -- and statements in case the subprogram body has to be retraversed
3399 Scenarios
:= NE_List
.Create
;
3400 Set_Nested_Scenarios
(N
, Scenarios
);
3402 Traverse_List
(Declarations
(N
));
3403 Traverse_Potential_Scenarios
(Handled_Statement_Sequence
(N
));
3408 -----------------------
3409 -- Build_Call_Marker --
3410 -----------------------
3412 procedure Build_Call_Marker
(N
: Node_Id
) is
3413 function In_External_Context
3415 Subp_Id
: Entity_Id
) return Boolean;
3416 pragma Inline
(In_External_Context
);
3417 -- Determine whether entry, operator, or subprogram Subp_Id is external
3418 -- to call Call which must reside within an instance.
3420 function In_Premature_Context
(Call
: Node_Id
) return Boolean;
3421 pragma Inline
(In_Premature_Context
);
3422 -- Determine whether call Call appears within a premature context
3424 function Is_Default_Expression
(Call
: Node_Id
) return Boolean;
3425 pragma Inline
(Is_Default_Expression
);
3426 -- Determine whether call Call acts as the expression of a defaulted
3427 -- parameter within a source call.
3429 function Is_Generic_Formal_Subp
(Subp_Id
: Entity_Id
) return Boolean;
3430 pragma Inline
(Is_Generic_Formal_Subp
);
3431 -- Determine whether subprogram Subp_Id denotes a generic formal
3432 -- subprogram which appears in the "prologue" of an instantiation.
3434 -------------------------
3435 -- In_External_Context --
3436 -------------------------
3438 function In_External_Context
3440 Subp_Id
: Entity_Id
) return Boolean
3442 Spec_Decl
: constant Entity_Id
:= Unit_Declaration_Node
(Subp_Id
);
3445 Inst_Body
: Node_Id
;
3446 Inst_Spec
: Node_Id
;
3449 Inst
:= Find_Enclosing_Instance
(Call
);
3451 -- The call appears within an instance
3453 if Present
(Inst
) then
3455 -- The call comes from the main unit and the target does not
3457 if In_Extended_Main_Code_Unit
(Call
)
3458 and then not In_Extended_Main_Code_Unit
(Spec_Decl
)
3462 -- Otherwise the target declaration must not appear within the
3463 -- instance spec or body.
3466 Spec_And_Body_From_Node
3468 Spec_Decl
=> Inst_Spec
,
3469 Body_Decl
=> Inst_Body
);
3471 return not In_Subtree
3474 Root2
=> Inst_Body
);
3479 end In_External_Context
;
3481 --------------------------
3482 -- In_Premature_Context --
3483 --------------------------
3485 function In_Premature_Context
(Call
: Node_Id
) return Boolean is
3489 -- Climb the parent chain looking for premature contexts
3491 Par
:= Parent
(Call
);
3492 while Present
(Par
) loop
3494 -- Aspect specifications and generic associations are premature
3495 -- contexts because nested calls has not been relocated to their
3498 if Nkind
(Par
) in N_Aspect_Specification | N_Generic_Association
3502 -- Prevent the search from going too far
3504 elsif Is_Body_Or_Package_Declaration
(Par
) then
3508 Par
:= Parent
(Par
);
3512 end In_Premature_Context
;
3514 ---------------------------
3515 -- Is_Default_Expression --
3516 ---------------------------
3518 function Is_Default_Expression
(Call
: Node_Id
) return Boolean is
3519 Outer_Call
: constant Node_Id
:= Parent
(Call
);
3520 Outer_Nam
: Node_Id
;
3523 -- To qualify, the node must appear immediately within a source call
3524 -- which invokes a source target.
3526 if Nkind
(Outer_Call
) in N_Entry_Call_Statement
3528 | N_Procedure_Call_Statement
3529 and then Comes_From_Source
(Outer_Call
)
3531 Outer_Nam
:= Call_Name
(Outer_Call
);
3534 Is_Entity_Name
(Outer_Nam
)
3535 and then Present
(Entity
(Outer_Nam
))
3536 and then Is_Subprogram_Or_Entry
(Entity
(Outer_Nam
))
3537 and then Comes_From_Source
(Entity
(Outer_Nam
));
3541 end Is_Default_Expression
;
3543 ----------------------------
3544 -- Is_Generic_Formal_Subp --
3545 ----------------------------
3547 function Is_Generic_Formal_Subp
(Subp_Id
: Entity_Id
) return Boolean is
3548 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
3549 Context
: constant Node_Id
:= Parent
(Subp_Decl
);
3552 -- To qualify, the subprogram must rename a generic actual subprogram
3553 -- where the enclosing context is an instantiation.
3556 Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
3557 and then not Comes_From_Source
(Subp_Decl
)
3558 and then Nkind
(Context
) in N_Function_Specification
3559 | N_Package_Specification
3560 | N_Procedure_Specification
3561 and then Present
(Generic_Parent
(Context
));
3562 end Is_Generic_Formal_Subp
;
3568 Subp_Id
: Entity_Id
;
3570 -- Start of processing for Build_Call_Marker
3573 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
3574 -- enabled) is in effect because the legacy ABE mechanism does not need
3575 -- to carry out this action.
3577 if Legacy_Elaboration_Checks
then
3580 -- Nothing to do when the call is being preanalyzed as the marker will
3581 -- be inserted in the wrong place.
3583 elsif Preanalysis_Active
then
3586 -- Nothing to do when the elaboration phase of the compiler is not
3589 elsif not Elaboration_Phase_Active
then
3592 -- Nothing to do when the input does not denote a call or a requeue
3594 elsif Nkind
(N
) not in N_Entry_Call_Statement
3596 | N_Procedure_Call_Statement
3597 | N_Requeue_Statement
3601 -- Nothing to do when the input denotes entry call or requeue statement,
3602 -- and switch -gnatd_e (ignore entry calls and requeue statements for
3603 -- elaboration) is in effect.
3605 elsif Debug_Flag_Underscore_E
3606 and then Nkind
(N
) in N_Entry_Call_Statement | N_Requeue_Statement
3610 -- Nothing to do when the call is analyzed/resolved too early within an
3611 -- intermediate context. This check is saved for last because it incurs
3612 -- a performance penalty.
3614 elsif In_Premature_Context
(N
) then
3618 Call_Nam
:= Call_Name
(N
);
3620 -- Nothing to do when the call is erroneous or left in a bad state
3622 if not (Is_Entity_Name
(Call_Nam
)
3623 and then Present
(Entity
(Call_Nam
))
3624 and then Is_Subprogram_Or_Entry
(Entity
(Call_Nam
)))
3629 Subp_Id
:= Canonical_Subprogram
(Entity
(Call_Nam
));
3631 -- Nothing to do when the call invokes a generic formal subprogram and
3632 -- switch -gnatd.G (ignore calls through generic formal parameters for
3633 -- elaboration) is in effect. This check must be performed with the
3634 -- direct target of the call to avoid the side effects of mapping
3635 -- actuals to formals using renamings.
3637 if Debug_Flag_Dot_GG
3638 and then Is_Generic_Formal_Subp
(Entity
(Call_Nam
))
3642 -- Nothing to do when the call appears within the expanded spec or
3643 -- body of an instantiated generic, the call does not invoke a generic
3644 -- formal subprogram, the target is external to the instance, and switch
3645 -- -gnatdL (ignore external calls from instances for elaboration) is in
3646 -- effect. This check must be performed with the direct target of the
3647 -- call to avoid the side effects of mapping actuals to formals using
3651 and then not Is_Generic_Formal_Subp
(Entity
(Call_Nam
))
3652 and then In_External_Context
3658 -- Nothing to do when the call invokes an assertion pragma procedure
3659 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is
3662 elsif Debug_Flag_Underscore_P
3663 and then Is_Assertion_Pragma_Target
(Subp_Id
)
3667 -- Static expression functions require no ABE processing
3669 elsif Is_Static_Function
(Subp_Id
) then
3672 -- Source calls to source targets are always considered because they
3673 -- reflect the original call graph.
3675 elsif Comes_From_Source
(N
) and then Comes_From_Source
(Subp_Id
) then
3678 -- A call to a source function which acts as the default expression in
3679 -- another call requires special detection.
3681 elsif Comes_From_Source
(Subp_Id
)
3682 and then Nkind
(N
) = N_Function_Call
3683 and then Is_Default_Expression
(N
)
3687 -- The target emulates Ada semantics
3689 elsif Is_Ada_Semantic_Target
(Subp_Id
) then
3692 -- The target acts as a link between scenarios
3694 elsif Is_Bridge_Target
(Subp_Id
) then
3697 -- The target emulates SPARK semantics
3699 elsif Is_SPARK_Semantic_Target
(Subp_Id
) then
3702 -- Otherwise the call is not suitable for ABE processing. This prevents
3703 -- the generation of call markers which will never play a role in ABE
3710 -- At this point it is known that the call will play some role in ABE
3711 -- checks and diagnostics. Create a corresponding call marker in case
3712 -- the original call is heavily transformed by expansion later on.
3714 Marker
:= Make_Call_Marker
(Sloc
(N
));
3716 -- Inherit the attributes of the original call
3718 Set_Is_Declaration_Level_Node
3719 (Marker
, Find_Enclosing_Level
(N
) = Declaration_Level
);
3721 Set_Is_Dispatching_Call
3723 Nkind
(N
) in N_Subprogram_Call
3724 and then Present
(Controlling_Argument
(N
)));
3726 Set_Is_Elaboration_Checks_OK_Node
3727 (Marker
, Is_Elaboration_Checks_OK_Node
(N
));
3729 Set_Is_Elaboration_Warnings_OK_Node
3730 (Marker
, Is_Elaboration_Warnings_OK_Node
(N
));
3732 Set_Is_Ignored_Ghost_Node
(Marker
, Is_Ignored_Ghost_Node
(N
));
3733 Set_Is_Source_Call
(Marker
, Comes_From_Source
(N
));
3734 Set_Is_SPARK_Mode_On_Node
(Marker
, Is_SPARK_Mode_On_Node
(N
));
3735 Set_Target
(Marker
, Subp_Id
);
3737 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
3738 -- unchecked conversions are preelaborable.
3740 if Ada_Version
>= Ada_2022
then
3741 Set_Is_Preelaborable_Call
(Marker
, Is_Preelaborable_Construct
(N
));
3743 Set_Is_Preelaborable_Call
(Marker
, False);
3746 -- The marker is inserted prior to the original call. This placement has
3747 -- several desirable effects:
3749 -- 1) The marker appears in the same context, in close proximity to
3755 -- 2) Inserting the marker prior to the call ensures that an ABE check
3756 -- will take effect prior to the call.
3762 -- 3) The above two properties are preserved even when the call is a
3763 -- function which is subsequently relocated in order to capture its
3764 -- result. Note that if the call is relocated to a new context, the
3765 -- relocated call will receive a marker of its own.
3769 -- Temp : ... := Func_Call ...;
3772 -- The insertion must take place even when the call does not occur in
3773 -- the main unit to keep the tree symmetric. This ensures that internal
3774 -- name serialization is consistent in case the call marker causes the
3775 -- tree to transform in some way.
3777 Insert_Action
(N
, Marker
);
3779 -- The marker becomes the "corresponding" scenario for the call. Save
3780 -- the marker for later processing by the ABE phase.
3782 Record_Elaboration_Scenario
(Marker
);
3783 end Build_Call_Marker
;
3785 -------------------------------------
3786 -- Build_Variable_Reference_Marker --
3787 -------------------------------------
3789 procedure Build_Variable_Reference_Marker
3794 function Ultimate_Variable
(Var_Id
: Entity_Id
) return Entity_Id
;
3795 pragma Inline
(Ultimate_Variable
);
3796 -- Obtain the ultimate renamed variable of variable Var_Id
3798 -----------------------
3799 -- Ultimate_Variable --
3800 -----------------------
3802 function Ultimate_Variable
(Var_Id
: Entity_Id
) return Entity_Id
is
3803 pragma Assert
(Ekind
(Var_Id
) = E_Variable
);
3807 while Present
(Renamed_Object
(Ren_Id
))
3808 and then Nkind
(Renamed_Object
(Ren_Id
)) in N_Entity
3810 Ren_Id
:= Renamed_Object
(Ren_Id
);
3814 end Ultimate_Variable
;
3818 Var_Id
: constant Entity_Id
:= Ultimate_Variable
(Entity
(N
));
3821 -- Start of processing for Build_Variable_Reference_Marker
3824 -- Nothing to do when the elaboration phase of the compiler is not
3827 if not Elaboration_Phase_Active
then
3831 Marker
:= Make_Variable_Reference_Marker
(Sloc
(N
));
3833 -- Inherit the attributes of the original variable reference
3835 Set_Is_Elaboration_Checks_OK_Node
3836 (Marker
, Is_Elaboration_Checks_OK_Node
(N
));
3838 Set_Is_Elaboration_Warnings_OK_Node
3839 (Marker
, Is_Elaboration_Warnings_OK_Node
(N
));
3841 Set_Is_Read
(Marker
, Read
);
3842 Set_Is_SPARK_Mode_On_Node
(Marker
, Is_SPARK_Mode_On_Node
(N
));
3843 Set_Is_Write
(Marker
, Write
);
3844 Set_Target
(Marker
, Var_Id
);
3846 -- The marker is inserted prior to the original variable reference. The
3847 -- insertion must take place even when the reference does not occur in
3848 -- the main unit to keep the tree symmetric. This ensures that internal
3849 -- name serialization is consistent in case the variable marker causes
3850 -- the tree to transform in some way.
3852 Insert_Action
(N
, Marker
);
3854 -- The marker becomes the "corresponding" scenario for the reference.
3855 -- Save the marker for later processing for the ABE phase.
3857 Record_Elaboration_Scenario
(Marker
);
3858 end Build_Variable_Reference_Marker
;
3864 function Call_Name
(Call
: Node_Id
) return Node_Id
is
3870 -- When the call invokes an entry family, the name appears as an indexed
3873 if Nkind
(Nam
) = N_Indexed_Component
then
3874 Nam
:= Prefix
(Nam
);
3877 -- When the call employs the object.operation form, the name appears as
3878 -- a selected component.
3880 if Nkind
(Nam
) = N_Selected_Component
then
3881 Nam
:= Selector_Name
(Nam
);
3887 --------------------------
3888 -- Canonical_Subprogram --
3889 --------------------------
3891 function Canonical_Subprogram
(Subp_Id
: Entity_Id
) return Entity_Id
is
3892 Canon_Id
: Entity_Id
;
3895 Canon_Id
:= Subp_Id
;
3897 -- Use the original protected subprogram when dealing with one of the
3898 -- specialized lock-manipulating versions.
3900 if Is_Protected_Body_Subp
(Canon_Id
) then
3901 Canon_Id
:= Protected_Subprogram
(Canon_Id
);
3904 -- Obtain the original subprogram except when the subprogram is also
3905 -- an instantiation. In this case the alias is the internally generated
3906 -- subprogram which appears within the anonymous package created for the
3907 -- instantiation, making it unuitable.
3909 if not Is_Generic_Instance
(Canon_Id
) then
3910 Canon_Id
:= Get_Renamed_Entity
(Canon_Id
);
3914 end Canonical_Subprogram
;
3916 ---------------------------------
3917 -- Check_Elaboration_Scenarios --
3918 ---------------------------------
3920 procedure Check_Elaboration_Scenarios
is
3921 Iter
: NE_Set
.Iterator
;
3924 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
3925 -- enabled) is in effect because the legacy ABE mechanism does not need
3926 -- to carry out this action.
3928 if Legacy_Elaboration_Checks
then
3929 Finalize_All_Data_Structures
;
3932 -- Nothing to do when the elaboration phase of the compiler is not
3935 elsif not Elaboration_Phase_Active
then
3936 Finalize_All_Data_Structures
;
3940 -- Restore the original elaboration model which was in effect when the
3941 -- scenarios were first recorded. The model may be specified by pragma
3942 -- Elaboration_Checks which appears on the initial declaration of the
3945 Install_Elaboration_Model
(Unit_Entity
(Main_Unit_Entity
));
3947 -- Examine the context of the main unit and record all units with prior
3948 -- elaboration with respect to it.
3950 Collect_Elaborated_Units
;
3952 -- Examine all scenarios saved during the Recording phase applying the
3953 -- Ada or SPARK elaboration rules in order to detect and diagnose ABE
3954 -- issues, install conditional ABE checks, and ensure the elaboration
3957 Iter
:= Iterate_Declaration_Scenarios
;
3958 Check_Conditional_ABE_Scenarios
(Iter
);
3960 Iter
:= Iterate_Library_Body_Scenarios
;
3961 Check_Conditional_ABE_Scenarios
(Iter
);
3963 Iter
:= Iterate_Library_Spec_Scenarios
;
3964 Check_Conditional_ABE_Scenarios
(Iter
);
3966 -- Examine each SPARK scenario saved during the Recording phase which
3967 -- is not necessarily executable during elaboration, but still requires
3968 -- elaboration-related checks.
3970 Check_SPARK_Scenarios
;
3972 -- Add conditional ABE checks for all scenarios that require one when
3973 -- the dynamic model is in effect.
3975 Install_Dynamic_ABE_Checks
;
3977 -- Examine all scenarios saved during the Recording phase along with
3978 -- invocation constructs within the spec and body of the main unit.
3979 -- Record the declarations and paths that reach into an external unit
3980 -- in the ALI file of the main unit.
3982 Record_Invocation_Graph
;
3984 -- Destroy all internal data structures and complete the elaboration
3985 -- phase of the compiler.
3987 Finalize_All_Data_Structures
;
3988 Set_Elaboration_Phase
(Completed
);
3989 end Check_Elaboration_Scenarios
;
3991 ---------------------
3992 -- Check_Installer --
3993 ---------------------
3995 package body Check_Installer
is
3997 -----------------------
3998 -- Local subprograms --
3999 -----------------------
4001 function ABE_Check_Or_Failure_OK
4003 Targ_Id
: Entity_Id
;
4004 Unit_Id
: Entity_Id
) return Boolean;
4005 pragma Inline
(ABE_Check_Or_Failure_OK
);
4006 -- Determine whether a conditional ABE check or guaranteed ABE failure
4007 -- can be installed for scenario N with target Targ_Id which resides in
4010 function Insertion_Node
(N
: Node_Id
) return Node_Id
;
4011 pragma Inline
(Insertion_Node
);
4012 -- Obtain the proper insertion node of an ABE check or failure for
4015 procedure Insert_ABE_Check_Or_Failure
(N
: Node_Id
; Check
: Node_Id
);
4016 pragma Inline
(Insert_ABE_Check_Or_Failure
);
4017 -- Insert conditional ABE check or guaranteed ABE failure Check prior to
4020 procedure Install_Scenario_ABE_Check_Common
4022 Targ_Id
: Entity_Id
;
4023 Targ_Rep
: Target_Rep_Id
);
4024 pragma Inline
(Install_Scenario_ABE_Check_Common
);
4025 -- Install a conditional ABE check for scenario N to ensure that target
4026 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
4029 procedure Install_Scenario_ABE_Failure_Common
(N
: Node_Id
);
4030 pragma Inline
(Install_Scenario_ABE_Failure_Common
);
4031 -- Install a guaranteed ABE failure for scenario N
4033 procedure Install_Unit_ABE_Check_Common
4035 Unit_Id
: Entity_Id
);
4036 pragma Inline
(Install_Unit_ABE_Check_Common
);
4037 -- Install a conditional ABE check for scenario N to ensure that unit
4038 -- Unit_Id is properly elaborated.
4040 -----------------------------
4041 -- ABE_Check_Or_Failure_OK --
4042 -----------------------------
4044 function ABE_Check_Or_Failure_OK
4046 Targ_Id
: Entity_Id
;
4047 Unit_Id
: Entity_Id
) return Boolean
4049 pragma Unreferenced
(Targ_Id
);
4051 Ins_Node
: constant Node_Id
:= Insertion_Node
(N
);
4054 if not Check_Or_Failure_Generation_OK
then
4057 -- Nothing to do when the scenario denots a compilation unit because
4058 -- there is no executable environment at that level.
4060 elsif Nkind
(Parent
(Ins_Node
)) = N_Compilation_Unit
then
4063 -- An ABE check or failure is not needed when the target is defined
4064 -- in a unit which is elaborated prior to the main unit. This check
4065 -- must also consider the following cases:
4067 -- * The unit of the target appears in the context of the main unit
4069 -- * The unit of the target is subject to pragma Elaborate_Body. An
4070 -- ABE check MUST NOT be generated because the unit is always
4071 -- elaborated prior to the main unit.
4073 -- * The unit of the target is the main unit. An ABE check MUST be
4074 -- added in this case because a conditional ABE may be raised
4075 -- depending on the flow of execution within the main unit (flag
4076 -- Same_Unit_OK is False).
4078 elsif Has_Prior_Elaboration
4079 (Unit_Id
=> Unit_Id
,
4081 Elab_Body_OK
=> True)
4087 end ABE_Check_Or_Failure_OK
;
4089 ------------------------------------
4090 -- Check_Or_Failure_Generation_OK --
4091 ------------------------------------
4093 function Check_Or_Failure_Generation_OK
return Boolean is
4095 -- An ABE check or failure is not needed when the compilation will
4096 -- not produce an executable.
4098 if Serious_Errors_Detected
> 0 then
4101 -- An ABE check or failure must not be installed when compiling for
4102 -- GNATprove because raise statements are not supported.
4104 elsif GNATprove_Mode
then
4109 end Check_Or_Failure_Generation_OK
;
4111 --------------------
4112 -- Insertion_Node --
4113 --------------------
4115 function Insertion_Node
(N
: Node_Id
) return Node_Id
is
4117 -- When the scenario denotes an instantiation, the proper insertion
4118 -- node is the instance spec. This ensures that the generic actuals
4119 -- will not be evaluated prior to a potential ABE.
4121 if Nkind
(N
) in N_Generic_Instantiation
4122 and then Present
(Instance_Spec
(N
))
4124 return Instance_Spec
(N
);
4126 -- Otherwise the proper insertion node is the scenario itself
4133 ---------------------------------
4134 -- Insert_ABE_Check_Or_Failure --
4135 ---------------------------------
4137 procedure Insert_ABE_Check_Or_Failure
(N
: Node_Id
; Check
: Node_Id
) is
4138 Ins_Nod
: constant Node_Id
:= Insertion_Node
(N
);
4139 Scop_Id
: constant Entity_Id
:= Find_Enclosing_Scope
(Ins_Nod
);
4142 -- Install the nearest enclosing scope of the scenario as there must
4143 -- be something on the scope stack.
4145 Push_Scope
(Scop_Id
);
4147 Insert_Action
(Ins_Nod
, Check
);
4150 end Insert_ABE_Check_Or_Failure
;
4152 --------------------------------
4153 -- Install_Dynamic_ABE_Checks --
4154 --------------------------------
4156 procedure Install_Dynamic_ABE_Checks
is
4157 Iter
: NE_Set
.Iterator
;
4161 if not Check_Or_Failure_Generation_OK
then
4164 -- Nothing to do if the dynamic model is not in effect
4166 elsif not Dynamic_Elaboration_Checks
then
4170 -- Install a conditional ABE check for each saved scenario
4172 Iter
:= Iterate_Dynamic_ABE_Check_Scenarios
;
4173 while NE_Set
.Has_Next
(Iter
) loop
4174 NE_Set
.Next
(Iter
, N
);
4176 Process_Conditional_ABE
4178 In_State
=> Dynamic_Model_State
);
4180 end Install_Dynamic_ABE_Checks
;
4182 --------------------------------
4183 -- Install_Scenario_ABE_Check --
4184 --------------------------------
4186 procedure Install_Scenario_ABE_Check
4188 Targ_Id
: Entity_Id
;
4189 Targ_Rep
: Target_Rep_Id
;
4190 Disable
: Scenario_Rep_Id
)
4193 -- Nothing to do when the scenario does not need an ABE check
4195 if not ABE_Check_Or_Failure_OK
4198 Unit_Id
=> Unit
(Targ_Rep
))
4203 -- Prevent multiple attempts to install the same ABE check
4205 Disable_Elaboration_Checks
(Disable
);
4207 Install_Scenario_ABE_Check_Common
4210 Targ_Rep
=> Targ_Rep
);
4211 end Install_Scenario_ABE_Check
;
4213 --------------------------------
4214 -- Install_Scenario_ABE_Check --
4215 --------------------------------
4217 procedure Install_Scenario_ABE_Check
4219 Targ_Id
: Entity_Id
;
4220 Targ_Rep
: Target_Rep_Id
;
4221 Disable
: Target_Rep_Id
)
4224 -- Nothing to do when the scenario does not need an ABE check
4226 if not ABE_Check_Or_Failure_OK
4229 Unit_Id
=> Unit
(Targ_Rep
))
4234 -- Prevent multiple attempts to install the same ABE check
4236 Disable_Elaboration_Checks
(Disable
);
4238 Install_Scenario_ABE_Check_Common
4241 Targ_Rep
=> Targ_Rep
);
4242 end Install_Scenario_ABE_Check
;
4244 ---------------------------------------
4245 -- Install_Scenario_ABE_Check_Common --
4246 ---------------------------------------
4248 procedure Install_Scenario_ABE_Check_Common
4250 Targ_Id
: Entity_Id
;
4251 Targ_Rep
: Target_Rep_Id
)
4253 Targ_Body
: constant Node_Id
:= Body_Declaration
(Targ_Rep
);
4254 Targ_Decl
: constant Node_Id
:= Spec_Declaration
(Targ_Rep
);
4256 pragma Assert
(Present
(Targ_Body
));
4257 pragma Assert
(Present
(Targ_Decl
));
4259 procedure Build_Elaboration_Entity
;
4260 pragma Inline
(Build_Elaboration_Entity
);
4261 -- Create a new elaboration flag for Targ_Id, insert it prior to
4262 -- Targ_Decl, and set it after Targ_Body.
4264 ------------------------------
4265 -- Build_Elaboration_Entity --
4266 ------------------------------
4268 procedure Build_Elaboration_Entity
is
4269 Loc
: constant Source_Ptr
:= Sloc
(Targ_Id
);
4270 Flag_Id
: Entity_Id
;
4273 -- Nothing to do if the target has an elaboration flag
4275 if Present
(Elaboration_Entity
(Targ_Id
)) then
4279 -- Create the declaration of the elaboration flag. The name
4280 -- carries a unique counter in case the name is overloaded.
4283 Make_Defining_Identifier
(Loc
,
4284 Chars
=> New_External_Name
(Chars
(Targ_Id
), 'E', -1));
4286 Set_Elaboration_Entity
(Targ_Id
, Flag_Id
);
4287 Set_Elaboration_Entity_Required
(Targ_Id
);
4289 Push_Scope
(Scope
(Targ_Id
));
4292 -- Enn : Short_Integer := 0;
4294 Insert_Action
(Targ_Decl
,
4295 Make_Object_Declaration
(Loc
,
4296 Defining_Identifier
=> Flag_Id
,
4297 Object_Definition
=>
4298 New_Occurrence_Of
(Standard_Short_Integer
, Loc
),
4299 Expression
=> Make_Integer_Literal
(Loc
, Uint_0
)));
4304 Set_Elaboration_Flag
(Targ_Body
, Targ_Id
);
4307 end Build_Elaboration_Entity
;
4311 Loc
: constant Source_Ptr
:= Sloc
(N
);
4313 -- Start for processing for Install_Scenario_ABE_Check_Common
4316 -- Create an elaboration flag for the target when it does not have
4319 Build_Elaboration_Entity
;
4322 -- if not Targ_Id'Elaborated then
4323 -- raise Program_Error with "access before elaboration";
4326 Insert_ABE_Check_Or_Failure
4329 Make_Raise_Program_Error
(Loc
,
4333 Make_Attribute_Reference
(Loc
,
4334 Prefix
=> New_Occurrence_Of
(Targ_Id
, Loc
),
4335 Attribute_Name
=> Name_Elaborated
)),
4336 Reason
=> PE_Access_Before_Elaboration
));
4337 end Install_Scenario_ABE_Check_Common
;
4339 ----------------------------------
4340 -- Install_Scenario_ABE_Failure --
4341 ----------------------------------
4343 procedure Install_Scenario_ABE_Failure
4345 Targ_Id
: Entity_Id
;
4346 Targ_Rep
: Target_Rep_Id
;
4347 Disable
: Scenario_Rep_Id
)
4350 -- Nothing to do when the scenario does not require an ABE failure
4352 if not ABE_Check_Or_Failure_OK
4355 Unit_Id
=> Unit
(Targ_Rep
))
4360 -- Prevent multiple attempts to install the same ABE check
4362 Disable_Elaboration_Checks
(Disable
);
4364 Install_Scenario_ABE_Failure_Common
(N
);
4365 end Install_Scenario_ABE_Failure
;
4367 ----------------------------------
4368 -- Install_Scenario_ABE_Failure --
4369 ----------------------------------
4371 procedure Install_Scenario_ABE_Failure
4373 Targ_Id
: Entity_Id
;
4374 Targ_Rep
: Target_Rep_Id
;
4375 Disable
: Target_Rep_Id
)
4378 -- Nothing to do when the scenario does not require an ABE failure
4380 if not ABE_Check_Or_Failure_OK
4383 Unit_Id
=> Unit
(Targ_Rep
))
4388 -- Prevent multiple attempts to install the same ABE check
4390 Disable_Elaboration_Checks
(Disable
);
4392 Install_Scenario_ABE_Failure_Common
(N
);
4393 end Install_Scenario_ABE_Failure
;
4395 -----------------------------------------
4396 -- Install_Scenario_ABE_Failure_Common --
4397 -----------------------------------------
4399 procedure Install_Scenario_ABE_Failure_Common
(N
: Node_Id
) is
4400 Loc
: constant Source_Ptr
:= Sloc
(N
);
4404 -- raise Program_Error with "access before elaboration";
4406 Insert_ABE_Check_Or_Failure
4409 Make_Raise_Program_Error
(Loc
,
4410 Reason
=> PE_Access_Before_Elaboration
));
4411 end Install_Scenario_ABE_Failure_Common
;
4413 ----------------------------
4414 -- Install_Unit_ABE_Check --
4415 ----------------------------
4417 procedure Install_Unit_ABE_Check
4419 Unit_Id
: Entity_Id
;
4420 Disable
: Scenario_Rep_Id
)
4422 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Unit_Id
);
4425 -- Nothing to do when the scenario does not require an ABE check
4427 if not ABE_Check_Or_Failure_OK
4435 -- Prevent multiple attempts to install the same ABE check
4437 Disable_Elaboration_Checks
(Disable
);
4439 Install_Unit_ABE_Check_Common
4441 Unit_Id
=> Unit_Id
);
4442 end Install_Unit_ABE_Check
;
4444 ----------------------------
4445 -- Install_Unit_ABE_Check --
4446 ----------------------------
4448 procedure Install_Unit_ABE_Check
4450 Unit_Id
: Entity_Id
;
4451 Disable
: Target_Rep_Id
)
4453 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Unit_Id
);
4456 -- Nothing to do when the scenario does not require an ABE check
4458 if not ABE_Check_Or_Failure_OK
4466 -- Prevent multiple attempts to install the same ABE check
4468 Disable_Elaboration_Checks
(Disable
);
4470 Install_Unit_ABE_Check_Common
4472 Unit_Id
=> Unit_Id
);
4473 end Install_Unit_ABE_Check
;
4475 -----------------------------------
4476 -- Install_Unit_ABE_Check_Common --
4477 -----------------------------------
4479 procedure Install_Unit_ABE_Check_Common
4481 Unit_Id
: Entity_Id
)
4483 Loc
: constant Source_Ptr
:= Sloc
(N
);
4484 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Unit_Id
);
4488 -- if not Spec_Id'Elaborated then
4489 -- raise Program_Error with "access before elaboration";
4492 Insert_ABE_Check_Or_Failure
4495 Make_Raise_Program_Error
(Loc
,
4499 Make_Attribute_Reference
(Loc
,
4500 Prefix
=> New_Occurrence_Of
(Spec_Id
, Loc
),
4501 Attribute_Name
=> Name_Elaborated
)),
4502 Reason
=> PE_Access_Before_Elaboration
));
4503 end Install_Unit_ABE_Check_Common
;
4504 end Check_Installer
;
4506 ----------------------
4507 -- Compilation_Unit --
4508 ----------------------
4510 function Compilation_Unit
(Unit_Id
: Entity_Id
) return Node_Id
is
4511 Comp_Unit
: Node_Id
;
4514 Comp_Unit
:= Parent
(Unit_Id
);
4516 -- Handle the case where a concurrent subunit is rewritten as a null
4517 -- statement due to expansion activities.
4519 if Nkind
(Comp_Unit
) = N_Null_Statement
4520 and then Nkind
(Original_Node
(Comp_Unit
)) in
4521 N_Protected_Body | N_Task_Body
4523 Comp_Unit
:= Parent
(Comp_Unit
);
4524 pragma Assert
(Nkind
(Comp_Unit
) = N_Subunit
);
4526 -- Otherwise use the declaration node of the unit
4529 Comp_Unit
:= Parent
(Unit_Declaration_Node
(Unit_Id
));
4532 -- Handle the case where a subprogram instantiation which acts as a
4533 -- compilation unit is expanded into an anonymous package that wraps
4534 -- the instantiated subprogram.
4536 if Nkind
(Comp_Unit
) = N_Package_Specification
4537 and then Nkind
(Original_Node
(Parent
(Comp_Unit
))) in
4538 N_Function_Instantiation | N_Procedure_Instantiation
4540 Comp_Unit
:= Parent
(Parent
(Comp_Unit
));
4542 -- Handle the case where the compilation unit is a subunit
4544 elsif Nkind
(Comp_Unit
) = N_Subunit
then
4545 Comp_Unit
:= Parent
(Comp_Unit
);
4548 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
4551 end Compilation_Unit
;
4553 -------------------------------
4554 -- Conditional_ABE_Processor --
4555 -------------------------------
4557 package body Conditional_ABE_Processor
is
4559 -----------------------
4560 -- Local subprograms --
4561 -----------------------
4563 function Is_Conditional_ABE_Scenario
(N
: Node_Id
) return Boolean;
4564 pragma Inline
(Is_Conditional_ABE_Scenario
);
4565 -- Determine whether node N is a suitable scenario for conditional ABE
4566 -- checks and diagnostics.
4568 procedure Process_Conditional_ABE_Access_Taken
4570 Attr_Rep
: Scenario_Rep_Id
;
4571 In_State
: Processing_In_State
);
4572 pragma Inline
(Process_Conditional_ABE_Access_Taken
);
4573 -- Perform ABE checks and diagnostics for attribute reference Attr with
4574 -- representation Attr_Rep which takes 'Access of an entry, operator, or
4575 -- subprogram. In_State is the current state of the Processing phase.
4577 procedure Process_Conditional_ABE_Activation
4579 Call_Rep
: Scenario_Rep_Id
;
4581 Obj_Rep
: Target_Rep_Id
;
4582 Task_Typ
: Entity_Id
;
4583 Task_Rep
: Target_Rep_Id
;
4584 In_State
: Processing_In_State
);
4585 pragma Inline
(Process_Conditional_ABE_Activation
);
4586 -- Perform common conditional ABE checks and diagnostics for activation
4587 -- call Call which activates object Obj_Id of task type Task_Typ. Formal
4588 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the
4589 -- representation of the object. Task_Rep denotes the representation of
4590 -- the task type. In_State is the current state of the Processing phase.
4592 procedure Process_Conditional_ABE_Call
4594 Call_Rep
: Scenario_Rep_Id
;
4595 In_State
: Processing_In_State
);
4596 pragma Inline
(Process_Conditional_ABE_Call
);
4597 -- Top-level dispatcher for processing of calls. Perform ABE checks and
4598 -- diagnostics for call Call with representation Call_Rep. In_State is
4599 -- the current state of the Processing phase.
4601 procedure Process_Conditional_ABE_Call_Ada
4603 Call_Rep
: Scenario_Rep_Id
;
4604 Subp_Id
: Entity_Id
;
4605 Subp_Rep
: Target_Rep_Id
;
4606 In_State
: Processing_In_State
);
4607 pragma Inline
(Process_Conditional_ABE_Call_Ada
);
4608 -- Perform ABE checks and diagnostics for call Call which invokes entry,
4609 -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes
4610 -- the representation of the call. Subp_Rep denotes the representation
4611 -- of the subprogram. In_State is the current state of the Processing
4614 procedure Process_Conditional_ABE_Call_SPARK
4616 Call_Rep
: Scenario_Rep_Id
;
4617 Subp_Id
: Entity_Id
;
4618 Subp_Rep
: Target_Rep_Id
;
4619 In_State
: Processing_In_State
);
4620 pragma Inline
(Process_Conditional_ABE_Call_SPARK
);
4621 -- Perform ABE checks and diagnostics for call Call which invokes entry,
4622 -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is
4623 -- the representation of the call. Subp_Rep denotes the representation
4624 -- of the subprogram. In_State is the current state of the Processing
4627 procedure Process_Conditional_ABE_Instantiation
4629 Inst_Rep
: Scenario_Rep_Id
;
4630 In_State
: Processing_In_State
);
4631 pragma Inline
(Process_Conditional_ABE_Instantiation
);
4632 -- Top-level dispatcher for processing of instantiations. Perform ABE
4633 -- checks and diagnostics for instantiation Inst with representation
4634 -- Inst_Rep. In_State is the current state of the Processing phase.
4636 procedure Process_Conditional_ABE_Instantiation_Ada
4638 Inst_Rep
: Scenario_Rep_Id
;
4640 Gen_Rep
: Target_Rep_Id
;
4641 In_State
: Processing_In_State
);
4642 pragma Inline
(Process_Conditional_ABE_Instantiation_Ada
);
4643 -- Perform ABE checks and diagnostics for instantiation Inst of generic
4644 -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of
4645 -- the instnace. Gen_Rep is the representation of the generic. In_State
4646 -- is the current state of the Processing phase.
4648 procedure Process_Conditional_ABE_Instantiation_SPARK
4650 Inst_Rep
: Scenario_Rep_Id
;
4652 Gen_Rep
: Target_Rep_Id
;
4653 In_State
: Processing_In_State
);
4654 pragma Inline
(Process_Conditional_ABE_Instantiation_SPARK
);
4655 -- Perform ABE checks and diagnostics for instantiation Inst of generic
4656 -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of
4657 -- the instnace. Gen_Rep is the representation of the generic. In_State
4658 -- is the current state of the Processing phase.
4660 procedure Process_Conditional_ABE_Variable_Assignment
4662 Asmt_Rep
: Scenario_Rep_Id
;
4663 In_State
: Processing_In_State
);
4664 pragma Inline
(Process_Conditional_ABE_Variable_Assignment
);
4665 -- Top-level dispatcher for processing of variable assignments. Perform
4666 -- ABE checks and diagnostics for assignment Asmt with representation
4667 -- Asmt_Rep. In_State denotes the current state of the Processing phase.
4669 procedure Process_Conditional_ABE_Variable_Assignment_Ada
4671 Asmt_Rep
: Scenario_Rep_Id
;
4673 Var_Rep
: Target_Rep_Id
;
4674 In_State
: Processing_In_State
);
4675 pragma Inline
(Process_Conditional_ABE_Variable_Assignment_Ada
);
4676 -- Perform ABE checks and diagnostics for assignment statement Asmt that
4677 -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep
4678 -- denotes the representation of the assignment. Var_Rep denotes the
4679 -- representation of the variable. In_State is the current state of the
4680 -- Processing phase.
4682 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
4684 Asmt_Rep
: Scenario_Rep_Id
;
4686 Var_Rep
: Target_Rep_Id
;
4687 In_State
: Processing_In_State
);
4688 pragma Inline
(Process_Conditional_ABE_Variable_Assignment_SPARK
);
4689 -- Perform ABE checks and diagnostics for assignment statement Asmt that
4690 -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep
4691 -- denotes the representation of the assignment. Var_Rep denotes the
4692 -- representation of the variable. In_State is the current state of the
4693 -- Processing phase.
4695 procedure Process_Conditional_ABE_Variable_Reference
4697 Ref_Rep
: Scenario_Rep_Id
;
4698 In_State
: Processing_In_State
);
4699 pragma Inline
(Process_Conditional_ABE_Variable_Reference
);
4700 -- Perform ABE checks and diagnostics for variable reference Ref with
4701 -- representation Ref_Rep. In_State denotes the current state of the
4702 -- Processing phase.
4704 procedure Traverse_Conditional_ABE_Body
4706 In_State
: Processing_In_State
);
4707 pragma Inline
(Traverse_Conditional_ABE_Body
);
4708 -- Traverse subprogram body N looking for suitable scenarios that need
4709 -- to be processed for conditional ABE checks and diagnostics. In_State
4710 -- is the current state of the Processing phase.
4712 -------------------------------------
4713 -- Check_Conditional_ABE_Scenarios --
4714 -------------------------------------
4716 procedure Check_Conditional_ABE_Scenarios
4717 (Iter
: in out NE_Set
.Iterator
)
4722 while NE_Set
.Has_Next
(Iter
) loop
4723 NE_Set
.Next
(Iter
, N
);
4725 -- Reset the traversed status of all subprogram bodies because the
4726 -- current conditional scenario acts as a new DFS traversal root.
4728 Reset_Traversed_Bodies
;
4730 Process_Conditional_ABE
4732 In_State
=> Conditional_ABE_State
);
4734 end Check_Conditional_ABE_Scenarios
;
4736 ---------------------------------
4737 -- Is_Conditional_ABE_Scenario --
4738 ---------------------------------
4740 function Is_Conditional_ABE_Scenario
(N
: Node_Id
) return Boolean is
4743 Is_Suitable_Access_Taken
(N
)
4744 or else Is_Suitable_Call
(N
)
4745 or else Is_Suitable_Instantiation
(N
)
4746 or else Is_Suitable_Variable_Assignment
(N
)
4747 or else Is_Suitable_Variable_Reference
(N
);
4748 end Is_Conditional_ABE_Scenario
;
4750 -----------------------------
4751 -- Process_Conditional_ABE --
4752 -----------------------------
4754 procedure Process_Conditional_ABE
4756 In_State
: Processing_In_State
)
4758 Scen
: constant Node_Id
:= Scenario
(N
);
4759 Scen_Rep
: Scenario_Rep_Id
;
4762 -- Add the current scenario to the stack of active scenarios
4764 Push_Active_Scenario
(Scen
);
4768 if Is_Suitable_Access_Taken
(Scen
) then
4769 Process_Conditional_ABE_Access_Taken
4771 Attr_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
4772 In_State
=> In_State
);
4774 -- Call or task activation
4776 elsif Is_Suitable_Call
(Scen
) then
4777 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
4779 -- Routine Build_Call_Marker creates call markers regardless of
4780 -- whether the call occurs within the main unit or not. This way
4781 -- the serialization of internal names is kept consistent. Only
4782 -- call markers found within the main unit must be processed.
4784 if In_Main_Context
(Scen
) then
4785 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
4787 if Kind
(Scen_Rep
) = Call_Scenario
then
4788 Process_Conditional_ABE_Call
4790 Call_Rep
=> Scen_Rep
,
4791 In_State
=> In_State
);
4794 pragma Assert
(Kind
(Scen_Rep
) = Task_Activation_Scenario
);
4798 Call_Rep
=> Scen_Rep
,
4799 Processor
=> Process_Conditional_ABE_Activation
'Access,
4800 In_State
=> In_State
);
4806 elsif Is_Suitable_Instantiation
(Scen
) then
4807 Process_Conditional_ABE_Instantiation
4809 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
4810 In_State
=> In_State
);
4812 -- Variable assignments
4814 elsif Is_Suitable_Variable_Assignment
(Scen
) then
4815 Process_Conditional_ABE_Variable_Assignment
4817 Asmt_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
4818 In_State
=> In_State
);
4820 -- Variable references
4822 elsif Is_Suitable_Variable_Reference
(Scen
) then
4824 -- Routine Build_Variable_Reference_Marker makes variable markers
4825 -- regardless of whether the reference occurs within the main unit
4826 -- or not. This way the serialization of internal names is kept
4827 -- consistent. Only variable markers within the main unit must be
4830 if In_Main_Context
(Scen
) then
4831 Process_Conditional_ABE_Variable_Reference
4833 Ref_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
4834 In_State
=> In_State
);
4838 -- Remove the current scenario from the stack of active scenarios
4839 -- once all ABE diagnostics and checks have been performed.
4841 Pop_Active_Scenario
(Scen
);
4842 end Process_Conditional_ABE
;
4844 ------------------------------------------
4845 -- Process_Conditional_ABE_Access_Taken --
4846 ------------------------------------------
4848 procedure Process_Conditional_ABE_Access_Taken
4850 Attr_Rep
: Scenario_Rep_Id
;
4851 In_State
: Processing_In_State
)
4853 function Build_Access_Marker
(Subp_Id
: Entity_Id
) return Node_Id
;
4854 pragma Inline
(Build_Access_Marker
);
4855 -- Create a suitable call marker which invokes subprogram Subp_Id
4857 -------------------------
4858 -- Build_Access_Marker --
4859 -------------------------
4861 function Build_Access_Marker
(Subp_Id
: Entity_Id
) return Node_Id
is
4865 Marker
:= Make_Call_Marker
(Sloc
(Attr
));
4867 -- Inherit relevant attributes from the attribute
4869 Set_Target
(Marker
, Subp_Id
);
4870 Set_Is_Declaration_Level_Node
4871 (Marker
, Level
(Attr_Rep
) = Declaration_Level
);
4872 Set_Is_Dispatching_Call
4874 Set_Is_Elaboration_Checks_OK_Node
4875 (Marker
, Elaboration_Checks_OK
(Attr_Rep
));
4876 Set_Is_Elaboration_Warnings_OK_Node
4877 (Marker
, Elaboration_Warnings_OK
(Attr_Rep
));
4878 Set_Is_Preelaborable_Call
4881 (Marker
, Comes_From_Source
(Attr
));
4882 Set_Is_SPARK_Mode_On_Node
4883 (Marker
, SPARK_Mode_Of
(Attr_Rep
) = Is_On
);
4885 -- Partially insert the call marker into the tree by setting its
4888 Set_Parent
(Marker
, Attr
);
4891 end Build_Access_Marker
;
4895 Root
: constant Node_Id
:= Root_Scenario
;
4896 Subp_Id
: constant Entity_Id
:= Target
(Attr_Rep
);
4897 Subp_Rep
: constant Target_Rep_Id
:=
4898 Target_Representation_Of
(Subp_Id
, In_State
);
4899 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
4901 New_In_State
: Processing_In_State
:= In_State
;
4902 -- Each step of the Processing phase constitutes a new state
4904 -- Start of processing for Process_Conditional_ABE_Access
4907 -- Output relevant information when switch -gnatel (info messages on
4908 -- implicit Elaborate[_All] pragmas) is in effect.
4910 if Elab_Info_Messages
4911 and then not New_In_State
.Suppress_Info_Messages
4914 ("info: access to & during elaboration?$?", Attr
, Subp_Id
);
4917 -- Warnings are suppressed when a prior scenario is already in that
4918 -- mode or when the attribute or the target have warnings suppressed.
4919 -- Update the state of the Processing phase to reflect this.
4921 New_In_State
.Suppress_Warnings
:=
4922 New_In_State
.Suppress_Warnings
4923 or else not Elaboration_Warnings_OK
(Attr_Rep
)
4924 or else not Elaboration_Warnings_OK
(Subp_Rep
);
4926 -- Do not emit any ABE diagnostics when the current or previous
4927 -- scenario in this traversal has suppressed elaboration warnings.
4929 if New_In_State
.Suppress_Warnings
then
4932 -- Both the attribute and the corresponding subprogram body are in
4933 -- the same unit. The body must appear prior to the root scenario
4934 -- which started the recursive search. If this is not the case, then
4935 -- there is a potential ABE if the access value is used to call the
4936 -- subprogram. Emit a warning only when switch -gnatw.f (warnings on
4937 -- suspicious 'Access) is in effect.
4939 elsif Warn_On_Elab_Access
4940 and then Present
(Body_Decl
)
4941 and then In_Extended_Main_Code_Unit
(Body_Decl
)
4942 and then Earlier_In_Extended_Unit
(Root
, Body_Decl
)
4944 Error_Msg_Name_1
:= Attribute_Name
(Attr
);
4946 ("?.f?% attribute of & before body seen", Attr
, Subp_Id
);
4947 Error_Msg_N
("\possible Program_Error on later references", Attr
);
4949 Output_Active_Scenarios
(Attr
, New_In_State
);
4952 -- Treat the attribute an immediate invocation of the target when
4953 -- switch -gnatd.o (conservative elaboration order for indirect
4954 -- calls) is in effect. This has the following desirable effects:
4956 -- * Ensure that the unit with the corresponding body is elaborated
4957 -- prior to the main unit.
4959 -- * Perform conditional ABE checks and diagnostics
4961 -- * Traverse the body of the target (if available)
4963 if Debug_Flag_Dot_O
then
4964 Process_Conditional_ABE
4965 (N
=> Build_Access_Marker
(Subp_Id
),
4966 In_State
=> New_In_State
);
4968 -- Otherwise ensure that the unit with the corresponding body is
4969 -- elaborated prior to the main unit.
4972 Ensure_Prior_Elaboration
4974 Unit_Id
=> Unit
(Subp_Rep
),
4975 Prag_Nam
=> Name_Elaborate_All
,
4976 In_State
=> New_In_State
);
4978 end Process_Conditional_ABE_Access_Taken
;
4980 ----------------------------------------
4981 -- Process_Conditional_ABE_Activation --
4982 ----------------------------------------
4984 procedure Process_Conditional_ABE_Activation
4986 Call_Rep
: Scenario_Rep_Id
;
4988 Obj_Rep
: Target_Rep_Id
;
4989 Task_Typ
: Entity_Id
;
4990 Task_Rep
: Target_Rep_Id
;
4991 In_State
: Processing_In_State
)
4993 pragma Unreferenced
(Task_Typ
);
4995 Body_Decl
: constant Node_Id
:= Body_Declaration
(Task_Rep
);
4996 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Task_Rep
);
4997 Root
: constant Node_Id
:= Root_Scenario
;
4998 Unit_Id
: constant Node_Id
:= Unit
(Task_Rep
);
5000 Check_OK
: constant Boolean :=
5001 not In_State
.Suppress_Checks
5002 and then Ghost_Mode_Of
(Obj_Rep
) /= Is_Ignored
5003 and then Ghost_Mode_Of
(Task_Rep
) /= Is_Ignored
5004 and then Elaboration_Checks_OK
(Obj_Rep
)
5005 and then Elaboration_Checks_OK
(Task_Rep
);
5006 -- A run-time ABE check may be installed only when the object and the
5007 -- task type have active elaboration checks, and both are not ignored
5008 -- Ghost constructs.
5010 New_In_State
: Processing_In_State
:= In_State
;
5011 -- Each step of the Processing phase constitutes a new state
5014 -- Output relevant information when switch -gnatel (info messages on
5015 -- implicit Elaborate[_All] pragmas) is in effect.
5017 if Elab_Info_Messages
5018 and then not New_In_State
.Suppress_Info_Messages
5021 ("info: activation of & during elaboration?$?", Call
, Obj_Id
);
5024 -- Nothing to do when the call activates a task whose type is defined
5025 -- within an instance and switch -gnatd_i (ignore activations and
5026 -- calls to instances for elaboration) is in effect.
5028 if Debug_Flag_Underscore_I
5029 and then In_External_Instance
5031 Target_Decl
=> Spec_Decl
)
5035 -- Nothing to do when the activation is a guaranteed ABE
5037 elsif Is_Known_Guaranteed_ABE
(Call
) then
5040 -- Nothing to do when the root scenario appears at the declaration
5041 -- level and the task is in the same unit, but outside this context.
5043 -- task type Task_Typ; -- task declaration
5045 -- procedure Proc is
5046 -- function A ... is
5048 -- if Some_Condition then
5052 -- <activation call> -- activation site
5057 -- X : ... := A; -- root scenario
5060 -- task body Task_Typ is
5064 -- In the example above, the context of X is the declarative list of
5065 -- Proc. The "elaboration" of X may reach the activation of T whose
5066 -- body is defined outside of X's context. The task body is relevant
5067 -- only when Proc is invoked, but this happens only during "normal"
5068 -- elaboration, therefore the task body must not be considered if
5069 -- this is not the case.
5071 elsif Is_Up_Level_Target
5072 (Targ_Decl
=> Spec_Decl
,
5073 In_State
=> New_In_State
)
5077 -- Nothing to do when the activation is ABE-safe
5081 -- task type Task_Typ;
5084 -- package body Gen is
5085 -- task body Task_Typ is
5092 -- procedure Main is
5093 -- package Nested is
5094 -- package Inst is new Gen;
5095 -- T : Inst.Task_Typ;
5096 -- <activation call> -- safe activation
5100 elsif Is_Safe_Activation
(Call
, Task_Rep
) then
5102 -- Note that the task body must still be examined for any nested
5107 -- The activation call and the task body are both in the main unit
5109 -- If the root scenario appears prior to the task body, then this is
5110 -- a possible ABE with respect to the root scenario.
5112 -- task type Task_Typ;
5114 -- function A ... is
5116 -- if Some_Condition then
5120 -- end Pack; -- activation of T
5124 -- X : ... := A; -- root scenario
5126 -- task body Task_Typ is -- task body
5130 -- Y : ... := A; -- root scenario
5132 -- IMPORTANT: The activation of T is a possible ABE for X, but
5133 -- not for Y. Intalling an unconditional ABE raise prior to the
5134 -- activation call would be wrong as it will fail for Y as well
5135 -- but in Y's case the activation of T is never an ABE.
5137 elsif Present
(Body_Decl
)
5138 and then In_Extended_Main_Code_Unit
(Body_Decl
)
5140 if Earlier_In_Extended_Unit
(Root
, Body_Decl
) then
5142 -- Do not emit any ABE diagnostics when a previous scenario in
5143 -- this traversal has suppressed elaboration warnings.
5145 if New_In_State
.Suppress_Warnings
then
5148 -- Do not emit any ABE diagnostics when the activation occurs
5149 -- in a partial finalization context because this action leads
5150 -- to confusing noise.
5152 elsif New_In_State
.Within_Partial_Finalization
then
5155 -- Otherwise emit the ABE disgnostic
5158 Error_Msg_Sloc
:= Sloc
(Call
);
5160 ("??task & will be activated # before elaboration of its "
5163 ("\Program_Error may be raised at run time", Obj_Id
);
5165 Output_Active_Scenarios
(Obj_Id
, New_In_State
);
5168 -- Install a conditional run-time ABE check to verify that the
5169 -- task body has been elaborated prior to the activation call.
5172 Install_Scenario_ABE_Check
5174 Targ_Id
=> Defining_Entity
(Spec_Decl
),
5175 Targ_Rep
=> Task_Rep
,
5176 Disable
=> Obj_Rep
);
5178 -- Update the state of the Processing phase to indicate that
5179 -- no implicit Elaborate[_All] pragma must be generated from
5182 -- task type Task_Typ;
5184 -- function A ... is
5186 -- if Some_Condition then
5191 -- end Pack; -- activation of T
5197 -- task body Task_Typ is
5199 -- External.Subp; -- imparts Elaborate_All
5202 -- If Some_Condition is True, then the ABE check will fail
5203 -- at runtime and the call to External.Subp will never take
5204 -- place, rendering the implicit Elaborate_All useless.
5206 -- If the value of Some_Condition is False, then the call
5207 -- to External.Subp will never take place, rendering the
5208 -- implicit Elaborate_All useless.
5210 New_In_State
.Suppress_Implicit_Pragmas
:= True;
5214 -- Otherwise the task body is not available in this compilation or
5215 -- it resides in an external unit. Install a run-time ABE check to
5216 -- verify that the task body has been elaborated prior to the
5217 -- activation call when the dynamic model is in effect.
5220 and then New_In_State
.Processing
= Dynamic_Model_Processing
5222 Install_Unit_ABE_Check
5225 Disable
=> Obj_Rep
);
5228 -- Both the activation call and task type are subject to SPARK_Mode
5229 -- On, this triggers the SPARK rules for task activation. Compared
5230 -- to calls and instantiations, task activation in SPARK does not
5231 -- require the presence of Elaborate[_All] pragmas in case the task
5232 -- type is defined outside the main unit. This is because SPARK uses
5233 -- a special policy which activates all tasks after the main unit has
5234 -- finished its elaboration.
5236 if SPARK_Mode_Of
(Call_Rep
) = Is_On
5237 and then SPARK_Mode_Of
(Task_Rep
) = Is_On
5241 -- Otherwise the Ada rules are in effect. Ensure that the unit with
5242 -- the task body is elaborated prior to the main unit.
5245 Ensure_Prior_Elaboration
5248 Prag_Nam
=> Name_Elaborate_All
,
5249 In_State
=> New_In_State
);
5252 Traverse_Conditional_ABE_Body
5254 In_State
=> New_In_State
);
5255 end Process_Conditional_ABE_Activation
;
5257 ----------------------------------
5258 -- Process_Conditional_ABE_Call --
5259 ----------------------------------
5261 procedure Process_Conditional_ABE_Call
5263 Call_Rep
: Scenario_Rep_Id
;
5264 In_State
: Processing_In_State
)
5266 function In_Initialization_Context
(N
: Node_Id
) return Boolean;
5267 pragma Inline
(In_Initialization_Context
);
5268 -- Determine whether arbitrary node N appears within a type init
5269 -- proc, primitive [Deep_]Initialize, or a block created for
5270 -- initialization purposes.
5272 function Is_Partial_Finalization_Proc
5273 (Subp_Id
: Entity_Id
) return Boolean;
5274 pragma Inline
(Is_Partial_Finalization_Proc
);
5275 -- Determine whether subprogram Subp_Id is a partial finalization
5278 -------------------------------
5279 -- In_Initialization_Context --
5280 -------------------------------
5282 function In_Initialization_Context
(N
: Node_Id
) return Boolean is
5284 Spec_Id
: Entity_Id
;
5287 -- Climb the parent chain looking for initialization actions
5290 while Present
(Par
) loop
5292 -- A block may be part of the initialization actions of a
5293 -- default initialized object.
5295 if Nkind
(Par
) = N_Block_Statement
5296 and then Is_Initialization_Block
(Par
)
5300 -- A subprogram body may denote an initialization routine
5302 elsif Nkind
(Par
) = N_Subprogram_Body
then
5303 Spec_Id
:= Unique_Defining_Entity
(Par
);
5305 -- The current subprogram body denotes a type init proc or
5306 -- primitive [Deep_]Initialize.
5308 if Is_Init_Proc
(Spec_Id
)
5309 or else Is_Controlled_Procedure
(Spec_Id
, Name_Initialize
)
5310 or else Is_TSS
(Spec_Id
, TSS_Deep_Initialize
)
5315 -- Prevent the search from going too far
5317 elsif Is_Body_Or_Package_Declaration
(Par
) then
5321 Par
:= Parent
(Par
);
5325 end In_Initialization_Context
;
5327 ----------------------------------
5328 -- Is_Partial_Finalization_Proc --
5329 ----------------------------------
5331 function Is_Partial_Finalization_Proc
5332 (Subp_Id
: Entity_Id
) return Boolean
5335 -- To qualify, the subprogram must denote a finalizer procedure
5336 -- or primitive [Deep_]Finalize, and the call must appear within
5337 -- an initialization context.
5340 (Is_Controlled_Procedure
(Subp_Id
, Name_Finalize
)
5341 or else Is_Finalizer_Proc
(Subp_Id
)
5342 or else Is_TSS
(Subp_Id
, TSS_Deep_Finalize
))
5343 and then In_Initialization_Context
(Call
);
5344 end Is_Partial_Finalization_Proc
;
5348 Subp_Id
: constant Entity_Id
:= Target
(Call_Rep
);
5349 Subp_Rep
: constant Target_Rep_Id
:=
5350 Target_Representation_Of
(Subp_Id
, In_State
);
5351 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
5352 Subp_Decl
: constant Node_Id
:= Spec_Declaration
(Subp_Rep
);
5354 SPARK_Rules_On
: constant Boolean :=
5355 SPARK_Mode_Of
(Call_Rep
) = Is_On
5356 and then SPARK_Mode_Of
(Subp_Rep
) = Is_On
;
5358 New_In_State
: Processing_In_State
:= In_State
;
5359 -- Each step of the Processing phase constitutes a new state
5361 -- Start of processing for Process_Conditional_ABE_Call
5364 -- Output relevant information when switch -gnatel (info messages on
5365 -- implicit Elaborate[_All] pragmas) is in effect.
5367 if Elab_Info_Messages
5368 and then not New_In_State
.Suppress_Info_Messages
5374 In_SPARK
=> SPARK_Rules_On
);
5377 -- Check whether the invocation of an entry clashes with an existing
5378 -- restriction. This check is relevant only when the processing was
5379 -- started from some library-level scenario.
5381 if Is_Protected_Entry
(Subp_Id
) then
5382 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
5384 elsif Is_Task_Entry
(Subp_Id
) then
5385 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, Call
);
5387 -- Task entry calls are never processed because the entry being
5388 -- invoked does not have a corresponding "body", it has a select.
5393 -- Nothing to do when the call invokes a target defined within an
5394 -- instance and switch -gnatd_i (ignore activations and calls to
5395 -- instances for elaboration) is in effect.
5397 if Debug_Flag_Underscore_I
5398 and then In_External_Instance
5400 Target_Decl
=> Subp_Decl
)
5404 -- Nothing to do when the call is a guaranteed ABE
5406 elsif Is_Known_Guaranteed_ABE
(Call
) then
5409 -- Nothing to do when the root scenario appears at the declaration
5410 -- level and the target is in the same unit but outside this context.
5412 -- function B ...; -- target declaration
5414 -- procedure Proc is
5415 -- function A ... is
5417 -- if Some_Condition then
5418 -- return B; -- call site
5422 -- X : ... := A; -- root scenario
5425 -- function B ... is
5429 -- In the example above, the context of X is the declarative region
5430 -- of Proc. The "elaboration" of X may eventually reach B which is
5431 -- defined outside of X's context. B is relevant only when Proc is
5432 -- invoked, but this happens only by means of "normal" elaboration,
5433 -- therefore B must not be considered if this is not the case.
5435 elsif Is_Up_Level_Target
5436 (Targ_Decl
=> Subp_Decl
,
5437 In_State
=> New_In_State
)
5442 -- Warnings are suppressed when a prior scenario is already in that
5443 -- mode, or the call or target have warnings suppressed. Update the
5444 -- state of the Processing phase to reflect this.
5446 New_In_State
.Suppress_Warnings
:=
5447 New_In_State
.Suppress_Warnings
5448 or else not Elaboration_Warnings_OK
(Call_Rep
)
5449 or else not Elaboration_Warnings_OK
(Subp_Rep
);
5451 -- The call occurs in freezing actions context when a prior scenario
5452 -- is already in that mode, or when the target is a subprogram whose
5453 -- body has been generated as a freezing action. Update the state of
5454 -- the Processing phase to reflect this.
5456 New_In_State
.Within_Freezing_Actions
:=
5457 New_In_State
.Within_Freezing_Actions
5458 or else (Present
(Body_Decl
)
5459 and then Nkind
(Parent
(Body_Decl
)) = N_Freeze_Entity
);
5461 -- The call occurs in an initial condition context when a prior
5462 -- scenario is already in that mode, or when the target is an
5463 -- Initial_Condition procedure. Update the state of the Processing
5464 -- phase to reflect this.
5466 New_In_State
.Within_Initial_Condition
:=
5467 New_In_State
.Within_Initial_Condition
5468 or else Is_Initial_Condition_Proc
(Subp_Id
);
5470 -- The call occurs in a partial finalization context when a prior
5471 -- scenario is already in that mode, or when the target denotes a
5472 -- [Deep_]Finalize primitive or a finalizer within an initialization
5473 -- context. Update the state of the Processing phase to reflect this.
5475 New_In_State
.Within_Partial_Finalization
:=
5476 New_In_State
.Within_Partial_Finalization
5477 or else Is_Partial_Finalization_Proc
(Subp_Id
);
5479 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK
5480 -- elaboration rules in SPARK code) is intentionally not taken into
5481 -- account here because Process_Conditional_ABE_Call_SPARK has two
5482 -- separate modes of operation.
5484 if SPARK_Rules_On
then
5485 Process_Conditional_ABE_Call_SPARK
5487 Call_Rep
=> Call_Rep
,
5489 Subp_Rep
=> Subp_Rep
,
5490 In_State
=> New_In_State
);
5492 -- Otherwise the Ada rules are in effect
5495 Process_Conditional_ABE_Call_Ada
5497 Call_Rep
=> Call_Rep
,
5499 Subp_Rep
=> Subp_Rep
,
5500 In_State
=> New_In_State
);
5503 -- Inspect the target body (and barried function) for other suitable
5504 -- elaboration scenarios.
5506 Traverse_Conditional_ABE_Body
5507 (N
=> Barrier_Body_Declaration
(Subp_Rep
),
5508 In_State
=> New_In_State
);
5510 Traverse_Conditional_ABE_Body
5512 In_State
=> New_In_State
);
5513 end Process_Conditional_ABE_Call
;
5515 --------------------------------------
5516 -- Process_Conditional_ABE_Call_Ada --
5517 --------------------------------------
5519 procedure Process_Conditional_ABE_Call_Ada
5521 Call_Rep
: Scenario_Rep_Id
;
5522 Subp_Id
: Entity_Id
;
5523 Subp_Rep
: Target_Rep_Id
;
5524 In_State
: Processing_In_State
)
5526 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
5527 Root
: constant Node_Id
:= Root_Scenario
;
5528 Unit_Id
: constant Node_Id
:= Unit
(Subp_Rep
);
5530 Check_OK
: constant Boolean :=
5531 not In_State
.Suppress_Checks
5532 and then Ghost_Mode_Of
(Call_Rep
) /= Is_Ignored
5533 and then Ghost_Mode_Of
(Subp_Rep
) /= Is_Ignored
5534 and then Elaboration_Checks_OK
(Call_Rep
)
5535 and then Elaboration_Checks_OK
(Subp_Rep
);
5536 -- A run-time ABE check may be installed only when both the call
5537 -- and the target have active elaboration checks, and both are not
5538 -- ignored Ghost constructs.
5540 New_In_State
: Processing_In_State
:= In_State
;
5541 -- Each step of the Processing phase constitutes a new state
5544 -- Nothing to do for an Ada dispatching call because there are no
5545 -- ABE diagnostics for either models. ABE checks for the dynamic
5546 -- model are handled by Install_Primitive_Elaboration_Check.
5548 if Is_Dispatching_Call
(Call_Rep
) then
5551 -- Nothing to do when the call is ABE-safe
5554 -- function Gen ...;
5556 -- function Gen ... is
5562 -- procedure Main is
5563 -- function Inst is new Gen;
5564 -- X : ... := Inst; -- safe call
5567 elsif Is_Safe_Call
(Call
, Subp_Id
, Subp_Rep
) then
5570 -- The call and the target body are both in the main unit
5572 -- If the root scenario appears prior to the target body, then this
5573 -- is a possible ABE with respect to the root scenario.
5577 -- function A ... is
5579 -- if Some_Condition then
5580 -- return B; -- call site
5584 -- X : ... := A; -- root scenario
5586 -- function B ... is -- target body
5590 -- Y : ... := A; -- root scenario
5592 -- IMPORTANT: The call to B from A is a possible ABE for X, but
5593 -- not for Y. Installing an unconditional ABE raise prior to the
5594 -- call to B would be wrong as it will fail for Y as well, but in
5595 -- Y's case the call to B is never an ABE.
5597 elsif Present
(Body_Decl
)
5598 and then In_Extended_Main_Code_Unit
(Body_Decl
)
5600 if Earlier_In_Extended_Unit
(Root
, Body_Decl
) then
5602 -- Do not emit any ABE diagnostics when a previous scenario in
5603 -- this traversal has suppressed elaboration warnings.
5605 if New_In_State
.Suppress_Warnings
then
5608 -- Do not emit any ABE diagnostics when the call occurs in a
5609 -- partial finalization context because this leads to confusing
5612 elsif New_In_State
.Within_Partial_Finalization
then
5615 -- Otherwise emit the ABE diagnostic
5619 ("??cannot call & before body seen", Call
, Subp_Id
);
5621 ("\Program_Error may be raised at run time", Call
);
5623 Output_Active_Scenarios
(Call
, New_In_State
);
5626 -- Install a conditional run-time ABE check to verify that the
5627 -- target body has been elaborated prior to the call.
5630 Install_Scenario_ABE_Check
5633 Targ_Rep
=> Subp_Rep
,
5634 Disable
=> Call_Rep
);
5636 -- Update the state of the Processing phase to indicate that
5637 -- no implicit Elaborate[_All] pragma must be generated from
5642 -- function A ... is
5644 -- if Some_Condition then
5652 -- function B ... is
5653 -- External.Subp; -- imparts Elaborate_All
5656 -- If Some_Condition is True, then the ABE check will fail
5657 -- at runtime and the call to External.Subp will never take
5658 -- place, rendering the implicit Elaborate_All useless.
5660 -- If the value of Some_Condition is False, then the call
5661 -- to External.Subp will never take place, rendering the
5662 -- implicit Elaborate_All useless.
5664 New_In_State
.Suppress_Implicit_Pragmas
:= True;
5668 -- Otherwise the target body is not available in this compilation or
5669 -- it resides in an external unit. Install a run-time ABE check to
5670 -- verify that the target body has been elaborated prior to the call
5671 -- site when the dynamic model is in effect.
5674 and then New_In_State
.Processing
= Dynamic_Model_Processing
5676 Install_Unit_ABE_Check
5679 Disable
=> Call_Rep
);
5682 -- Ensure that the unit with the target body is elaborated prior to
5683 -- the main unit. The implicit Elaborate[_All] is generated only when
5684 -- the call has elaboration checks enabled. This behavior parallels
5685 -- that of the old ABE mechanism.
5687 if Elaboration_Checks_OK
(Call_Rep
) then
5688 Ensure_Prior_Elaboration
5691 Prag_Nam
=> Name_Elaborate_All
,
5692 In_State
=> New_In_State
);
5694 end Process_Conditional_ABE_Call_Ada
;
5696 ----------------------------------------
5697 -- Process_Conditional_ABE_Call_SPARK --
5698 ----------------------------------------
5700 procedure Process_Conditional_ABE_Call_SPARK
5702 Call_Rep
: Scenario_Rep_Id
;
5703 Subp_Id
: Entity_Id
;
5704 Subp_Rep
: Target_Rep_Id
;
5705 In_State
: Processing_In_State
)
5707 pragma Unreferenced
(Call_Rep
);
5709 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
5713 -- Ensure that a suitable elaboration model is in effect for SPARK
5714 -- rule verification.
5716 Check_SPARK_Model_In_Effect
;
5718 -- The call and the target body are both in the main unit
5720 if Present
(Body_Decl
)
5721 and then In_Extended_Main_Code_Unit
(Body_Decl
)
5722 and then Earlier_In_Extended_Unit
(Call
, Body_Decl
)
5724 -- Do not emit any ABE diagnostics when a previous scenario in
5725 -- this traversal has suppressed elaboration warnings.
5727 if In_State
.Suppress_Warnings
then
5730 -- Do not emit any ABE diagnostics when the call occurs in a
5731 -- freezing actions context because this leads to incorrect
5734 elsif In_State
.Within_Freezing_Actions
then
5737 -- Do not emit any ABE diagnostics when the call occurs in an
5738 -- initial condition context because this leads to incorrect
5741 elsif In_State
.Within_Initial_Condition
then
5744 -- Do not emit any ABE diagnostics when the call occurs in a
5745 -- partial finalization context because this leads to confusing
5748 elsif In_State
.Within_Partial_Finalization
then
5751 -- Ensure that a call that textually precedes the subprogram body
5752 -- it invokes appears within the early call region of the body.
5754 -- IMPORTANT: This check must always be performed even when switch
5755 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
5756 -- specified because the static model cannot guarantee the absence
5757 -- of elaboration issues when dispatching calls are involved.
5760 Region
:= Find_Early_Call_Region
(Body_Decl
);
5762 if Earlier_In_Extended_Unit
(Call
, Region
) then
5764 ("call must appear within early call region of subprogram "
5765 & "body & (SPARK RM 7.7(3))",
5768 Error_Msg_Sloc
:= Sloc
(Region
);
5769 Error_Msg_N
("\region starts #", Call
);
5771 Error_Msg_Sloc
:= Sloc
(Body_Decl
);
5772 Error_Msg_N
("\region ends #", Call
);
5774 Output_Active_Scenarios
(Call
, In_State
);
5779 -- A call to a source target or to a target which emulates Ada
5780 -- or SPARK semantics imposes an Elaborate_All requirement on the
5781 -- context of the main unit. Determine whether the context has a
5782 -- pragma strong enough to meet the requirement.
5784 -- IMPORTANT: This check must be performed only when switch -gnatd.v
5785 -- (enforce SPARK elaboration rules in SPARK code) is active because
5786 -- the static model can ensure the prior elaboration of the unit
5787 -- which contains a body by installing an implicit Elaborate[_All]
5790 if Debug_Flag_Dot_V
then
5791 if Comes_From_Source
(Subp_Id
)
5792 or else Is_Ada_Semantic_Target
(Subp_Id
)
5793 or else Is_SPARK_Semantic_Target
(Subp_Id
)
5795 Meet_Elaboration_Requirement
5798 Req_Nam
=> Name_Elaborate_All
,
5799 In_State
=> In_State
);
5802 -- Otherwise ensure that the unit with the target body is elaborated
5803 -- prior to the main unit.
5806 Ensure_Prior_Elaboration
5808 Unit_Id
=> Unit
(Subp_Rep
),
5809 Prag_Nam
=> Name_Elaborate_All
,
5810 In_State
=> In_State
);
5812 end Process_Conditional_ABE_Call_SPARK
;
5814 -------------------------------------------
5815 -- Process_Conditional_ABE_Instantiation --
5816 -------------------------------------------
5818 procedure Process_Conditional_ABE_Instantiation
5820 Inst_Rep
: Scenario_Rep_Id
;
5821 In_State
: Processing_In_State
)
5823 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
5824 Gen_Rep
: constant Target_Rep_Id
:=
5825 Target_Representation_Of
(Gen_Id
, In_State
);
5827 SPARK_Rules_On
: constant Boolean :=
5828 SPARK_Mode_Of
(Inst_Rep
) = Is_On
5829 and then SPARK_Mode_Of
(Gen_Rep
) = Is_On
;
5831 New_In_State
: Processing_In_State
:= In_State
;
5832 -- Each step of the Processing phase constitutes a new state
5835 -- Output relevant information when switch -gnatel (info messages on
5836 -- implicit Elaborate[_All] pragmas) is in effect.
5838 if Elab_Info_Messages
5839 and then not New_In_State
.Suppress_Info_Messages
5845 In_SPARK
=> SPARK_Rules_On
);
5848 -- Nothing to do when the instantiation is a guaranteed ABE
5850 if Is_Known_Guaranteed_ABE
(Inst
) then
5853 -- Nothing to do when the root scenario appears at the declaration
5854 -- level and the generic is in the same unit, but outside this
5858 -- procedure Gen is ...; -- generic declaration
5860 -- procedure Proc is
5861 -- function A ... is
5863 -- if Some_Condition then
5865 -- procedure I is new Gen; -- instantiation site
5870 -- X : ... := A; -- root scenario
5877 -- In the example above, the context of X is the declarative region
5878 -- of Proc. The "elaboration" of X may eventually reach Gen which
5879 -- appears outside of X's context. Gen is relevant only when Proc is
5880 -- invoked, but this happens only by means of "normal" elaboration,
5881 -- therefore Gen must not be considered if this is not the case.
5883 elsif Is_Up_Level_Target
5884 (Targ_Decl
=> Spec_Declaration
(Gen_Rep
),
5885 In_State
=> New_In_State
)
5890 -- Warnings are suppressed when a prior scenario is already in that
5891 -- mode, or when the instantiation has warnings suppressed. Update
5892 -- the state of the processing phase to reflect this.
5894 New_In_State
.Suppress_Warnings
:=
5895 New_In_State
.Suppress_Warnings
5896 or else not Elaboration_Warnings_OK
(Inst_Rep
);
5898 -- The SPARK rules are in effect
5900 if SPARK_Rules_On
then
5901 Process_Conditional_ABE_Instantiation_SPARK
5903 Inst_Rep
=> Inst_Rep
,
5906 In_State
=> New_In_State
);
5908 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
5909 -- violate the SPARK rules.
5912 Process_Conditional_ABE_Instantiation_Ada
5914 Inst_Rep
=> Inst_Rep
,
5917 In_State
=> New_In_State
);
5919 end Process_Conditional_ABE_Instantiation
;
5921 -----------------------------------------------
5922 -- Process_Conditional_ABE_Instantiation_Ada --
5923 -----------------------------------------------
5925 procedure Process_Conditional_ABE_Instantiation_Ada
5927 Inst_Rep
: Scenario_Rep_Id
;
5929 Gen_Rep
: Target_Rep_Id
;
5930 In_State
: Processing_In_State
)
5932 Body_Decl
: constant Node_Id
:= Body_Declaration
(Gen_Rep
);
5933 Root
: constant Node_Id
:= Root_Scenario
;
5934 Unit_Id
: constant Entity_Id
:= Unit
(Gen_Rep
);
5936 Check_OK
: constant Boolean :=
5937 not In_State
.Suppress_Checks
5938 and then Ghost_Mode_Of
(Inst_Rep
) /= Is_Ignored
5939 and then Ghost_Mode_Of
(Gen_Rep
) /= Is_Ignored
5940 and then Elaboration_Checks_OK
(Inst_Rep
)
5941 and then Elaboration_Checks_OK
(Gen_Rep
);
5942 -- A run-time ABE check may be installed only when both the instance
5943 -- and the generic have active elaboration checks and both are not
5944 -- ignored Ghost constructs.
5946 New_In_State
: Processing_In_State
:= In_State
;
5947 -- Each step of the Processing phase constitutes a new state
5950 -- Nothing to do when the instantiation is ABE-safe
5957 -- package body Gen is
5962 -- procedure Main is
5963 -- package Inst is new Gen (ABE); -- safe instantiation
5966 if Is_Safe_Instantiation
(Inst
, Gen_Id
, Gen_Rep
) then
5969 -- The instantiation and the generic body are both in the main unit
5971 -- If the root scenario appears prior to the generic body, then this
5972 -- is a possible ABE with respect to the root scenario.
5979 -- function A ... is
5981 -- if Some_Condition then
5983 -- package Inst is new Gen; -- instantiation site
5987 -- X : ... := A; -- root scenario
5989 -- package body Gen is -- generic body
5993 -- Y : ... := A; -- root scenario
5995 -- IMPORTANT: The instantiation of Gen is a possible ABE for X,
5996 -- but not for Y. Installing an unconditional ABE raise prior to
5997 -- the instance site would be wrong as it will fail for Y as well,
5998 -- but in Y's case the instantiation of Gen is never an ABE.
6000 elsif Present
(Body_Decl
)
6001 and then In_Extended_Main_Code_Unit
(Body_Decl
)
6003 if Earlier_In_Extended_Unit
(Root
, Body_Decl
) then
6005 -- Do not emit any ABE diagnostics when a previous scenario in
6006 -- this traversal has suppressed elaboration warnings.
6008 if New_In_State
.Suppress_Warnings
then
6011 -- Do not emit any ABE diagnostics when the instantiation
6012 -- occurs in partial finalization context because this leads
6013 -- to unwanted noise.
6015 elsif New_In_State
.Within_Partial_Finalization
then
6018 -- Otherwise output the diagnostic
6022 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
6024 ("\Program_Error may be raised at run time", Inst
);
6026 Output_Active_Scenarios
(Inst
, New_In_State
);
6029 -- Install a conditional run-time ABE check to verify that the
6030 -- generic body has been elaborated prior to the instantiation.
6033 Install_Scenario_ABE_Check
6036 Targ_Rep
=> Gen_Rep
,
6037 Disable
=> Inst_Rep
);
6039 -- Update the state of the Processing phase to indicate that
6040 -- no implicit Elaborate[_All] pragma must be generated from
6048 -- function A ... is
6050 -- if Some_Condition then
6052 -- declare Inst is new Gen;
6058 -- package body Gen is
6060 -- External.Subp; -- imparts Elaborate_All
6063 -- If Some_Condition is True, then the ABE check will fail
6064 -- at runtime and the call to External.Subp will never take
6065 -- place, rendering the implicit Elaborate_All useless.
6067 -- If the value of Some_Condition is False, then the call
6068 -- to External.Subp will never take place, rendering the
6069 -- implicit Elaborate_All useless.
6071 New_In_State
.Suppress_Implicit_Pragmas
:= True;
6075 -- Otherwise the generic body is not available in this compilation
6076 -- or it resides in an external unit. Install a run-time ABE check
6077 -- to verify that the generic body has been elaborated prior to the
6078 -- instantiation when the dynamic model is in effect.
6081 and then New_In_State
.Processing
= Dynamic_Model_Processing
6083 Install_Unit_ABE_Check
6086 Disable
=> Inst_Rep
);
6089 -- Ensure that the unit with the generic body is elaborated prior
6090 -- to the main unit. No implicit pragma has to be generated if the
6091 -- instantiation has elaboration checks suppressed. This behavior
6092 -- parallels that of the old ABE mechanism.
6094 if Elaboration_Checks_OK
(Inst_Rep
) then
6095 Ensure_Prior_Elaboration
6098 Prag_Nam
=> Name_Elaborate
,
6099 In_State
=> New_In_State
);
6101 end Process_Conditional_ABE_Instantiation_Ada
;
6103 -------------------------------------------------
6104 -- Process_Conditional_ABE_Instantiation_SPARK --
6105 -------------------------------------------------
6107 procedure Process_Conditional_ABE_Instantiation_SPARK
6109 Inst_Rep
: Scenario_Rep_Id
;
6111 Gen_Rep
: Target_Rep_Id
;
6112 In_State
: Processing_In_State
)
6114 pragma Unreferenced
(Inst_Rep
);
6119 -- Ensure that a suitable elaboration model is in effect for SPARK
6120 -- rule verification.
6122 Check_SPARK_Model_In_Effect
;
6124 -- A source instantiation imposes an Elaborate[_All] requirement
6125 -- on the context of the main unit. Determine whether the context
6126 -- has a pragma strong enough to meet the requirement. The check
6127 -- is orthogonal to the ABE ramifications of the instantiation.
6129 -- IMPORTANT: This check must be performed only when switch -gnatd.v
6130 -- (enforce SPARK elaboration rules in SPARK code) is active because
6131 -- the static model can ensure the prior elaboration of the unit
6132 -- which contains a body by installing an implicit Elaborate[_All]
6135 if Debug_Flag_Dot_V
then
6136 if Nkind
(Inst
) = N_Package_Instantiation
then
6137 Req_Nam
:= Name_Elaborate_All
;
6139 Req_Nam
:= Name_Elaborate
;
6142 Meet_Elaboration_Requirement
6146 In_State
=> In_State
);
6148 -- Otherwise ensure that the unit with the target body is elaborated
6149 -- prior to the main unit.
6152 Ensure_Prior_Elaboration
6154 Unit_Id
=> Unit
(Gen_Rep
),
6155 Prag_Nam
=> Name_Elaborate
,
6156 In_State
=> In_State
);
6158 end Process_Conditional_ABE_Instantiation_SPARK
;
6160 -------------------------------------------------
6161 -- Process_Conditional_ABE_Variable_Assignment --
6162 -------------------------------------------------
6164 procedure Process_Conditional_ABE_Variable_Assignment
6166 Asmt_Rep
: Scenario_Rep_Id
;
6167 In_State
: Processing_In_State
)
6170 Var_Id
: constant Entity_Id
:= Target
(Asmt_Rep
);
6171 Var_Rep
: constant Target_Rep_Id
:=
6172 Target_Representation_Of
(Var_Id
, In_State
);
6174 SPARK_Rules_On
: constant Boolean :=
6175 SPARK_Mode_Of
(Asmt_Rep
) = Is_On
6176 and then SPARK_Mode_Of
(Var_Rep
) = Is_On
;
6179 -- Output relevant information when switch -gnatel (info messages on
6180 -- implicit Elaborate[_All] pragmas) is in effect.
6182 if Elab_Info_Messages
6183 and then not In_State
.Suppress_Info_Messages
6186 (Msg
=> "assignment to & during elaboration",
6190 In_SPARK
=> SPARK_Rules_On
);
6193 -- The SPARK rules are in effect. These rules are applied regardless
6194 -- of whether switch -gnatd.v (enforce SPARK elaboration rules in
6195 -- SPARK code) is in effect because the static model cannot ensure
6196 -- safe assignment of variables.
6198 if SPARK_Rules_On
then
6199 Process_Conditional_ABE_Variable_Assignment_SPARK
6201 Asmt_Rep
=> Asmt_Rep
,
6204 In_State
=> In_State
);
6206 -- Otherwise the Ada rules are in effect
6209 Process_Conditional_ABE_Variable_Assignment_Ada
6211 Asmt_Rep
=> Asmt_Rep
,
6214 In_State
=> In_State
);
6216 end Process_Conditional_ABE_Variable_Assignment
;
6218 -----------------------------------------------------
6219 -- Process_Conditional_ABE_Variable_Assignment_Ada --
6220 -----------------------------------------------------
6222 procedure Process_Conditional_ABE_Variable_Assignment_Ada
6224 Asmt_Rep
: Scenario_Rep_Id
;
6226 Var_Rep
: Target_Rep_Id
;
6227 In_State
: Processing_In_State
)
6229 pragma Unreferenced
(Asmt_Rep
);
6231 Var_Decl
: constant Node_Id
:= Variable_Declaration
(Var_Rep
);
6232 Unit_Id
: constant Entity_Id
:= Unit
(Var_Rep
);
6235 -- Emit a warning when an uninitialized variable declared in a
6236 -- package spec without a pragma Elaborate_Body is initialized
6237 -- by elaboration code within the corresponding body.
6239 if Is_Elaboration_Warnings_OK_Id
(Var_Id
)
6240 and then not Is_Initialized
(Var_Decl
)
6241 and then not Has_Pragma_Elaborate_Body
(Unit_Id
)
6243 -- Do not emit any ABE diagnostics when a previous scenario in
6244 -- this traversal has suppressed elaboration warnings.
6246 if not In_State
.Suppress_Warnings
then
6248 ("??variable & can be accessed by clients before this "
6249 & "initialization", Asmt
, Var_Id
);
6252 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
6253 & "initialization", Asmt
, Unit_Id
);
6255 Output_Active_Scenarios
(Asmt
, In_State
);
6258 -- Generate an implicit Elaborate_Body in the spec
6260 Set_Elaborate_Body_Desirable
(Unit_Id
);
6262 end Process_Conditional_ABE_Variable_Assignment_Ada
;
6264 -------------------------------------------------------
6265 -- Process_Conditional_ABE_Variable_Assignment_SPARK --
6266 -------------------------------------------------------
6268 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
6270 Asmt_Rep
: Scenario_Rep_Id
;
6272 Var_Rep
: Target_Rep_Id
;
6273 In_State
: Processing_In_State
)
6275 pragma Unreferenced
(Asmt_Rep
);
6277 Var_Decl
: constant Node_Id
:= Variable_Declaration
(Var_Rep
);
6278 Unit_Id
: constant Entity_Id
:= Unit
(Var_Rep
);
6281 -- Ensure that a suitable elaboration model is in effect for SPARK
6282 -- rule verification.
6284 Check_SPARK_Model_In_Effect
;
6286 -- Do not emit any ABE diagnostics when a previous scenario in this
6287 -- traversal has suppressed elaboration warnings.
6289 if In_State
.Suppress_Warnings
then
6292 -- Emit an error when an initialized variable declared in a package
6293 -- spec that is missing pragma Elaborate_Body is further modified by
6294 -- elaboration code within the corresponding body.
6296 elsif Is_Elaboration_Warnings_OK_Id
(Var_Id
)
6297 and then Is_Initialized
(Var_Decl
)
6298 and then not Has_Pragma_Elaborate_Body
(Unit_Id
)
6301 ("variable & modified by elaboration code in package body",
6305 ("\add pragma ""Elaborate_Body"" to spec & to ensure full "
6306 & "initialization", Asmt
, Unit_Id
);
6308 Output_Active_Scenarios
(Asmt
, In_State
);
6310 end Process_Conditional_ABE_Variable_Assignment_SPARK
;
6312 ------------------------------------------------
6313 -- Process_Conditional_ABE_Variable_Reference --
6314 ------------------------------------------------
6316 procedure Process_Conditional_ABE_Variable_Reference
6318 Ref_Rep
: Scenario_Rep_Id
;
6319 In_State
: Processing_In_State
)
6321 Var_Id
: constant Entity_Id
:= Target
(Ref
);
6322 Var_Rep
: Target_Rep_Id
;
6323 Unit_Id
: Entity_Id
;
6326 -- Nothing to do when the variable reference is not a read
6328 if not Is_Read_Reference
(Ref_Rep
) then
6332 Var_Rep
:= Target_Representation_Of
(Var_Id
, In_State
);
6333 Unit_Id
:= Unit
(Var_Rep
);
6335 -- Output relevant information when switch -gnatel (info messages on
6336 -- implicit Elaborate[_All] pragmas) is in effect.
6338 if Elab_Info_Messages
6339 and then not In_State
.Suppress_Info_Messages
6342 (Msg
=> "read of variable & during elaboration",
6349 -- Nothing to do when the variable appears within the main unit
6350 -- because diagnostics on reads are relevant only for external
6353 if Is_Same_Unit
(Unit_Id
, Main_Unit_Entity
) then
6356 -- Nothing to do when the variable is already initialized. Note that
6357 -- the variable may be further modified by the external unit.
6359 elsif Is_Initialized
(Variable_Declaration
(Var_Rep
)) then
6362 -- Nothing to do when the external unit guarantees the initialization
6363 -- of the variable by means of pragma Elaborate_Body.
6365 elsif Has_Pragma_Elaborate_Body
(Unit_Id
) then
6368 -- A variable read imposes an Elaborate requirement on the context of
6369 -- the main unit. Determine whether the context has a pragma strong
6370 -- enough to meet the requirement.
6373 Meet_Elaboration_Requirement
6376 Req_Nam
=> Name_Elaborate
,
6377 In_State
=> In_State
);
6379 end Process_Conditional_ABE_Variable_Reference
;
6381 -----------------------------------
6382 -- Traverse_Conditional_ABE_Body --
6383 -----------------------------------
6385 procedure Traverse_Conditional_ABE_Body
6387 In_State
: Processing_In_State
)
6392 Requires_Processing
=> Is_Conditional_ABE_Scenario
'Access,
6393 Processor
=> Process_Conditional_ABE
'Access,
6394 In_State
=> In_State
);
6395 end Traverse_Conditional_ABE_Body
;
6396 end Conditional_ABE_Processor
;
6402 procedure Destroy
(NE
: in out Node_Or_Entity_Id
) is
6403 pragma Unreferenced
(NE
);
6412 package body Diagnostics
is
6418 procedure Elab_Msg_NE
6425 function Prefix
return String;
6426 pragma Inline
(Prefix
);
6427 -- Obtain the prefix of the message
6429 function Suffix
return String;
6430 pragma Inline
(Suffix
);
6431 -- Obtain the suffix of the message
6437 function Prefix
return String is
6450 function Suffix
return String is
6459 -- Start of processing for Elab_Msg_NE
6462 Error_Msg_NE
(Prefix
& Msg
& Suffix
, N
, Id
);
6471 Subp_Id
: Entity_Id
;
6475 procedure Info_Accept_Alternative
;
6476 pragma Inline
(Info_Accept_Alternative
);
6477 -- Output information concerning an accept alternative
6479 procedure Info_Simple_Call
;
6480 pragma Inline
(Info_Simple_Call
);
6481 -- Output information concerning the call
6483 procedure Info_Type_Actions
(Action
: String);
6484 pragma Inline
(Info_Type_Actions
);
6485 -- Output information concerning action Action of a type
6487 procedure Info_Verification_Call
6491 pragma Inline
(Info_Verification_Call
);
6492 -- Output information concerning the verification of predicate Pred
6493 -- applied to related entity Id with kind Id_Kind.
6495 -----------------------------
6496 -- Info_Accept_Alternative --
6497 -----------------------------
6499 procedure Info_Accept_Alternative
is
6500 Entry_Id
: constant Entity_Id
:= Receiving_Entry
(Subp_Id
);
6501 pragma Assert
(Present
(Entry_Id
));
6505 (Msg
=> "accept for entry & during elaboration",
6508 Info_Msg
=> Info_Msg
,
6509 In_SPARK
=> In_SPARK
);
6510 end Info_Accept_Alternative
;
6512 ----------------------
6513 -- Info_Simple_Call --
6514 ----------------------
6516 procedure Info_Simple_Call
is
6519 (Msg
=> "call to & during elaboration",
6522 Info_Msg
=> Info_Msg
,
6523 In_SPARK
=> In_SPARK
);
6524 end Info_Simple_Call
;
6526 -----------------------
6527 -- Info_Type_Actions --
6528 -----------------------
6530 procedure Info_Type_Actions
(Action
: String) is
6531 Typ
: constant Entity_Id
:= First_Formal_Type
(Subp_Id
);
6532 pragma Assert
(Present
(Typ
));
6536 (Msg
=> Action
& " actions for type & during elaboration",
6539 Info_Msg
=> Info_Msg
,
6540 In_SPARK
=> In_SPARK
);
6541 end Info_Type_Actions
;
6543 ----------------------------
6544 -- Info_Verification_Call --
6545 ----------------------------
6547 procedure Info_Verification_Call
6552 pragma Assert
(Present
(Id
));
6557 "verification of " & Pred
& " of " & Id_Kind
& " & during "
6561 Info_Msg
=> Info_Msg
,
6562 In_SPARK
=> In_SPARK
);
6563 end Info_Verification_Call
;
6565 -- Start of processing for Info_Call
6568 -- Do not output anything for targets defined in internal units
6569 -- because this creates noise.
6571 if not In_Internal_Unit
(Subp_Id
) then
6573 -- Accept alternative
6575 if Is_Accept_Alternative_Proc
(Subp_Id
) then
6576 Info_Accept_Alternative
;
6580 elsif Is_TSS
(Subp_Id
, TSS_Deep_Adjust
) then
6581 Info_Type_Actions
("adjustment");
6583 -- Default_Initial_Condition
6585 elsif Is_Default_Initial_Condition_Proc
(Subp_Id
) then
6586 Info_Verification_Call
6587 (Pred
=> "Default_Initial_Condition",
6588 Id
=> First_Formal_Type
(Subp_Id
),
6593 elsif Is_Protected_Entry
(Subp_Id
) then
6596 -- Task entry calls are never processed because the entry being
6597 -- invoked does not have a corresponding "body", it has a select.
6599 elsif Is_Task_Entry
(Subp_Id
) then
6604 elsif Is_TSS
(Subp_Id
, TSS_Deep_Finalize
) then
6605 Info_Type_Actions
("finalization");
6607 -- Calls to _Finalizer procedures must not appear in the output
6608 -- because this creates confusing noise.
6610 elsif Is_Finalizer_Proc
(Subp_Id
) then
6613 -- Initial_Condition
6615 elsif Is_Initial_Condition_Proc
(Subp_Id
) then
6616 Info_Verification_Call
6617 (Pred
=> "Initial_Condition",
6618 Id
=> Find_Enclosing_Scope
(Call
),
6619 Id_Kind
=> "package");
6623 elsif Is_Init_Proc
(Subp_Id
)
6624 or else Is_TSS
(Subp_Id
, TSS_Deep_Initialize
)
6626 Info_Type_Actions
("initialization");
6630 elsif Is_Invariant_Proc
(Subp_Id
) then
6631 Info_Verification_Call
6632 (Pred
=> "invariants",
6633 Id
=> First_Formal_Type
(Subp_Id
),
6636 -- Partial invariant calls must not appear in the output because
6637 -- this creates confusing noise.
6639 elsif Is_Partial_Invariant_Proc
(Subp_Id
) then
6642 -- Subprograms must come last because some of the previous cases
6643 -- fall under this category.
6645 elsif Ekind
(Subp_Id
) = E_Function
then
6648 elsif Ekind
(Subp_Id
) = E_Procedure
then
6652 pragma Assert
(False);
6658 ------------------------
6659 -- Info_Instantiation --
6660 ------------------------
6662 procedure Info_Instantiation
6670 (Msg
=> "instantiation of & during elaboration",
6673 Info_Msg
=> Info_Msg
,
6674 In_SPARK
=> In_SPARK
);
6675 end Info_Instantiation
;
6677 -----------------------------
6678 -- Info_Variable_Reference --
6679 -----------------------------
6681 procedure Info_Variable_Reference
6686 if Is_Read
(Ref
) then
6688 (Msg
=> "read of variable & during elaboration",
6694 end Info_Variable_Reference
;
6697 ---------------------------------
6698 -- Early_Call_Region_Processor --
6699 ---------------------------------
6701 package body Early_Call_Region_Processor
is
6703 ---------------------
6704 -- Data structures --
6705 ---------------------
6707 -- The following map relates early call regions to subprogram bodies
6709 procedure Destroy
(N
: in out Node_Id
);
6712 package ECR_Map
is new Dynamic_Hash_Tables
6713 (Key_Type
=> Entity_Id
,
6714 Value_Type
=> Node_Id
,
6716 Expansion_Threshold
=> 1.5,
6717 Expansion_Factor
=> 2,
6718 Compression_Threshold
=> 0.3,
6719 Compression_Factor
=> 2,
6721 Destroy_Value
=> Destroy
,
6724 Early_Call_Regions_Map
: ECR_Map
.Dynamic_Hash_Table
:= ECR_Map
.Nil
;
6726 -----------------------
6727 -- Local subprograms --
6728 -----------------------
6730 function Early_Call_Region
(Body_Id
: Entity_Id
) return Node_Id
;
6731 pragma Inline
(Early_Call_Region
);
6732 -- Obtain the early call region associated with entry or subprogram body
6735 procedure Set_Early_Call_Region
(Body_Id
: Entity_Id
; Start
: Node_Id
);
6736 pragma Inline
(Set_Early_Call_Region
);
6737 -- Associate an early call region with begins at construct Start with
6738 -- entry or subprogram body Body_Id.
6744 procedure Destroy
(N
: in out Node_Id
) is
6745 pragma Unreferenced
(N
);
6750 -----------------------
6751 -- Early_Call_Region --
6752 -----------------------
6754 function Early_Call_Region
(Body_Id
: Entity_Id
) return Node_Id
is
6755 pragma Assert
(Present
(Body_Id
));
6757 return ECR_Map
.Get
(Early_Call_Regions_Map
, Body_Id
);
6758 end Early_Call_Region
;
6760 ------------------------------------------
6761 -- Finalize_Early_Call_Region_Processor --
6762 ------------------------------------------
6764 procedure Finalize_Early_Call_Region_Processor
is
6766 ECR_Map
.Destroy
(Early_Call_Regions_Map
);
6767 end Finalize_Early_Call_Region_Processor
;
6769 ----------------------------
6770 -- Find_Early_Call_Region --
6771 ----------------------------
6773 function Find_Early_Call_Region
6774 (Body_Decl
: Node_Id
;
6775 Assume_Elab_Body
: Boolean := False;
6776 Skip_Memoization
: Boolean := False) return Node_Id
6778 -- NOTE: The routines within Find_Early_Call_Region are intentionally
6779 -- unnested to avoid deep indentation of code.
6781 ECR_Found
: exception;
6782 -- This exception is raised when the early call region has been found
6784 Start
: Node_Id
:= Empty
;
6785 -- The start of the early call region. This variable is updated by
6786 -- the various nested routines. Due to the use of exceptions, the
6787 -- variable must be global to the nested routines.
6789 -- The algorithm implemented in this routine attempts to find the
6790 -- early call region of a subprogram body by inspecting constructs
6791 -- in reverse declarative order, while navigating the tree. The
6792 -- algorithm consists of an Inspection phase and Advancement phase.
6793 -- The pseudocode is as follows:
6797 -- advancement phase
6800 -- The infinite loop is terminated by raising exception ECR_Found.
6801 -- The algorithm utilizes two pointers, Curr and Start, to represent
6802 -- the current construct to inspect and the start of the early call
6805 -- IMPORTANT: The algorithm must maintain the following invariant at
6806 -- all time for it to function properly:
6808 -- A nested construct is entered only when it contains suitable
6811 -- This guarantees that leaving a nested or encapsulating construct
6812 -- functions properly.
6814 -- The Inspection phase determines whether the current construct is
6815 -- non-preelaborable, and if it is, the algorithm terminates.
6817 -- The Advancement phase walks the tree in reverse declarative order,
6818 -- while entering and leaving nested and encapsulating constructs. It
6819 -- may also terminate the elaborithm. There are several special cases
6826 -- <construct N-1> <- Curr
6827 -- <construct N> <- Start
6828 -- <subprogram body>
6830 -- In the general case, a declarative or statement list is traversed
6831 -- in reverse order where Curr is the lead pointer, and Start is the
6832 -- last preelaborable construct.
6834 -- 2) Entering handled bodies
6836 -- package body Nested is <- Curr (2.3)
6837 -- <declarations> <- Curr (2.2)
6839 -- <statements> <- Curr (2.1)
6841 -- <construct> <- Start
6843 -- In this case, the algorithm enters a handled body by starting from
6844 -- the last statement (2.1), or the last declaration (2.2), or the
6845 -- body is consumed (2.3) because it is empty and thus preelaborable.
6847 -- 3) Entering package declarations
6849 -- package Nested is <- Curr (2.3)
6850 -- <visible declarations> <- Curr (2.2)
6852 -- <private declarations> <- Curr (2.1)
6854 -- <construct> <- Start
6856 -- In this case, the algorithm enters a package declaration by
6857 -- starting from the last private declaration (2.1), the last visible
6858 -- declaration (2.2), or the package is consumed (2.3) because it is
6859 -- empty and thus preelaborable.
6861 -- 4) Transitioning from list to list of the same construct
6863 -- Certain constructs have two eligible lists. The algorithm must
6864 -- thus transition from the second to the first list when the second
6865 -- list is exhausted.
6867 -- declare <- Curr (4.2)
6868 -- <declarations> <- Curr (4.1)
6870 -- <statements> <- Start
6873 -- In this case, the algorithm has exhausted the second list (the
6874 -- statements in the example above), and continues with the last
6875 -- declaration (4.1) or the construct is consumed (4.2) because it
6876 -- contains only preelaborable code.
6878 -- 5) Transitioning from list to construct
6880 -- tack body Task is <- Curr (5.1)
6882 -- <construct 1> <- Start
6884 -- In this case, the algorithm has exhausted a list, Curr is Empty,
6885 -- and the owner of the list is consumed (5.1).
6887 -- 6) Transitioning from unit to unit
6889 -- A package body with a spec subject to pragma Elaborate_Body
6890 -- extends the possible range of the early call region to the package
6893 -- package Pack is <- Curr (6.3)
6894 -- pragma Elaborate_Body; <- Curr (6.2)
6895 -- <visible declarations> <- Curr (6.2)
6897 -- <private declarations> <- Curr (6.1)
6900 -- package body Pack is <- Curr, Start
6902 -- In this case, the algorithm has reached a package body compilation
6903 -- unit whose spec is subject to pragma Elaborate_Body, or the caller
6904 -- of the algorithm has specified this behavior. This transition is
6905 -- equivalent to 3).
6907 -- 7) Transitioning from unit to termination
6909 -- Reaching a compilation unit always terminates the algorithm as
6910 -- there are no more lists to examine. This must take case 6) into
6913 -- 8) Transitioning from subunit to stub
6915 -- package body Pack is separate; <- Curr (8.1)
6918 -- package body Pack is <- Curr, Start
6920 -- Reaching a subunit continues the search from the corresponding
6923 procedure Advance
(Curr
: in out Node_Id
);
6924 pragma Inline
(Advance
);
6925 -- Update the Curr and Start pointers depending on their location
6926 -- in the tree to the next eligible construct. This routine raises
6929 procedure Enter_Handled_Body
(Curr
: in out Node_Id
);
6930 pragma Inline
(Enter_Handled_Body
);
6931 -- Update the Curr and Start pointers to enter a nested handled body
6932 -- if applicable. This routine raises ECR_Found.
6934 procedure Enter_Package_Declaration
(Curr
: in out Node_Id
);
6935 pragma Inline
(Enter_Package_Declaration
);
6936 -- Update the Curr and Start pointers to enter a nested package spec
6937 -- if applicable. This routine raises ECR_Found.
6939 function Find_ECR
(N
: Node_Id
) return Node_Id
;
6940 pragma Inline
(Find_ECR
);
6941 -- Find an early call region starting from arbitrary node N
6943 function Has_Suitable_Construct
(List
: List_Id
) return Boolean;
6944 pragma Inline
(Has_Suitable_Construct
);
6945 -- Determine whether list List contains a suitable construct for
6946 -- inclusion into an early call region.
6948 procedure Include
(N
: Node_Id
; Curr
: out Node_Id
);
6949 pragma Inline
(Include
);
6950 -- Update the Curr and Start pointers to include arbitrary construct
6951 -- N in the early call region. This routine raises ECR_Found.
6953 function Is_OK_Preelaborable_Construct
(N
: Node_Id
) return Boolean;
6954 pragma Inline
(Is_OK_Preelaborable_Construct
);
6955 -- Determine whether arbitrary node N denotes a preelaboration-safe
6958 function Is_Suitable_Construct
(N
: Node_Id
) return Boolean;
6959 pragma Inline
(Is_Suitable_Construct
);
6960 -- Determine whether arbitrary node N denotes a suitable construct
6961 -- for inclusion into the early call region.
6963 function Previous_Suitable_Construct
(N
: Node_Id
) return Node_Id
;
6964 pragma Inline
(Previous_Suitable_Construct
);
6965 -- Return the previous node suitable for inclusion into the early
6968 procedure Transition_Body_Declarations
6970 Curr
: out Node_Id
);
6971 pragma Inline
(Transition_Body_Declarations
);
6972 -- Update the Curr and Start pointers when construct Bod denotes a
6973 -- block statement or a suitable body. This routine raises ECR_Found.
6975 procedure Transition_Handled_Statements
6977 Curr
: out Node_Id
);
6978 pragma Inline
(Transition_Handled_Statements
);
6979 -- Update the Curr and Start pointers when node HSS denotes a handled
6980 -- sequence of statements. This routine raises ECR_Found.
6982 procedure Transition_Spec_Declarations
6984 Curr
: out Node_Id
);
6985 pragma Inline
(Transition_Spec_Declarations
);
6986 -- Update the Curr and Start pointers when construct Spec denotes
6987 -- a concurrent definition or a package spec. This routine raises
6990 procedure Transition_Unit
(Unit
: Node_Id
; Curr
: out Node_Id
);
6991 pragma Inline
(Transition_Unit
);
6992 -- Update the Curr and Start pointers when node Unit denotes a
6993 -- potential compilation unit. This routine raises ECR_Found.
6999 procedure Advance
(Curr
: in out Node_Id
) is
7003 -- Curr denotes one of the following cases upon entry into this
7006 -- * Empty - There is no current construct when a declarative or
7007 -- a statement list has been exhausted. This does not indicate
7008 -- that the early call region has been computed as it is still
7009 -- possible to transition to another list.
7011 -- * Encapsulator - The current construct wraps declarations
7012 -- and/or statements. This indicates that the early call
7013 -- region may extend within the nested construct.
7015 -- * Preelaborable - The current construct is preelaborable
7016 -- because Find_ECR would not invoke Advance if this was not
7019 -- The current construct is an encapsulator or is preelaborable
7021 if Present
(Curr
) then
7023 -- Enter encapsulators by inspecting their declarations and/or
7026 if Nkind
(Curr
) in N_Block_Statement | N_Package_Body
then
7027 Enter_Handled_Body
(Curr
);
7029 elsif Nkind
(Curr
) = N_Package_Declaration
then
7030 Enter_Package_Declaration
(Curr
);
7032 -- Early call regions have a property which can be exploited to
7033 -- optimize the algorithm.
7035 -- <preceding subprogram body>
7036 -- <preelaborable construct 1>
7038 -- <preelaborable construct N>
7039 -- <initiating subprogram body>
7041 -- If a traversal initiated from a subprogram body reaches a
7042 -- preceding subprogram body, then both bodies share the same
7043 -- early call region.
7045 -- The property results in the following desirable effects:
7047 -- * If the preceding body already has an early call region,
7048 -- then the initiating body can reuse it. This minimizes the
7049 -- amount of processing performed by the algorithm.
7051 -- * If the preceding body lack an early call region, then the
7052 -- algorithm can compute the early call region, and reuse it
7053 -- for the initiating body. This processing performs the same
7054 -- amount of work, but has the beneficial effect of computing
7055 -- the early call regions of all preceding bodies.
7057 elsif Nkind
(Curr
) in N_Entry_Body | N_Subprogram_Body
then
7059 Find_Early_Call_Region
7061 Assume_Elab_Body
=> Assume_Elab_Body
,
7062 Skip_Memoization
=> Skip_Memoization
);
7066 -- Otherwise current construct is preelaborable. Unpdate the
7067 -- early call region to include it.
7070 Include
(Curr
, Curr
);
7073 -- Otherwise the current construct is missing, indicating that the
7074 -- current list has been exhausted. Depending on the context of
7075 -- the list, several transitions are possible.
7078 -- The invariant of the algorithm ensures that Curr and Start
7079 -- are at the same level of nesting at the point of transition.
7080 -- The algorithm can determine which list the traversal came
7081 -- from by examining Start.
7083 Context
:= Parent
(Start
);
7085 -- Attempt the following transitions:
7087 -- private declarations -> visible declarations
7088 -- private declarations -> upper level
7089 -- private declarations -> terminate
7090 -- visible declarations -> upper level
7091 -- visible declarations -> terminate
7093 if Nkind
(Context
) in N_Package_Specification
7094 | N_Protected_Definition
7097 Transition_Spec_Declarations
(Context
, Curr
);
7099 -- Attempt the following transitions:
7101 -- statements -> declarations
7102 -- statements -> upper level
7103 -- statements -> corresponding package spec (Elab_Body)
7104 -- statements -> terminate
7106 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
7107 Transition_Handled_Statements
(Context
, Curr
);
7109 -- Attempt the following transitions:
7111 -- declarations -> upper level
7112 -- declarations -> corresponding package spec (Elab_Body)
7113 -- declarations -> terminate
7115 elsif Nkind
(Context
) in N_Block_Statement
7122 Transition_Body_Declarations
(Context
, Curr
);
7124 -- Otherwise it is not possible to transition. Stop the search
7125 -- because there are no more declarations or statements to
7134 --------------------------
7135 -- Enter_Handled_Body --
7136 --------------------------
7138 procedure Enter_Handled_Body
(Curr
: in out Node_Id
) is
7139 Decls
: constant List_Id
:= Declarations
(Curr
);
7140 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Curr
);
7141 Stmts
: List_Id
:= No_List
;
7144 if Present
(HSS
) then
7145 Stmts
:= Statements
(HSS
);
7148 -- The handled body has a non-empty statement sequence. The
7149 -- construct to inspect is the last statement.
7151 if Has_Suitable_Construct
(Stmts
) then
7152 Curr
:= Last
(Stmts
);
7154 -- The handled body lacks statements, but has non-empty
7155 -- declarations. The construct to inspect is the last declaration.
7157 elsif Has_Suitable_Construct
(Decls
) then
7158 Curr
:= Last
(Decls
);
7160 -- Otherwise the handled body lacks both declarations and
7161 -- statements. The construct to inspect is the node which precedes
7162 -- the handled body. Update the early call region to include the
7166 Include
(Curr
, Curr
);
7168 end Enter_Handled_Body
;
7170 -------------------------------
7171 -- Enter_Package_Declaration --
7172 -------------------------------
7174 procedure Enter_Package_Declaration
(Curr
: in out Node_Id
) is
7175 Pack_Spec
: constant Node_Id
:= Specification
(Curr
);
7176 Prv_Decls
: constant List_Id
:= Private_Declarations
(Pack_Spec
);
7177 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Pack_Spec
);
7180 -- The package has a non-empty private declarations. The construct
7181 -- to inspect is the last private declaration.
7183 if Has_Suitable_Construct
(Prv_Decls
) then
7184 Curr
:= Last
(Prv_Decls
);
7186 -- The package lacks private declarations, but has non-empty
7187 -- visible declarations. In this case the construct to inspect
7188 -- is the last visible declaration.
7190 elsif Has_Suitable_Construct
(Vis_Decls
) then
7191 Curr
:= Last
(Vis_Decls
);
7193 -- Otherwise the package lacks any declarations. The construct
7194 -- to inspect is the node which precedes the package. Update the
7195 -- early call region to include the package declaration.
7198 Include
(Curr
, Curr
);
7200 end Enter_Package_Declaration
;
7206 function Find_ECR
(N
: Node_Id
) return Node_Id
is
7210 -- The early call region starts at N
7212 Curr
:= Previous_Suitable_Construct
(N
);
7215 -- Inspect each node in reverse declarative order while going in
7216 -- and out of nested and enclosing constructs. Note that the only
7217 -- way to terminate this infinite loop is to raise ECR_Found.
7220 -- The current construct is not preelaboration-safe. Terminate
7224 and then not Is_OK_Preelaborable_Construct
(Curr
)
7229 -- Advance to the next suitable construct. This may terminate
7230 -- the traversal by raising ECR_Found.
7240 ----------------------------
7241 -- Has_Suitable_Construct --
7242 ----------------------------
7244 function Has_Suitable_Construct
(List
: List_Id
) return Boolean is
7248 -- Examine the list in reverse declarative order, looking for a
7249 -- suitable construct.
7251 if Present
(List
) then
7252 Item
:= Last
(List
);
7253 while Present
(Item
) loop
7254 if Is_Suitable_Construct
(Item
) then
7263 end Has_Suitable_Construct
;
7269 procedure Include
(N
: Node_Id
; Curr
: out Node_Id
) is
7273 -- The input node is a compilation unit. This terminates the
7274 -- search because there are no more lists to inspect and there are
7275 -- no more enclosing constructs to climb up to. The transitions
7278 -- private declarations -> terminate
7279 -- visible declarations -> terminate
7280 -- statements -> terminate
7281 -- declarations -> terminate
7283 if Nkind
(Parent
(Start
)) = N_Compilation_Unit
then
7286 -- Otherwise the input node is still within some list
7289 Curr
:= Previous_Suitable_Construct
(Start
);
7293 -----------------------------------
7294 -- Is_OK_Preelaborable_Construct --
7295 -----------------------------------
7297 function Is_OK_Preelaborable_Construct
(N
: Node_Id
) return Boolean is
7299 -- Assignment statements are acceptable as long as they were
7300 -- produced by the ABE mechanism to update elaboration flags.
7302 if Nkind
(N
) = N_Assignment_Statement
then
7303 return Is_Elaboration_Code
(N
);
7305 -- Block statements are acceptable even though they directly
7306 -- violate preelaborability. The intention is not to penalize
7307 -- the early call region when a block contains only preelaborable
7311 -- Val : constant Integer := 1;
7313 -- pragma Assert (Val = 1);
7317 -- Note that the Advancement phase does enter blocks, and will
7318 -- detect any non-preelaborable declarations or statements within.
7320 elsif Nkind
(N
) = N_Block_Statement
then
7324 -- Otherwise the construct must be preelaborable. The check must
7325 -- take the syntactic and semantic structure of the construct. DO
7326 -- NOT use Is_Preelaborable_Construct here.
7328 return not Is_Non_Preelaborable_Construct
(N
);
7329 end Is_OK_Preelaborable_Construct
;
7331 ---------------------------
7332 -- Is_Suitable_Construct --
7333 ---------------------------
7335 function Is_Suitable_Construct
(N
: Node_Id
) return Boolean is
7336 Context
: constant Node_Id
:= Parent
(N
);
7339 -- An internally-generated statement sequence which contains only
7340 -- a single null statement is not a suitable construct because it
7341 -- is a byproduct of the parser. Such a null statement should be
7342 -- excluded from the early call region because it carries the
7343 -- source location of the "end" keyword, and may lead to confusing
7346 if Nkind
(N
) = N_Null_Statement
7347 and then not Comes_From_Source
(N
)
7348 and then Present
(Context
)
7349 and then Nkind
(Context
) = N_Handled_Sequence_Of_Statements
7353 -- Similarly, internally-generated objects and types may have
7354 -- out-of-order source locations that confuse diagnostics, e.g.
7355 -- source locations in the body for objects/types generated in
7358 elsif Nkind
(N
) in N_Full_Type_Declaration | N_Object_Declaration
7359 and then not Comes_From_Source
(N
)
7364 -- Otherwise only constructs which correspond to pure Ada
7365 -- constructs are considered suitable.
7370 | N_Freeze_Generic_Entity
7371 | N_Implicit_Label_Declaration
7373 | N_Pop_Constraint_Error_Label
7374 | N_Pop_Program_Error_Label
7375 | N_Pop_Storage_Error_Label
7376 | N_Push_Constraint_Error_Label
7377 | N_Push_Program_Error_Label
7378 | N_Push_Storage_Error_Label
7379 | N_SCIL_Dispatch_Table_Tag_Init
7380 | N_SCIL_Dispatching_Call
7381 | N_SCIL_Membership_Test
7382 | N_Variable_Reference_Marker
7389 end Is_Suitable_Construct
;
7391 ---------------------------------
7392 -- Previous_Suitable_Construct --
7393 ---------------------------------
7395 function Previous_Suitable_Construct
(N
: Node_Id
) return Node_Id
is
7401 while Present
(P
) and then not Is_Suitable_Construct
(P
) loop
7406 end Previous_Suitable_Construct
;
7408 ----------------------------------
7409 -- Transition_Body_Declarations --
7410 ----------------------------------
7412 procedure Transition_Body_Declarations
7416 Decls
: constant List_Id
:= Declarations
(Bod
);
7419 -- The search must come from the declarations of the body
7422 (Is_Non_Empty_List
(Decls
)
7423 and then List_Containing
(Start
) = Decls
);
7425 -- The search finished inspecting the declarations. The construct
7426 -- to inspect is the node which precedes the handled body, unless
7427 -- the body is a compilation unit. The transitions are:
7429 -- declarations -> upper level
7430 -- declarations -> corresponding package spec (Elab_Body)
7431 -- declarations -> terminate
7433 Transition_Unit
(Bod
, Curr
);
7434 end Transition_Body_Declarations
;
7436 -----------------------------------
7437 -- Transition_Handled_Statements --
7438 -----------------------------------
7440 procedure Transition_Handled_Statements
7444 Bod
: constant Node_Id
:= Parent
(HSS
);
7445 Decls
: constant List_Id
:= Declarations
(Bod
);
7446 Stmts
: constant List_Id
:= Statements
(HSS
);
7449 -- The search must come from the statements of certain bodies or
7461 -- The search must come from the statements of the handled
7465 (Is_Non_Empty_List
(Stmts
)
7466 and then List_Containing
(Start
) = Stmts
);
7468 -- The search finished inspecting the statements. The handled body
7469 -- has non-empty declarations. The construct to inspect is the
7470 -- last declaration. The transitions are:
7472 -- statements -> declarations
7474 if Has_Suitable_Construct
(Decls
) then
7475 Curr
:= Last
(Decls
);
7477 -- Otherwise the handled body lacks declarations. The construct to
7478 -- inspect is the node which precedes the handled body, unless the
7479 -- body is a compilation unit. The transitions are:
7481 -- statements -> upper level
7482 -- statements -> corresponding package spec (Elab_Body)
7483 -- statements -> terminate
7486 Transition_Unit
(Bod
, Curr
);
7488 end Transition_Handled_Statements
;
7490 ----------------------------------
7491 -- Transition_Spec_Declarations --
7492 ----------------------------------
7494 procedure Transition_Spec_Declarations
7498 Prv_Decls
: constant List_Id
:= Private_Declarations
(Spec
);
7499 Vis_Decls
: constant List_Id
:= Visible_Declarations
(Spec
);
7502 pragma Assert
(Present
(Start
) and then Is_List_Member
(Start
));
7504 -- The search came from the private declarations and finished
7505 -- their inspection.
7507 if Has_Suitable_Construct
(Prv_Decls
)
7508 and then List_Containing
(Start
) = Prv_Decls
7510 -- The context has non-empty visible declarations. The node to
7511 -- inspect is the last visible declaration. The transitions
7514 -- private declarations -> visible declarations
7516 if Has_Suitable_Construct
(Vis_Decls
) then
7517 Curr
:= Last
(Vis_Decls
);
7519 -- Otherwise the context lacks visible declarations. The
7520 -- construct to inspect is the node which precedes the context
7521 -- unless the context is a compilation unit. The transitions
7524 -- private declarations -> upper level
7525 -- private declarations -> terminate
7528 Transition_Unit
(Parent
(Spec
), Curr
);
7531 -- The search came from the visible declarations and finished
7532 -- their inspections. The construct to inspect is the node which
7533 -- precedes the context, unless the context is a compilaton unit.
7534 -- The transitions are:
7536 -- visible declarations -> upper level
7537 -- visible declarations -> terminate
7539 elsif Has_Suitable_Construct
(Vis_Decls
)
7540 and then List_Containing
(Start
) = Vis_Decls
7542 Transition_Unit
(Parent
(Spec
), Curr
);
7544 -- At this point both declarative lists are empty, but the
7545 -- traversal still came from within the spec. This indicates
7546 -- that the invariant of the algorithm has been violated.
7549 pragma Assert
(False);
7552 end Transition_Spec_Declarations
;
7554 ---------------------
7555 -- Transition_Unit --
7556 ---------------------
7558 procedure Transition_Unit
7562 Context
: constant Node_Id
:= Parent
(Unit
);
7565 -- The unit is a compilation unit. This terminates the search
7566 -- because there are no more lists to inspect and there are no
7567 -- more enclosing constructs to climb up to.
7569 if Nkind
(Context
) = N_Compilation_Unit
then
7571 -- A package body with a corresponding spec subject to pragma
7572 -- Elaborate_Body is an exception to the above. The annotation
7573 -- allows the search to continue into the package declaration.
7574 -- The transitions are:
7576 -- statements -> corresponding package spec (Elab_Body)
7577 -- declarations -> corresponding package spec (Elab_Body)
7579 if Nkind
(Unit
) = N_Package_Body
7580 and then (Assume_Elab_Body
7581 or else Has_Pragma_Elaborate_Body
7582 (Corresponding_Spec
(Unit
)))
7584 Curr
:= Unit_Declaration_Node
(Corresponding_Spec
(Unit
));
7585 Enter_Package_Declaration
(Curr
);
7587 -- Otherwise terminate the search. The transitions are:
7589 -- private declarations -> terminate
7590 -- visible declarations -> terminate
7591 -- statements -> terminate
7592 -- declarations -> terminate
7598 -- The unit is a subunit. The construct to inspect is the node
7599 -- which precedes the corresponding stub. Update the early call
7600 -- region to include the unit.
7602 elsif Nkind
(Context
) = N_Subunit
then
7604 Curr
:= Corresponding_Stub
(Context
);
7606 -- Otherwise the unit is nested. The construct to inspect is the
7607 -- node which precedes the unit. Update the early call region to
7608 -- include the unit.
7611 Include
(Unit
, Curr
);
7613 end Transition_Unit
;
7617 Body_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Body_Decl
);
7620 -- Start of processing for Find_Early_Call_Region
7623 -- The caller demands the start of the early call region without
7624 -- saving or retrieving it to/from internal data structures.
7626 if Skip_Memoization
then
7627 Region
:= Find_ECR
(Body_Decl
);
7632 -- Check whether the early call region of the subprogram body is
7635 Region
:= Early_Call_Region
(Body_Id
);
7638 Region
:= Find_ECR
(Body_Decl
);
7640 -- Associate the early call region with the subprogram body in
7641 -- case other scenarios need it.
7643 Set_Early_Call_Region
(Body_Id
, Region
);
7647 -- A subprogram body must always have an early call region
7649 pragma Assert
(Present
(Region
));
7652 end Find_Early_Call_Region
;
7654 --------------------------------------------
7655 -- Initialize_Early_Call_Region_Processor --
7656 --------------------------------------------
7658 procedure Initialize_Early_Call_Region_Processor
is
7660 Early_Call_Regions_Map
:= ECR_Map
.Create
(100);
7661 end Initialize_Early_Call_Region_Processor
;
7663 ---------------------------
7664 -- Set_Early_Call_Region --
7665 ---------------------------
7667 procedure Set_Early_Call_Region
(Body_Id
: Entity_Id
; Start
: Node_Id
) is
7668 pragma Assert
(Present
(Body_Id
));
7669 pragma Assert
(Present
(Start
));
7672 ECR_Map
.Put
(Early_Call_Regions_Map
, Body_Id
, Start
);
7673 end Set_Early_Call_Region
;
7674 end Early_Call_Region_Processor
;
7676 ----------------------
7677 -- Elaborated_Units --
7678 ----------------------
7680 package body Elaborated_Units
is
7686 -- The following type idenfities the elaboration attributes of a unit
7688 type Elaboration_Attributes_Id
is new Natural;
7690 No_Elaboration_Attributes
: constant Elaboration_Attributes_Id
:=
7691 Elaboration_Attributes_Id
'First;
7692 First_Elaboration_Attributes
: constant Elaboration_Attributes_Id
:=
7693 No_Elaboration_Attributes
+ 1;
7695 -- The following type represents the elaboration attributes of a unit
7697 type Elaboration_Attributes_Record
is record
7698 Elab_Pragma
: Node_Id
:= Empty
;
7699 -- This attribute denotes a source Elaborate or Elaborate_All pragma
7700 -- which guarantees the prior elaboration of some unit with respect
7701 -- to the main unit. The pragma may come from the following contexts:
7704 -- * The spec of the main unit (if applicable)
7705 -- * Any parent spec of the main unit (if applicable)
7706 -- * Any parent subunit of the main unit (if applicable)
7708 -- The attribute remains Empty if no such pragma is available. Source
7709 -- pragmas play a role in satisfying SPARK elaboration requirements.
7711 With_Clause
: Node_Id
:= Empty
;
7712 -- This attribute denotes an internally-generated or a source with
7713 -- clause for some unit withed by the main unit. With clauses carry
7714 -- flags which represent implicit Elaborate or Elaborate_All pragmas.
7715 -- These clauses play a role in supplying elaboration dependencies to
7719 ---------------------
7720 -- Data structures --
7721 ---------------------
7723 -- The following table stores all elaboration attributes
7725 package Elaboration_Attributes
is new Table
.Table
7726 (Table_Index_Type
=> Elaboration_Attributes_Id
,
7727 Table_Component_Type
=> Elaboration_Attributes_Record
,
7728 Table_Low_Bound
=> First_Elaboration_Attributes
,
7729 Table_Initial
=> 250,
7730 Table_Increment
=> 200,
7731 Table_Name
=> "Elaboration_Attributes");
7733 procedure Destroy
(EA_Id
: in out Elaboration_Attributes_Id
);
7734 -- Destroy elaboration attributes EA_Id
7736 package UA_Map
is new Dynamic_Hash_Tables
7737 (Key_Type
=> Entity_Id
,
7738 Value_Type
=> Elaboration_Attributes_Id
,
7739 No_Value
=> No_Elaboration_Attributes
,
7740 Expansion_Threshold
=> 1.5,
7741 Expansion_Factor
=> 2,
7742 Compression_Threshold
=> 0.3,
7743 Compression_Factor
=> 2,
7745 Destroy_Value
=> Destroy
,
7748 -- The following map relates an elaboration attributes of a unit to the
7751 Unit_To_Attributes_Map
: UA_Map
.Dynamic_Hash_Table
:= UA_Map
.Nil
;
7757 function Elaboration_Attributes_Of
7758 (Unit_Id
: Entity_Id
) return Elaboration_Attributes_Id
;
7759 pragma Inline
(Elaboration_Attributes_Of
);
7760 -- Obtain the elaboration attributes of unit Unit_Id
7762 -----------------------
7763 -- Local subprograms --
7764 -----------------------
7766 function Elab_Pragma
(EA_Id
: Elaboration_Attributes_Id
) return Node_Id
;
7767 pragma Inline
(Elab_Pragma
);
7768 -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id
7770 procedure Ensure_Prior_Elaboration_Dynamic
7772 Unit_Id
: Entity_Id
;
7774 In_State
: Processing_In_State
);
7775 pragma Inline
(Ensure_Prior_Elaboration_Dynamic
);
7776 -- Guarantee the elaboration of unit Unit_Id with respect to the main
7777 -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N
7778 -- denotes the related scenario. In_State is the current state of the
7779 -- Processing phase.
7781 procedure Ensure_Prior_Elaboration_Static
7783 Unit_Id
: Entity_Id
;
7785 In_State
: Processing_In_State
);
7786 pragma Inline
(Ensure_Prior_Elaboration_Static
);
7787 -- Guarantee the elaboration of unit Unit_Id with respect to the main
7788 -- unit by installing an implicit Elaborate[_All] pragma with name
7789 -- Prag_Nam. N denotes the related scenario. In_State is the current
7790 -- state of the Processing phase.
7792 function Present
(EA_Id
: Elaboration_Attributes_Id
) return Boolean;
7793 pragma Inline
(Present
);
7794 -- Determine whether elaboration attributes UA_Id exist
7796 procedure Set_Elab_Pragma
7797 (EA_Id
: Elaboration_Attributes_Id
;
7799 pragma Inline
(Set_Elab_Pragma
);
7800 -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to
7803 procedure Set_With_Clause
7804 (EA_Id
: Elaboration_Attributes_Id
;
7806 pragma Inline
(Set_With_Clause
);
7807 -- Set the with clause of elaboration attributes EA_Id to Clause
7809 function With_Clause
(EA_Id
: Elaboration_Attributes_Id
) return Node_Id
;
7810 pragma Inline
(With_Clause
);
7811 -- Obtain the implicit or source with clause of elaboration attributes
7814 ------------------------------
7815 -- Collect_Elaborated_Units --
7816 ------------------------------
7818 procedure Collect_Elaborated_Units
is
7819 procedure Add_Pragma
(Prag
: Node_Id
);
7820 pragma Inline
(Add_Pragma
);
7821 -- Determine whether pragma Prag denotes a legal Elaborate[_All]
7822 -- pragma. If this is the case, add the related unit to the context.
7823 -- For pragma Elaborate_All, include recursively all units withed by
7824 -- the related unit.
7827 (Unit_Id
: Entity_Id
;
7829 Full_Context
: Boolean);
7830 pragma Inline
(Add_Unit
);
7831 -- Add unit Unit_Id to the elaboration context. Prag denotes the
7832 -- pragma which prompted the inclusion of the unit to the context.
7833 -- If flag Full_Context is set, examine the nonlimited clauses of
7834 -- unit Unit_Id and add each withed unit to the context.
7836 procedure Find_Elaboration_Context
(Comp_Unit
: Node_Id
);
7837 pragma Inline
(Find_Elaboration_Context
);
7838 -- Examine the context items of compilation unit Comp_Unit for
7839 -- suitable elaboration-related pragmas and add all related units
7846 procedure Add_Pragma
(Prag
: Node_Id
) is
7847 Prag_Args
: constant List_Id
:=
7848 Pragma_Argument_Associations
(Prag
);
7849 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
7853 -- Nothing to do if the pragma is not related to elaboration
7855 if Prag_Nam
not in Name_Elaborate | Name_Elaborate_All
then
7858 -- Nothing to do when the pragma is illegal
7860 elsif Error_Posted
(Prag
) then
7864 Unit_Arg
:= Get_Pragma_Arg
(First
(Prag_Args
));
7866 -- The argument of the pragma may appear in package.package form
7868 if Nkind
(Unit_Arg
) = N_Selected_Component
then
7869 Unit_Arg
:= Selector_Name
(Unit_Arg
);
7873 (Unit_Id
=> Entity
(Unit_Arg
),
7875 Full_Context
=> Prag_Nam
= Name_Elaborate_All
);
7883 (Unit_Id
: Entity_Id
;
7885 Full_Context
: Boolean)
7888 EA_Id
: Elaboration_Attributes_Id
;
7889 Unit_Prag
: Node_Id
;
7892 -- Nothing to do when some previous error left a with clause or a
7893 -- pragma in a bad state.
7895 if No
(Unit_Id
) then
7899 EA_Id
:= Elaboration_Attributes_Of
(Unit_Id
);
7900 Unit_Prag
:= Elab_Pragma
(EA_Id
);
7902 -- The unit is already included in the context by means of pragma
7905 if Present
(Unit_Prag
) then
7907 -- Upgrade an existing pragma Elaborate when the unit is
7908 -- subject to Elaborate_All because the new pragma covers a
7909 -- larger set of units.
7911 if Pragma_Name
(Unit_Prag
) = Name_Elaborate
7912 and then Pragma_Name
(Prag
) = Name_Elaborate_All
7914 Set_Elab_Pragma
(EA_Id
, Prag
);
7916 -- Otherwise the unit retains its existing pragma and does not
7917 -- need to be included in the context again.
7923 -- Otherwise the current unit is not included in the context
7926 Set_Elab_Pragma
(EA_Id
, Prag
);
7929 -- Includes all units withed by the current one when computing the
7932 if Full_Context
then
7934 -- Process all nonlimited with clauses found in the context of
7935 -- the current unit. Note that limited clauses do not impose an
7936 -- elaboration order.
7938 Clause
:= First
(Context_Items
(Compilation_Unit
(Unit_Id
)));
7939 while Present
(Clause
) loop
7940 if Nkind
(Clause
) = N_With_Clause
7941 and then not Error_Posted
(Clause
)
7942 and then not Limited_Present
(Clause
)
7945 (Unit_Id
=> Entity
(Name
(Clause
)),
7947 Full_Context
=> Full_Context
);
7955 ------------------------------
7956 -- Find_Elaboration_Context --
7957 ------------------------------
7959 procedure Find_Elaboration_Context
(Comp_Unit
: Node_Id
) is
7960 pragma Assert
(Nkind
(Comp_Unit
) = N_Compilation_Unit
);
7965 -- Process all elaboration-related pragmas found in the context of
7966 -- the compilation unit.
7968 Prag
:= First
(Context_Items
(Comp_Unit
));
7969 while Present
(Prag
) loop
7970 if Nkind
(Prag
) = N_Pragma
then
7976 end Find_Elaboration_Context
;
7983 -- Start of processing for Collect_Elaborated_Units
7986 -- Perform a traversal to examines the context of the main unit. The
7987 -- traversal performs the following jumps:
7989 -- subunit -> parent subunit
7990 -- parent subunit -> body
7992 -- spec -> parent spec
7993 -- parent spec -> grandparent spec and so on
7995 -- The traversal relies on units rather than scopes because the scope
7996 -- of a subunit is some spec, while this traversal must process the
7997 -- body as well. Given that protected and task bodies can also be
7998 -- subunits, this complicates the scope approach even further.
8000 Unit_Id
:= Unit
(Cunit
(Main_Unit
));
8002 -- Perform the following traversals when the main unit is a subunit
8004 -- subunit -> parent subunit
8005 -- parent subunit -> body
8007 while Present
(Unit_Id
) and then Nkind
(Unit_Id
) = N_Subunit
loop
8008 Find_Elaboration_Context
(Parent
(Unit_Id
));
8010 -- Continue the traversal by going to the unit which contains the
8011 -- corresponding stub.
8013 if Present
(Corresponding_Stub
(Unit_Id
)) then
8015 Unit
(Cunit
(Get_Source_Unit
(Corresponding_Stub
(Unit_Id
))));
8017 -- Otherwise the subunit may be erroneous or left in a bad state
8024 -- Perform the following traversal now that subunits have been taken
8025 -- care of, or the main unit is a body.
8029 if Present
(Unit_Id
)
8030 and then Nkind
(Unit_Id
) in N_Package_Body | N_Subprogram_Body
8032 Find_Elaboration_Context
(Parent
(Unit_Id
));
8034 -- Continue the traversal by going to the unit which contains the
8035 -- corresponding spec.
8037 if Present
(Corresponding_Spec
(Unit_Id
)) then
8039 Unit
(Cunit
(Get_Source_Unit
(Corresponding_Spec
(Unit_Id
))));
8043 -- Perform the following traversals now that the body has been taken
8044 -- care of, or the main unit is a spec.
8046 -- spec -> parent spec
8047 -- parent spec -> grandparent spec and so on
8049 if Present
(Unit_Id
)
8050 and then Nkind
(Unit_Id
) in N_Generic_Package_Declaration
8051 | N_Generic_Subprogram_Declaration
8052 | N_Package_Declaration
8053 | N_Subprogram_Declaration
8055 Find_Elaboration_Context
(Parent
(Unit_Id
));
8057 -- Process a potential chain of parent units which ends with the
8058 -- main unit spec. The traversal can now safely rely on the scope
8061 Par_Id
:= Scope
(Defining_Entity
(Unit_Id
));
8062 while Present
(Par_Id
) and then Par_Id
/= Standard_Standard
loop
8063 Find_Elaboration_Context
(Compilation_Unit
(Par_Id
));
8065 Par_Id
:= Scope
(Par_Id
);
8068 end Collect_Elaborated_Units
;
8074 procedure Destroy
(EA_Id
: in out Elaboration_Attributes_Id
) is
8075 pragma Unreferenced
(EA_Id
);
8084 function Elab_Pragma
8085 (EA_Id
: Elaboration_Attributes_Id
) return Node_Id
8087 pragma Assert
(Present
(EA_Id
));
8089 return Elaboration_Attributes
.Table
(EA_Id
).Elab_Pragma
;
8092 -------------------------------
8093 -- Elaboration_Attributes_Of --
8094 -------------------------------
8096 function Elaboration_Attributes_Of
8097 (Unit_Id
: Entity_Id
) return Elaboration_Attributes_Id
8099 EA_Id
: Elaboration_Attributes_Id
;
8102 EA_Id
:= UA_Map
.Get
(Unit_To_Attributes_Map
, Unit_Id
);
8104 -- The unit lacks elaboration attributes. This indicates that the
8105 -- unit is encountered for the first time. Create the elaboration
8106 -- attributes for it.
8108 if not Present
(EA_Id
) then
8109 Elaboration_Attributes
.Append
8110 ((Elab_Pragma
=> Empty
,
8111 With_Clause
=> Empty
));
8112 EA_Id
:= Elaboration_Attributes
.Last
;
8114 -- Associate the elaboration attributes with the unit
8116 UA_Map
.Put
(Unit_To_Attributes_Map
, Unit_Id
, EA_Id
);
8119 pragma Assert
(Present
(EA_Id
));
8122 end Elaboration_Attributes_Of
;
8124 ------------------------------
8125 -- Ensure_Prior_Elaboration --
8126 ------------------------------
8128 procedure Ensure_Prior_Elaboration
8130 Unit_Id
: Entity_Id
;
8132 In_State
: Processing_In_State
)
8134 pragma Assert
(Prag_Nam
in Name_Elaborate | Name_Elaborate_All
);
8137 -- Nothing to do when the need for prior elaboration came from a
8138 -- partial finalization routine which occurs in an initialization
8139 -- context. This behavior parallels that of the old ABE mechanism.
8141 if In_State
.Within_Partial_Finalization
then
8144 -- Nothing to do when the need for prior elaboration came from a task
8145 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on
8146 -- task bodies) is in effect.
8148 elsif Debug_Flag_Dot_Y
and then In_State
.Within_Task_Body
then
8151 -- Nothing to do when the unit is elaborated prior to the main unit.
8152 -- This check must also consider the following cases:
8154 -- * No check is made against the context of the main unit because
8155 -- this is specific to the elaboration model in effect and requires
8156 -- custom handling (see Ensure_xxx_Prior_Elaboration).
8158 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
8159 -- Elaborate[_All] MUST be generated even though Unit_Id is always
8160 -- elaborated prior to the main unit. This conservative strategy
8161 -- ensures that other units withed by Unit_Id will not lead to an
8164 -- package A is package body A is
8165 -- procedure ABE; procedure ABE is ... end ABE;
8169 -- package B is package body B is
8170 -- pragma Elaborate_Body; procedure Proc is
8172 -- procedure Proc; A.ABE;
8173 -- package B; end Proc;
8177 -- package C is package body C is
8183 -- In the example above, the elaboration of C invokes B.Proc. B is
8184 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All]
8185 -- is gnerated for B in C, then the following elaboratio order will
8188 -- spec of A elaborated
8189 -- spec of B elaborated
8190 -- body of B elaborated
8191 -- spec of C elaborated
8192 -- body of C elaborated <-- calls B.Proc which calls A.ABE
8193 -- body of A elaborated <-- problem
8195 -- The generation of an implicit pragma Elaborate_All (B) ensures
8196 -- that the elaboration-order mechanism will not pick the above
8199 -- An implicit Elaborate is NOT generated when the unit is subject
8200 -- to Elaborate_Body because both pragmas have the same effect.
8202 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All]
8203 -- MUST NOT be generated in this case because a unit cannot depend
8204 -- on its own elaboration. This case is therefore treated as valid
8205 -- prior elaboration.
8207 elsif Has_Prior_Elaboration
8208 (Unit_Id
=> Unit_Id
,
8209 Same_Unit_OK
=> True,
8210 Elab_Body_OK
=> Prag_Nam
= Name_Elaborate
)
8215 -- Suggest the use of pragma Prag_Nam when the dynamic model is in
8218 if Dynamic_Elaboration_Checks
then
8219 Ensure_Prior_Elaboration_Dynamic
8222 Prag_Nam
=> Prag_Nam
,
8223 In_State
=> In_State
);
8225 -- Install an implicit pragma Prag_Nam when the static model is in
8229 pragma Assert
(Static_Elaboration_Checks
);
8231 Ensure_Prior_Elaboration_Static
8234 Prag_Nam
=> Prag_Nam
,
8235 In_State
=> In_State
);
8237 end Ensure_Prior_Elaboration
;
8239 --------------------------------------
8240 -- Ensure_Prior_Elaboration_Dynamic --
8241 --------------------------------------
8243 procedure Ensure_Prior_Elaboration_Dynamic
8245 Unit_Id
: Entity_Id
;
8247 In_State
: Processing_In_State
)
8249 procedure Info_Missing_Pragma
;
8250 pragma Inline
(Info_Missing_Pragma
);
8251 -- Output information concerning missing Elaborate or Elaborate_All
8252 -- pragma with name Prag_Nam for scenario N, which would ensure the
8253 -- prior elaboration of Unit_Id.
8255 -------------------------
8256 -- Info_Missing_Pragma --
8257 -------------------------
8259 procedure Info_Missing_Pragma
is
8261 -- Internal units are ignored as they cause unnecessary noise
8263 if not In_Internal_Unit
(Unit_Id
) then
8265 -- The name of the unit subjected to the elaboration pragma is
8266 -- fully qualified to improve the clarity of the info message.
8268 Error_Msg_Name_1
:= Prag_Nam
;
8269 Error_Msg_Qual_Level
:= Nat
'Last;
8272 ("info: missing pragma % for unit &?$?", N
,
8274 Error_Msg_Qual_Level
:= 0;
8276 end Info_Missing_Pragma
;
8280 EA_Id
: constant Elaboration_Attributes_Id
:=
8281 Elaboration_Attributes_Of
(Unit_Id
);
8282 N_Lvl
: Enclosing_Level_Kind
;
8283 N_Rep
: Scenario_Rep_Id
;
8285 -- Start of processing for Ensure_Prior_Elaboration_Dynamic
8288 -- Nothing to do when the unit is guaranteed prior elaboration by
8289 -- means of a source Elaborate[_All] pragma.
8291 if Present
(Elab_Pragma
(EA_Id
)) then
8295 -- Output extra information on a missing Elaborate[_All] pragma when
8296 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
8299 if Elab_Info_Messages
8300 and then not In_State
.Suppress_Info_Messages
8302 N_Rep
:= Scenario_Representation_Of
(N
, In_State
);
8303 N_Lvl
:= Level
(N_Rep
);
8305 -- Declaration-level scenario
8307 if (Is_Suitable_Call
(N
) or else Is_Suitable_Instantiation
(N
))
8308 and then N_Lvl
= Declaration_Level
8312 -- Library-level scenario
8314 elsif N_Lvl
in Library_Level
then
8317 -- Instantiation library-level scenario
8319 elsif N_Lvl
= Instantiation_Level
then
8322 -- Otherwise the scenario does not appear at the proper level
8328 Info_Missing_Pragma
;
8330 end Ensure_Prior_Elaboration_Dynamic
;
8332 -------------------------------------
8333 -- Ensure_Prior_Elaboration_Static --
8334 -------------------------------------
8336 procedure Ensure_Prior_Elaboration_Static
8338 Unit_Id
: Entity_Id
;
8340 In_State
: Processing_In_State
)
8342 function Find_With_Clause
8344 Withed_Id
: Entity_Id
) return Node_Id
;
8345 pragma Inline
(Find_With_Clause
);
8346 -- Find a nonlimited with clause in the list of context items Items
8347 -- that withs unit Withed_Id. Return Empty if no such clause exists.
8349 procedure Info_Implicit_Pragma
;
8350 pragma Inline
(Info_Implicit_Pragma
);
8351 -- Output information concerning an implicitly generated Elaborate
8352 -- or Elaborate_All pragma with name Prag_Nam for scenario N which
8353 -- ensures the prior elaboration of unit Unit_Id.
8355 ----------------------
8356 -- Find_With_Clause --
8357 ----------------------
8359 function Find_With_Clause
8361 Withed_Id
: Entity_Id
) return Node_Id
8366 -- Examine the context clauses looking for a suitable with. Note
8367 -- that limited clauses do not affect the elaboration order.
8369 Item
:= First
(Items
);
8370 while Present
(Item
) loop
8371 if Nkind
(Item
) = N_With_Clause
8372 and then not Error_Posted
(Item
)
8373 and then not Limited_Present
(Item
)
8374 and then Entity
(Name
(Item
)) = Withed_Id
8383 end Find_With_Clause
;
8385 --------------------------
8386 -- Info_Implicit_Pragma --
8387 --------------------------
8389 procedure Info_Implicit_Pragma
is
8391 -- Internal units are ignored as they cause unnecessary noise
8393 if not In_Internal_Unit
(Unit_Id
) then
8395 -- The name of the unit subjected to the elaboration pragma is
8396 -- fully qualified to improve the clarity of the info message.
8398 Error_Msg_Name_1
:= Prag_Nam
;
8399 Error_Msg_Qual_Level
:= Nat
'Last;
8402 ("info: implicit pragma % generated for unit &?$?",
8405 Error_Msg_Qual_Level
:= 0;
8406 Output_Active_Scenarios
(N
, In_State
);
8408 end Info_Implicit_Pragma
;
8412 EA_Id
: constant Elaboration_Attributes_Id
:=
8413 Elaboration_Attributes_Of
(Unit_Id
);
8415 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
8416 Loc
: constant Source_Ptr
:= Sloc
(Main_Cunit
);
8417 Unit_Cunit
: constant Node_Id
:= Compilation_Unit
(Unit_Id
);
8418 Unit_Prag
: constant Node_Id
:= Elab_Pragma
(EA_Id
);
8419 Unit_With
: constant Node_Id
:= With_Clause
(EA_Id
);
8424 -- Start of processing for Ensure_Prior_Elaboration_Static
8427 -- Nothing to do when the caller has suppressed the generation of
8428 -- implicit Elaborate[_All] pragmas.
8430 if In_State
.Suppress_Implicit_Pragmas
then
8433 -- Nothing to do when the unit is guaranteed prior elaboration by
8434 -- means of a source Elaborate[_All] pragma.
8436 elsif Present
(Unit_Prag
) then
8439 -- Nothing to do when the unit has an existing implicit Elaborate or
8440 -- Elaborate_All pragma installed by a previous scenario.
8442 elsif Present
(Unit_With
) then
8444 -- The unit is already guaranteed prior elaboration by means of an
8445 -- implicit Elaborate pragma, however the current scenario imposes
8446 -- a stronger requirement of Elaborate_All. "Upgrade" the existing
8447 -- pragma to match this new requirement.
8449 if Elaborate_Desirable
(Unit_With
)
8450 and then Prag_Nam
= Name_Elaborate_All
8452 Set_Elaborate_All_Desirable
(Unit_With
);
8453 Set_Elaborate_Desirable
(Unit_With
, False);
8459 -- At this point it is known that the unit has no prior elaboration
8460 -- according to pragmas and hierarchical relationships.
8462 Items
:= Context_Items
(Main_Cunit
);
8466 Set_Context_Items
(Main_Cunit
, Items
);
8469 -- Locate the with clause for the unit. Note that there may not be a
8470 -- clause if the unit is visible through a subunit-body, body-spec,
8471 -- or spec-parent relationship.
8476 Withed_Id
=> Unit_Id
);
8481 -- Note that adding implicit with clauses is safe because analysis,
8482 -- resolution, and expansion have already taken place and it is not
8483 -- possible to interfere with visibility.
8487 Make_With_Clause
(Loc
,
8488 Name
=> New_Occurrence_Of
(Unit_Id
, Loc
));
8490 Set_Implicit_With
(Clause
);
8491 Set_Library_Unit
(Clause
, Unit_Cunit
);
8493 Append_To
(Items
, Clause
);
8496 -- Mark the with clause depending on the pragma required
8498 if Prag_Nam
= Name_Elaborate
then
8499 Set_Elaborate_Desirable
(Clause
);
8501 Set_Elaborate_All_Desirable
(Clause
);
8504 -- The implicit Elaborate[_All] ensures the prior elaboration of
8505 -- the unit. Include the unit in the elaboration context of the
8508 Set_With_Clause
(EA_Id
, Clause
);
8510 -- Output extra information on an implicit Elaborate[_All] pragma
8511 -- when switch -gnatel (info messages on implicit Elaborate[_All]
8512 -- pragmas is in effect.
8514 if Elab_Info_Messages
then
8515 Info_Implicit_Pragma
;
8517 end Ensure_Prior_Elaboration_Static
;
8519 -------------------------------
8520 -- Finalize_Elaborated_Units --
8521 -------------------------------
8523 procedure Finalize_Elaborated_Units
is
8525 UA_Map
.Destroy
(Unit_To_Attributes_Map
);
8526 end Finalize_Elaborated_Units
;
8528 ---------------------------
8529 -- Has_Prior_Elaboration --
8530 ---------------------------
8532 function Has_Prior_Elaboration
8533 (Unit_Id
: Entity_Id
;
8534 Context_OK
: Boolean := False;
8535 Elab_Body_OK
: Boolean := False;
8536 Same_Unit_OK
: Boolean := False) return Boolean
8538 EA_Id
: constant Elaboration_Attributes_Id
:=
8539 Elaboration_Attributes_Of
(Unit_Id
);
8540 Main_Id
: constant Entity_Id
:= Main_Unit_Entity
;
8541 Unit_Prag
: constant Node_Id
:= Elab_Pragma
(EA_Id
);
8542 Unit_With
: constant Node_Id
:= With_Clause
(EA_Id
);
8545 -- A preelaborated unit is always elaborated prior to the main unit
8547 if Is_Preelaborated_Unit
(Unit_Id
) then
8550 -- An internal unit is always elaborated prior to a non-internal main
8553 elsif In_Internal_Unit
(Unit_Id
)
8554 and then not In_Internal_Unit
(Main_Id
)
8558 -- A unit has prior elaboration if it appears within the context
8559 -- of the main unit. Consider this case only when requested by the
8563 and then (Present
(Unit_Prag
) or else Present
(Unit_With
))
8567 -- A unit whose body is elaborated together with its spec has prior
8568 -- elaboration except with respect to itself. Consider this case only
8569 -- when requested by the caller.
8572 and then Has_Pragma_Elaborate_Body
(Unit_Id
)
8573 and then not Is_Same_Unit
(Unit_Id
, Main_Id
)
8577 -- A unit has no prior elaboration with respect to itself, but does
8578 -- not require any means of ensuring its own elaboration either.
8579 -- Treat this case as valid prior elaboration only when requested by
8582 elsif Same_Unit_OK
and then Is_Same_Unit
(Unit_Id
, Main_Id
) then
8587 end Has_Prior_Elaboration
;
8589 ---------------------------------
8590 -- Initialize_Elaborated_Units --
8591 ---------------------------------
8593 procedure Initialize_Elaborated_Units
is
8595 Unit_To_Attributes_Map
:= UA_Map
.Create
(250);
8596 end Initialize_Elaborated_Units
;
8598 ----------------------------------
8599 -- Meet_Elaboration_Requirement --
8600 ----------------------------------
8602 procedure Meet_Elaboration_Requirement
8604 Targ_Id
: Entity_Id
;
8606 In_State
: Processing_In_State
)
8608 pragma Assert
(Req_Nam
in Name_Elaborate | Name_Elaborate_All
);
8610 Main_Id
: constant Entity_Id
:= Main_Unit_Entity
;
8611 Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(Targ_Id
);
8613 procedure Elaboration_Requirement_Error
;
8614 pragma Inline
(Elaboration_Requirement_Error
);
8615 -- Emit an error concerning scenario N which has failed to meet the
8616 -- elaboration requirement.
8618 function Find_Preelaboration_Pragma
8619 (Prag_Nam
: Name_Id
) return Node_Id
;
8620 pragma Inline
(Find_Preelaboration_Pragma
);
8621 -- Traverse the visible declarations of unit Unit_Id and locate a
8622 -- source preelaboration-related pragma with name Prag_Nam.
8624 procedure Info_Requirement_Met
(Prag
: Node_Id
);
8625 pragma Inline
(Info_Requirement_Met
);
8626 -- Output information concerning pragma Prag which meets requirement
8629 -----------------------------------
8630 -- Elaboration_Requirement_Error --
8631 -----------------------------------
8633 procedure Elaboration_Requirement_Error
is
8635 if Is_Suitable_Call
(N
) then
8642 elsif Is_Suitable_Instantiation
(N
) then
8649 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
8651 ("read of refinement constituents during elaboration in "
8654 elsif Is_Suitable_Variable_Reference
(N
) then
8655 Info_Variable_Reference
8659 -- No other scenario may impose a requirement on the context of
8663 pragma Assert
(False);
8667 Error_Msg_Name_1
:= Req_Nam
;
8668 Error_Msg_Node_2
:= Unit_Id
;
8669 Error_Msg_NE
("\\unit & requires pragma % for &", N
, Main_Id
);
8671 Output_Active_Scenarios
(N
, In_State
);
8672 end Elaboration_Requirement_Error
;
8674 --------------------------------
8675 -- Find_Preelaboration_Pragma --
8676 --------------------------------
8678 function Find_Preelaboration_Pragma
8679 (Prag_Nam
: Name_Id
) return Node_Id
8681 Spec
: constant Node_Id
:= Parent
(Unit_Id
);
8685 -- A preelaboration-related pragma comes from source and appears
8686 -- at the top of the visible declarations of a package.
8688 if Nkind
(Spec
) = N_Package_Specification
then
8689 Decl
:= First
(Visible_Declarations
(Spec
));
8690 while Present
(Decl
) loop
8691 if Comes_From_Source
(Decl
) then
8692 if Nkind
(Decl
) = N_Pragma
8693 and then Pragma_Name
(Decl
) = Prag_Nam
8697 -- Otherwise the construct terminates the region where
8698 -- the preelaboration-related pragma may appear.
8710 end Find_Preelaboration_Pragma
;
8712 --------------------------
8713 -- Info_Requirement_Met --
8714 --------------------------
8716 procedure Info_Requirement_Met
(Prag
: Node_Id
) is
8717 pragma Assert
(Present
(Prag
));
8720 Error_Msg_Name_1
:= Req_Nam
;
8721 Error_Msg_Sloc
:= Sloc
(Prag
);
8723 ("\\% requirement for unit & met by pragma #", N
, Unit_Id
);
8724 end Info_Requirement_Met
;
8728 EA_Id
: Elaboration_Attributes_Id
;
8731 Unit_Prag
: Node_Id
;
8733 -- Start of processing for Meet_Elaboration_Requirement
8736 -- Assume that the requirement has not been met
8740 -- If the target is within the main unit, either at the source level
8741 -- or through an instantiation, then there is no real requirement to
8742 -- meet because the main unit cannot force its own elaboration by
8743 -- means of an Elaborate[_All] pragma. Treat this case as valid
8746 if In_Extended_Main_Code_Unit
(Targ_Id
) then
8749 -- Otherwise the target resides in an external unit
8751 -- The requirement is met when the target comes from an internal unit
8752 -- because such a unit is elaborated prior to a non-internal unit.
8754 elsif In_Internal_Unit
(Unit_Id
)
8755 and then not In_Internal_Unit
(Main_Id
)
8759 -- The requirement is met when the target comes from a preelaborated
8760 -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
8762 elsif Is_Preelaborated_Unit
(Unit_Id
) then
8765 -- Output extra information when switch -gnatel (info messages on
8766 -- implicit Elaborate[_All] pragmas.
8768 if Elab_Info_Messages
8769 and then not In_State
.Suppress_Info_Messages
8771 if Is_Preelaborated
(Unit_Id
) then
8772 Elab_Nam
:= Name_Preelaborate
;
8774 elsif Is_Pure
(Unit_Id
) then
8775 Elab_Nam
:= Name_Pure
;
8777 elsif Is_Remote_Call_Interface
(Unit_Id
) then
8778 Elab_Nam
:= Name_Remote_Call_Interface
;
8780 elsif Is_Remote_Types
(Unit_Id
) then
8781 Elab_Nam
:= Name_Remote_Types
;
8784 pragma Assert
(Is_Shared_Passive
(Unit_Id
));
8785 Elab_Nam
:= Name_Shared_Passive
;
8788 Info_Requirement_Met
(Find_Preelaboration_Pragma
(Elab_Nam
));
8791 -- Determine whether the context of the main unit has a pragma strong
8792 -- enough to meet the requirement.
8795 EA_Id
:= Elaboration_Attributes_Of
(Unit_Id
);
8796 Unit_Prag
:= Elab_Pragma
(EA_Id
);
8798 -- The pragma must be either Elaborate_All or be as strong as the
8801 if Present
(Unit_Prag
)
8802 and then Pragma_Name
(Unit_Prag
) in Name_Elaborate_All | Req_Nam
8806 -- Output extra information when switch -gnatel (info messages
8807 -- on implicit Elaborate[_All] pragmas.
8809 if Elab_Info_Messages
8810 and then not In_State
.Suppress_Info_Messages
8812 Info_Requirement_Met
(Unit_Prag
);
8817 -- The requirement was not met by the context of the main unit, issue
8821 Elaboration_Requirement_Error
;
8823 end Meet_Elaboration_Requirement
;
8829 function Present
(EA_Id
: Elaboration_Attributes_Id
) return Boolean is
8831 return EA_Id
/= No_Elaboration_Attributes
;
8834 ---------------------
8835 -- Set_Elab_Pragma --
8836 ---------------------
8838 procedure Set_Elab_Pragma
8839 (EA_Id
: Elaboration_Attributes_Id
;
8842 pragma Assert
(Present
(EA_Id
));
8844 Elaboration_Attributes
.Table
(EA_Id
).Elab_Pragma
:= Prag
;
8845 end Set_Elab_Pragma
;
8847 ---------------------
8848 -- Set_With_Clause --
8849 ---------------------
8851 procedure Set_With_Clause
8852 (EA_Id
: Elaboration_Attributes_Id
;
8855 pragma Assert
(Present
(EA_Id
));
8857 Elaboration_Attributes
.Table
(EA_Id
).With_Clause
:= Clause
;
8858 end Set_With_Clause
;
8864 function With_Clause
8865 (EA_Id
: Elaboration_Attributes_Id
) return Node_Id
8867 pragma Assert
(Present
(EA_Id
));
8869 return Elaboration_Attributes
.Table
(EA_Id
).With_Clause
;
8871 end Elaborated_Units
;
8873 ------------------------------
8874 -- Elaboration_Phase_Active --
8875 ------------------------------
8877 function Elaboration_Phase_Active
return Boolean is
8879 return Elaboration_Phase
= Active
;
8880 end Elaboration_Phase_Active
;
8882 ------------------------------
8883 -- Error_Preelaborated_Call --
8884 ------------------------------
8886 procedure Error_Preelaborated_Call
(N
: Node_Id
) is
8888 -- This is a warning in GNAT mode allowing such calls to be used in the
8889 -- predefined library units with appropriate care.
8891 Error_Msg_Warn
:= GNAT_Mode
;
8893 -- Ada 2022 (AI12-0175): Calls to certain functions that are essentially
8894 -- unchecked conversions are preelaborable.
8896 if Ada_Version
>= Ada_2022
then
8898 ("<<non-preelaborable call not allowed in preelaborated unit", N
);
8901 ("<<non-static call not allowed in preelaborated unit", N
);
8903 end Error_Preelaborated_Call
;
8905 ----------------------------------
8906 -- Finalize_All_Data_Structures --
8907 ----------------------------------
8909 procedure Finalize_All_Data_Structures
is
8911 Finalize_Body_Processor
;
8912 Finalize_Early_Call_Region_Processor
;
8913 Finalize_Elaborated_Units
;
8914 Finalize_Internal_Representation
;
8915 Finalize_Invocation_Graph
;
8916 Finalize_Scenario_Storage
;
8917 end Finalize_All_Data_Structures
;
8919 -----------------------------
8920 -- Find_Enclosing_Instance --
8921 -----------------------------
8923 function Find_Enclosing_Instance
(N
: Node_Id
) return Node_Id
is
8927 -- Climb the parent chain looking for an enclosing instance spec or body
8930 while Present
(Par
) loop
8931 if Nkind
(Par
) in N_Package_Body
8932 | N_Package_Declaration
8934 | N_Subprogram_Declaration
8935 and then Is_Generic_Instance
(Unique_Defining_Entity
(Par
))
8940 Par
:= Parent
(Par
);
8944 end Find_Enclosing_Instance
;
8946 --------------------------
8947 -- Find_Enclosing_Level --
8948 --------------------------
8950 function Find_Enclosing_Level
(N
: Node_Id
) return Enclosing_Level_Kind
is
8951 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
;
8952 pragma Inline
(Level_Of
);
8953 -- Obtain the corresponding level of unit Unit
8959 function Level_Of
(Unit
: Node_Id
) return Enclosing_Level_Kind
is
8960 Spec_Id
: Entity_Id
;
8963 if Nkind
(Unit
) in N_Generic_Instantiation
then
8964 return Instantiation_Level
;
8966 elsif Nkind
(Unit
) = N_Generic_Package_Declaration
then
8967 return Generic_Spec_Level
;
8969 elsif Nkind
(Unit
) = N_Package_Declaration
then
8970 return Library_Spec_Level
;
8972 elsif Nkind
(Unit
) = N_Package_Body
then
8973 Spec_Id
:= Corresponding_Spec
(Unit
);
8975 -- The body belongs to a generic package
8977 if Present
(Spec_Id
)
8978 and then Ekind
(Spec_Id
) = E_Generic_Package
8980 return Generic_Body_Level
;
8982 -- Otherwise the body belongs to a non-generic package. This also
8983 -- treats an illegal package body without a corresponding spec as
8984 -- a non-generic package body.
8987 return Library_Body_Level
;
9000 -- Start of processing for Find_Enclosing_Level
9003 -- Call markers and instantiations which appear at the declaration level
9004 -- but are later relocated in a different context retain their original
9005 -- declaration level.
9007 if Nkind
(N
) in N_Call_Marker
9008 | N_Function_Instantiation
9009 | N_Package_Instantiation
9010 | N_Procedure_Instantiation
9011 and then Is_Declaration_Level_Node
(N
)
9013 return Declaration_Level
;
9016 -- Climb the parent chain looking at the enclosing levels
9019 Curr
:= Parent
(Prev
);
9020 while Present
(Curr
) loop
9022 -- A traversal from a subunit continues via the corresponding stub
9024 if Nkind
(Curr
) = N_Subunit
then
9025 Curr
:= Corresponding_Stub
(Curr
);
9027 -- The current construct is a package. Packages are ignored because
9028 -- they are always elaborated when the enclosing context is invoked
9031 elsif Nkind
(Curr
) in N_Package_Body | N_Package_Declaration
then
9034 -- The current construct is a block statement
9036 elsif Nkind
(Curr
) = N_Block_Statement
then
9038 -- Ignore internally generated blocks created by the expander for
9039 -- various purposes such as abort defer/undefer.
9041 if not Comes_From_Source
(Curr
) then
9044 -- If the traversal came from the handled sequence of statements,
9045 -- then the node appears at the level of the enclosing construct.
9046 -- This is a more reliable test because transients scopes within
9047 -- the declarative region of the encapsulator are hard to detect.
9049 elsif Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
9050 and then Handled_Statement_Sequence
(Curr
) = Prev
9052 return Find_Enclosing_Level
(Parent
(Curr
));
9054 -- Otherwise the traversal came from the declarations, the node is
9055 -- at the declaration level.
9058 return Declaration_Level
;
9061 -- The current construct is a declaration-level encapsulator
9063 elsif Nkind
(Curr
) in
9064 N_Entry_Body | N_Subprogram_Body | N_Task_Body
9066 -- If the traversal came from the handled sequence of statements,
9067 -- then the node cannot possibly appear at any level. This is
9068 -- a more reliable test because transients scopes within the
9069 -- declarative region of the encapsulator are hard to detect.
9071 if Nkind
(Prev
) = N_Handled_Sequence_Of_Statements
9072 and then Handled_Statement_Sequence
(Curr
) = Prev
9076 -- Otherwise the traversal came from the declarations, the node is
9077 -- at the declaration level.
9080 return Declaration_Level
;
9083 -- The current construct is a non-library-level encapsulator which
9084 -- indicates that the node cannot possibly appear at any level. Note
9085 -- that the check must come after the declaration-level check because
9086 -- both predicates share certain nodes.
9088 elsif Is_Non_Library_Level_Encapsulator
(Curr
) then
9089 Context
:= Parent
(Curr
);
9091 -- The sole exception is when the encapsulator is the compilation
9092 -- utit itself because the compilation unit node requires special
9093 -- processing (see below).
9095 if Present
(Context
)
9096 and then Nkind
(Context
) = N_Compilation_Unit
9100 -- Otherwise the node is not at any level
9106 -- The current construct is a compilation unit. The node appears at
9107 -- the [generic] library level when the unit is a [generic] package.
9109 elsif Nkind
(Curr
) = N_Compilation_Unit
then
9110 return Level_Of
(Unit
(Curr
));
9114 Curr
:= Parent
(Prev
);
9118 end Find_Enclosing_Level
;
9124 function Find_Top_Unit
(N
: Node_Or_Entity_Id
) return Entity_Id
is
9126 return Find_Unit_Entity
(Unit
(Cunit
(Get_Top_Level_Code_Unit
(N
))));
9129 ----------------------
9130 -- Find_Unit_Entity --
9131 ----------------------
9133 function Find_Unit_Entity
(N
: Node_Id
) return Entity_Id
is
9134 Context
: constant Node_Id
:= Parent
(N
);
9135 Orig_N
: constant Node_Id
:= Original_Node
(N
);
9138 -- The unit denotes a package body of an instantiation which acts as
9139 -- a compilation unit. The proper entity is that of the package spec.
9141 if Nkind
(N
) = N_Package_Body
9142 and then Nkind
(Orig_N
) = N_Package_Instantiation
9143 and then Nkind
(Context
) = N_Compilation_Unit
9145 return Corresponding_Spec
(N
);
9147 -- The unit denotes an anonymous package created to wrap a subprogram
9148 -- instantiation which acts as a compilation unit. The proper entity is
9149 -- that of the "related instance".
9151 elsif Nkind
(N
) = N_Package_Declaration
9152 and then Nkind
(Orig_N
) in
9153 N_Function_Instantiation | N_Procedure_Instantiation
9154 and then Nkind
(Context
) = N_Compilation_Unit
9156 return Related_Instance
(Defining_Entity
(N
));
9158 -- The unit denotes a concurrent body acting as a subunit. Such bodies
9159 -- are generally rewritten into null statements. The proper entity is
9160 -- that of the "original node".
9162 elsif Nkind
(N
) = N_Subunit
9163 and then Nkind
(Proper_Body
(N
)) = N_Null_Statement
9164 and then Nkind
(Original_Node
(Proper_Body
(N
))) in
9165 N_Protected_Body | N_Task_Body
9167 return Defining_Entity
(Original_Node
(Proper_Body
(N
)));
9169 -- Otherwise the proper entity is the defining entity
9172 return Defining_Entity
(N
);
9174 end Find_Unit_Entity
;
9176 -----------------------
9177 -- First_Formal_Type --
9178 -----------------------
9180 function First_Formal_Type
(Subp_Id
: Entity_Id
) return Entity_Id
is
9181 Formal_Id
: constant Entity_Id
:= First_Formal
(Subp_Id
);
9185 if Present
(Formal_Id
) then
9186 Typ
:= Etype
(Formal_Id
);
9188 -- Handle various combinations of concurrent and private types
9191 if Ekind
(Typ
) in E_Protected_Type | E_Task_Type
9192 and then Present
(Anonymous_Object
(Typ
))
9194 Typ
:= Anonymous_Object
(Typ
);
9196 elsif Is_Concurrent_Record_Type
(Typ
) then
9197 Typ
:= Corresponding_Concurrent_Type
(Typ
);
9199 elsif Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
9200 Typ
:= Full_View
(Typ
);
9211 end First_Formal_Type
;
9213 ------------------------------
9214 -- Guaranteed_ABE_Processor --
9215 ------------------------------
9217 package body Guaranteed_ABE_Processor
is
9218 function Is_Guaranteed_ABE
9220 Target_Decl
: Node_Id
;
9221 Target_Body
: Node_Id
) return Boolean;
9222 pragma Inline
(Is_Guaranteed_ABE
);
9223 -- Determine whether scenario N with a target described by its initial
9224 -- declaration Target_Decl and body Target_Decl results in a guaranteed
9227 procedure Process_Guaranteed_ABE_Activation
9229 Call_Rep
: Scenario_Rep_Id
;
9231 Obj_Rep
: Target_Rep_Id
;
9232 Task_Typ
: Entity_Id
;
9233 Task_Rep
: Target_Rep_Id
;
9234 In_State
: Processing_In_State
);
9235 pragma Inline
(Process_Guaranteed_ABE_Activation
);
9236 -- Perform common guaranteed ABE checks and diagnostics for activation
9237 -- call Call which activates object Obj_Id of task type Task_Typ. Formal
9238 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the
9239 -- representation of the object. Task_Rep denotes the representation of
9240 -- the task type. In_State is the current state of the Processing phase.
9242 procedure Process_Guaranteed_ABE_Call
9244 Call_Rep
: Scenario_Rep_Id
;
9245 In_State
: Processing_In_State
);
9246 pragma Inline
(Process_Guaranteed_ABE_Call
);
9247 -- Perform common guaranteed ABE checks and diagnostics for call Call
9248 -- with representation Call_Rep. In_State denotes the current state of
9249 -- the Processing phase.
9251 procedure Process_Guaranteed_ABE_Instantiation
9253 Inst_Rep
: Scenario_Rep_Id
;
9254 In_State
: Processing_In_State
);
9255 pragma Inline
(Process_Guaranteed_ABE_Instantiation
);
9256 -- Perform common guaranteed ABE checks and diagnostics for instance
9257 -- Inst with representation Inst_Rep. In_State is the current state of
9258 -- the Processing phase.
9260 -----------------------
9261 -- Is_Guaranteed_ABE --
9262 -----------------------
9264 function Is_Guaranteed_ABE
9266 Target_Decl
: Node_Id
;
9267 Target_Body
: Node_Id
) return Boolean
9271 -- Avoid cascaded errors if there were previous serious infractions.
9272 -- As a result the scenario will not be treated as a guaranteed ABE.
9273 -- This behavior parallels that of the old ABE mechanism.
9275 if Serious_Errors_Detected
> 0 then
9278 -- The scenario and the target appear in the same context ignoring
9279 -- enclosing library levels.
9281 elsif In_Same_Context
(N
, Target_Decl
) then
9283 -- The target body has already been encountered. The scenario
9284 -- results in a guaranteed ABE if it appears prior to the body.
9286 if Present
(Target_Body
) then
9287 return Earlier_In_Extended_Unit
(N
, Target_Body
);
9289 -- Otherwise the body has not been encountered yet. The scenario
9290 -- is a guaranteed ABE since the body will appear later, unless
9291 -- this is a null specification, which can occur if expansion is
9292 -- disabled (e.g. -gnatc or GNATprove mode). It is assumed that
9293 -- the caller has already ensured that the scenario is ABE-safe
9294 -- because optional bodies are not considered here.
9297 Spec
:= Specification
(Target_Decl
);
9299 if Nkind
(Spec
) /= N_Procedure_Specification
9300 or else not Null_Present
(Spec
)
9308 end Is_Guaranteed_ABE
;
9310 ----------------------------
9311 -- Process_Guaranteed_ABE --
9312 ----------------------------
9314 procedure Process_Guaranteed_ABE
9316 In_State
: Processing_In_State
)
9318 Scen
: constant Node_Id
:= Scenario
(N
);
9319 Scen_Rep
: Scenario_Rep_Id
;
9322 -- Add the current scenario to the stack of active scenarios
9324 Push_Active_Scenario
(Scen
);
9326 -- Only calls, instantiations, and task activations may result in a
9329 -- Call or task activation
9331 if Is_Suitable_Call
(Scen
) then
9332 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
9334 if Kind
(Scen_Rep
) = Call_Scenario
then
9335 Process_Guaranteed_ABE_Call
9337 Call_Rep
=> Scen_Rep
,
9338 In_State
=> In_State
);
9341 pragma Assert
(Kind
(Scen_Rep
) = Task_Activation_Scenario
);
9345 Call_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
9346 Processor
=> Process_Guaranteed_ABE_Activation
'Access,
9347 In_State
=> In_State
);
9352 elsif Is_Suitable_Instantiation
(Scen
) then
9353 Process_Guaranteed_ABE_Instantiation
9355 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
9356 In_State
=> In_State
);
9359 -- Remove the current scenario from the stack of active scenarios
9360 -- once all ABE diagnostics and checks have been performed.
9362 Pop_Active_Scenario
(Scen
);
9363 end Process_Guaranteed_ABE
;
9365 ---------------------------------------
9366 -- Process_Guaranteed_ABE_Activation --
9367 ---------------------------------------
9369 procedure Process_Guaranteed_ABE_Activation
9371 Call_Rep
: Scenario_Rep_Id
;
9373 Obj_Rep
: Target_Rep_Id
;
9374 Task_Typ
: Entity_Id
;
9375 Task_Rep
: Target_Rep_Id
;
9376 In_State
: Processing_In_State
)
9378 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Task_Rep
);
9380 Check_OK
: constant Boolean :=
9381 not In_State
.Suppress_Checks
9382 and then Ghost_Mode_Of
(Obj_Rep
) /= Is_Ignored
9383 and then Ghost_Mode_Of
(Task_Rep
) /= Is_Ignored
9384 and then Elaboration_Checks_OK
(Obj_Rep
)
9385 and then Elaboration_Checks_OK
(Task_Rep
);
9386 -- A run-time ABE check may be installed only when the object and the
9387 -- task type have active elaboration checks, and both are not ignored
9388 -- Ghost constructs.
9391 -- Nothing to do when the root scenario appears at the declaration
9392 -- level and the task is in the same unit, but outside this context.
9394 -- task type Task_Typ; -- task declaration
9396 -- procedure Proc is
9397 -- function A ... is
9399 -- if Some_Condition then
9403 -- <activation call> -- activation site
9408 -- X : ... := A; -- root scenario
9411 -- task body Task_Typ is
9415 -- In the example above, the context of X is the declarative list
9416 -- of Proc. The "elaboration" of X may reach the activation of T
9417 -- whose body is defined outside of X's context. The task body is
9418 -- relevant only when Proc is invoked, but this happens only in
9419 -- "normal" elaboration, therefore the task body must not be
9420 -- considered if this is not the case.
9422 if Is_Up_Level_Target
9423 (Targ_Decl
=> Spec_Decl
,
9424 In_State
=> In_State
)
9428 -- Nothing to do when the activation is ABE-safe
9432 -- task type Task_Typ;
9435 -- package body Gen is
9436 -- task body Task_Typ is
9443 -- procedure Main is
9444 -- package Nested is
9445 -- package Inst is new Gen;
9446 -- T : Inst.Task_Typ;
9447 -- end Nested; -- safe activation
9450 elsif Is_Safe_Activation
(Call
, Task_Rep
) then
9453 -- An activation call leads to a guaranteed ABE when the activation
9454 -- call and the task appear within the same context ignoring library
9455 -- levels, and the body of the task has not been seen yet or appears
9456 -- after the activation call.
9458 -- procedure Guaranteed_ABE is
9459 -- task type Task_Typ;
9461 -- package Nested is
9463 -- <activation call> -- guaranteed ABE
9466 -- task body Task_Typ is
9471 elsif Is_Guaranteed_ABE
9473 Target_Decl
=> Spec_Decl
,
9474 Target_Body
=> Body_Declaration
(Task_Rep
))
9476 if Elaboration_Warnings_OK
(Call_Rep
) then
9477 Error_Msg_Sloc
:= Sloc
(Call
);
9479 ("??task & will be activated # before elaboration of its "
9482 ("\Program_Error will be raised at run time", Obj_Id
);
9485 -- Mark the activation call as a guaranteed ABE
9487 Set_Is_Known_Guaranteed_ABE
(Call
);
9489 -- Install a run-time ABE failue because this activation call will
9490 -- always result in an ABE.
9493 Install_Scenario_ABE_Failure
9495 Targ_Id
=> Task_Typ
,
9496 Targ_Rep
=> Task_Rep
,
9497 Disable
=> Obj_Rep
);
9500 end Process_Guaranteed_ABE_Activation
;
9502 ---------------------------------
9503 -- Process_Guaranteed_ABE_Call --
9504 ---------------------------------
9506 procedure Process_Guaranteed_ABE_Call
9508 Call_Rep
: Scenario_Rep_Id
;
9509 In_State
: Processing_In_State
)
9511 Subp_Id
: constant Entity_Id
:= Target
(Call_Rep
);
9512 Subp_Rep
: constant Target_Rep_Id
:=
9513 Target_Representation_Of
(Subp_Id
, In_State
);
9514 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Subp_Rep
);
9516 Check_OK
: constant Boolean :=
9517 not In_State
.Suppress_Checks
9518 and then Ghost_Mode_Of
(Call_Rep
) /= Is_Ignored
9519 and then Ghost_Mode_Of
(Subp_Rep
) /= Is_Ignored
9520 and then Elaboration_Checks_OK
(Call_Rep
)
9521 and then Elaboration_Checks_OK
(Subp_Rep
);
9522 -- A run-time ABE check may be installed only when both the call
9523 -- and the target have active elaboration checks, and both are not
9524 -- ignored Ghost constructs.
9527 -- Nothing to do when the root scenario appears at the declaration
9528 -- level and the target is in the same unit but outside this context.
9530 -- function B ...; -- target declaration
9532 -- procedure Proc is
9533 -- function A ... is
9535 -- if Some_Condition then
9536 -- return B; -- call site
9540 -- X : ... := A; -- root scenario
9543 -- function B ... is
9547 -- In the example above, the context of X is the declarative region
9548 -- of Proc. The "elaboration" of X may eventually reach B which is
9549 -- defined outside of X's context. B is relevant only when Proc is
9550 -- invoked, but this happens only by means of "normal" elaboration,
9551 -- therefore B must not be considered if this is not the case.
9553 if Is_Up_Level_Target
9554 (Targ_Decl
=> Spec_Decl
,
9555 In_State
=> In_State
)
9559 -- Nothing to do when the call is ABE-safe
9562 -- function Gen ...;
9564 -- function Gen ... is
9570 -- procedure Main is
9571 -- function Inst is new Gen;
9572 -- X : ... := Inst; -- safe call
9575 elsif Is_Safe_Call
(Call
, Subp_Id
, Subp_Rep
) then
9578 -- A call leads to a guaranteed ABE when the call and the target
9579 -- appear within the same context ignoring library levels, and the
9580 -- body of the target has not been seen yet or appears after the
9583 -- procedure Guaranteed_ABE is
9584 -- function Func ...;
9586 -- package Nested is
9587 -- Obj : ... := Func; -- guaranteed ABE
9590 -- function Func ... is
9595 elsif Is_Guaranteed_ABE
9597 Target_Decl
=> Spec_Decl
,
9598 Target_Body
=> Body_Declaration
(Subp_Rep
))
9600 if Elaboration_Warnings_OK
(Call_Rep
) then
9602 ("??cannot call & before body seen", Call
, Subp_Id
);
9603 Error_Msg_N
("\Program_Error will be raised at run time", Call
);
9606 -- Mark the call as a guaranteed ABE
9608 Set_Is_Known_Guaranteed_ABE
(Call
);
9610 -- Install a run-time ABE failure because the call will always
9611 -- result in an ABE.
9614 Install_Scenario_ABE_Failure
9617 Targ_Rep
=> Subp_Rep
,
9618 Disable
=> Call_Rep
);
9621 end Process_Guaranteed_ABE_Call
;
9623 ------------------------------------------
9624 -- Process_Guaranteed_ABE_Instantiation --
9625 ------------------------------------------
9627 procedure Process_Guaranteed_ABE_Instantiation
9629 Inst_Rep
: Scenario_Rep_Id
;
9630 In_State
: Processing_In_State
)
9632 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
9633 Gen_Rep
: constant Target_Rep_Id
:=
9634 Target_Representation_Of
(Gen_Id
, In_State
);
9635 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Gen_Rep
);
9637 Check_OK
: constant Boolean :=
9638 not In_State
.Suppress_Checks
9639 and then Ghost_Mode_Of
(Inst_Rep
) /= Is_Ignored
9640 and then Ghost_Mode_Of
(Gen_Rep
) /= Is_Ignored
9641 and then Elaboration_Checks_OK
(Inst_Rep
)
9642 and then Elaboration_Checks_OK
(Gen_Rep
);
9643 -- A run-time ABE check may be installed only when both the instance
9644 -- and the generic have active elaboration checks and both are not
9645 -- ignored Ghost constructs.
9648 -- Nothing to do when the root scenario appears at the declaration
9649 -- level and the generic is in the same unit, but outside this
9653 -- procedure Gen is ...; -- generic declaration
9655 -- procedure Proc is
9656 -- function A ... is
9658 -- if Some_Condition then
9660 -- procedure I is new Gen; -- instantiation site
9665 -- X : ... := A; -- root scenario
9672 -- In the example above, the context of X is the declarative region
9673 -- of Proc. The "elaboration" of X may eventually reach Gen which
9674 -- appears outside of X's context. Gen is relevant only when Proc is
9675 -- invoked, but this happens only by means of "normal" elaboration,
9676 -- therefore Gen must not be considered if this is not the case.
9678 if Is_Up_Level_Target
9679 (Targ_Decl
=> Spec_Decl
,
9680 In_State
=> In_State
)
9684 -- Nothing to do when the instantiation is ABE-safe
9691 -- package body Gen is
9696 -- procedure Main is
9697 -- package Inst is new Gen (ABE); -- safe instantiation
9700 elsif Is_Safe_Instantiation
(Inst
, Gen_Id
, Gen_Rep
) then
9703 -- An instantiation leads to a guaranteed ABE when the instantiation
9704 -- and the generic appear within the same context ignoring library
9705 -- levels, and the body of the generic has not been seen yet or
9706 -- appears after the instantiation.
9708 -- procedure Guaranteed_ABE is
9712 -- package Nested is
9713 -- procedure Inst is new Gen; -- guaranteed ABE
9721 elsif Is_Guaranteed_ABE
9723 Target_Decl
=> Spec_Decl
,
9724 Target_Body
=> Body_Declaration
(Gen_Rep
))
9726 if Elaboration_Warnings_OK
(Inst_Rep
) then
9728 ("??cannot instantiate & before body seen", Inst
, Gen_Id
);
9729 Error_Msg_N
("\Program_Error will be raised at run time", Inst
);
9732 -- Mark the instantiation as a guarantee ABE. This automatically
9733 -- suppresses the instantiation of the generic body.
9735 Set_Is_Known_Guaranteed_ABE
(Inst
);
9737 -- Install a run-time ABE failure because the instantiation will
9738 -- always result in an ABE.
9741 Install_Scenario_ABE_Failure
9744 Targ_Rep
=> Gen_Rep
,
9745 Disable
=> Inst_Rep
);
9748 end Process_Guaranteed_ABE_Instantiation
;
9749 end Guaranteed_ABE_Processor
;
9755 function Has_Body
(Pack_Decl
: Node_Id
) return Boolean is
9756 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
;
9757 pragma Inline
(Find_Corresponding_Body
);
9758 -- Try to locate the corresponding body of spec Spec_Id. If no body is
9759 -- found, return Empty.
9762 (Spec_Id
: Entity_Id
;
9763 From
: Node_Id
) return Node_Id
;
9764 pragma Inline
(Find_Body
);
9765 -- Try to locate the corresponding body of spec Spec_Id in the node list
9766 -- which follows arbitrary node From. If no body is found, return Empty.
9768 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
;
9769 pragma Inline
(Load_Package_Body
);
9770 -- Attempt to load the body of unit Unit_Nam. If the load failed, return
9771 -- Empty. If the compilation will not generate code, return Empty.
9773 -----------------------------
9774 -- Find_Corresponding_Body --
9775 -----------------------------
9777 function Find_Corresponding_Body
(Spec_Id
: Entity_Id
) return Node_Id
is
9778 Context
: constant Entity_Id
:= Scope
(Spec_Id
);
9779 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9780 Body_Decl
: Node_Id
;
9781 Body_Id
: Entity_Id
;
9784 if Is_Compilation_Unit
(Spec_Id
) then
9785 Body_Id
:= Corresponding_Body
(Spec_Decl
);
9787 if Present
(Body_Id
) then
9788 return Unit_Declaration_Node
(Body_Id
);
9790 -- The package is at the library and requires a body. Load the
9791 -- corresponding body because the optional body may be declared
9794 elsif Unit_Requires_Body
(Spec_Id
) then
9797 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec_Decl
))));
9799 -- Otherwise there is no optional body
9805 -- The immediate context is a package. The optional body may be
9806 -- within the body of that package.
9808 -- procedure Proc is
9809 -- package Nested_1 is
9810 -- package Nested_2 is
9817 -- package body Nested_1 is
9818 -- package body Nested_2 is separate;
9821 -- separate (Proc.Nested_1.Nested_2)
9822 -- package body Nested_2 is
9823 -- package body Pack is -- optional body
9828 elsif Is_Package_Or_Generic_Package
(Context
) then
9829 Body_Decl
:= Find_Corresponding_Body
(Context
);
9831 -- The optional body is within the body of the enclosing package
9833 if Present
(Body_Decl
) then
9836 (Spec_Id
=> Spec_Id
,
9837 From
=> First
(Declarations
(Body_Decl
)));
9839 -- Otherwise the enclosing package does not have a body. This may
9840 -- be the result of an error or a genuine lack of a body.
9846 -- Otherwise the immediate context is a body. The optional body may
9847 -- be within the same list as the spec.
9849 -- procedure Proc is
9854 -- package body Pack is -- optional body
9861 (Spec_Id
=> Spec_Id
,
9862 From
=> Next
(Spec_Decl
));
9864 end Find_Corresponding_Body
;
9871 (Spec_Id
: Entity_Id
;
9872 From
: Node_Id
) return Node_Id
9874 Spec_Nam
: constant Name_Id
:= Chars
(Spec_Id
);
9880 while Present
(Item
) loop
9882 -- The current item denotes the optional body
9884 if Nkind
(Item
) = N_Package_Body
9885 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
9889 -- The current item denotes a stub, the optional body may be in
9892 elsif Nkind
(Item
) = N_Package_Body_Stub
9893 and then Chars
(Defining_Entity
(Item
)) = Spec_Nam
9895 Lib_Unit
:= Library_Unit
(Item
);
9897 -- The corresponding subunit was previously loaded
9899 if Present
(Lib_Unit
) then
9902 -- Otherwise attempt to load the corresponding subunit
9905 return Load_Package_Body
(Get_Unit_Name
(Item
));
9915 -----------------------
9916 -- Load_Package_Body --
9917 -----------------------
9919 function Load_Package_Body
(Unit_Nam
: Unit_Name_Type
) return Node_Id
is
9920 Body_Decl
: Node_Id
;
9921 Unit_Num
: Unit_Number_Type
;
9924 -- The load is performed only when the compilation will generate code
9926 if Operating_Mode
= Generate_Code
then
9929 (Load_Name
=> Unit_Nam
,
9932 Error_Node
=> Pack_Decl
);
9934 -- The load failed most likely because the physical file is
9937 if Unit_Num
= No_Unit
then
9940 -- Otherwise the load was successful, return the body of the unit
9943 Body_Decl
:= Unit
(Cunit
(Unit_Num
));
9945 -- If the unit is a subunit with an available proper body,
9946 -- return the proper body.
9948 if Nkind
(Body_Decl
) = N_Subunit
9949 and then Present
(Proper_Body
(Body_Decl
))
9951 Body_Decl
:= Proper_Body
(Body_Decl
);
9959 end Load_Package_Body
;
9963 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
9965 -- Start of processing for Has_Body
9968 -- The body is available
9970 if Present
(Corresponding_Body
(Pack_Decl
)) then
9973 -- The body is required if the package spec contains a construct which
9974 -- requires a completion in a body.
9976 elsif Unit_Requires_Body
(Pack_Id
) then
9979 -- The body may be optional
9982 return Present
(Find_Corresponding_Body
(Pack_Id
));
9990 function Hash
(NE
: Node_Or_Entity_Id
) return Bucket_Range_Type
is
9991 pragma Assert
(Present
(NE
));
9993 return Bucket_Range_Type
(NE
);
9996 --------------------------
9997 -- In_External_Instance --
9998 --------------------------
10000 function In_External_Instance
10002 Target_Decl
: Node_Id
) return Boolean
10005 Inst_Body
: Node_Id
;
10006 Inst_Spec
: Node_Id
;
10009 Inst
:= Find_Enclosing_Instance
(Target_Decl
);
10011 -- The target declaration appears within an instance spec. Visibility is
10012 -- ignored because internally generated primitives for private types may
10013 -- reside in the private declarations and still be invoked from outside.
10015 if Present
(Inst
) and then Nkind
(Inst
) = N_Package_Declaration
then
10017 -- The scenario comes from the main unit and the instance does not
10019 if In_Extended_Main_Code_Unit
(N
)
10020 and then not In_Extended_Main_Code_Unit
(Inst
)
10024 -- Otherwise the scenario must not appear within the instance spec or
10028 Spec_And_Body_From_Node
10030 Spec_Decl
=> Inst_Spec
,
10031 Body_Decl
=> Inst_Body
);
10033 return not In_Subtree
10035 Root1
=> Inst_Spec
,
10036 Root2
=> Inst_Body
);
10041 end In_External_Instance
;
10043 ---------------------
10044 -- In_Main_Context --
10045 ---------------------
10047 function In_Main_Context
(N
: Node_Id
) return Boolean is
10049 -- Scenarios outside the main unit are not considered because the ALI
10050 -- information supplied to binde is for the main unit only.
10052 if not In_Extended_Main_Code_Unit
(N
) then
10055 -- Scenarios within internal units are not considered unless switch
10056 -- -gnatdE (elaboration checks on predefined units) is in effect.
10058 elsif not Debug_Flag_EE
and then In_Internal_Unit
(N
) then
10063 end In_Main_Context
;
10065 ---------------------
10066 -- In_Same_Context --
10067 ---------------------
10069 function In_Same_Context
10072 Nested_OK
: Boolean := False) return Boolean
10074 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
;
10075 pragma Inline
(Find_Enclosing_Context
);
10076 -- Return the nearest enclosing non-library-level or compilation unit
10077 -- node which encapsulates arbitrary node N. Return Empty is no such
10078 -- context is available.
10080 function In_Nested_Context
10082 Inner
: Node_Id
) return Boolean;
10083 pragma Inline
(In_Nested_Context
);
10084 -- Determine whether arbitrary node Outer encapsulates arbitrary node
10087 ----------------------------
10088 -- Find_Enclosing_Context --
10089 ----------------------------
10091 function Find_Enclosing_Context
(N
: Node_Id
) return Node_Id
is
10097 while Present
(Par
) loop
10099 -- A traversal from a subunit continues via the corresponding stub
10101 if Nkind
(Par
) = N_Subunit
then
10102 Par
:= Corresponding_Stub
(Par
);
10104 -- Stop the traversal when the nearest enclosing non-library-level
10105 -- encapsulator has been reached.
10107 elsif Is_Non_Library_Level_Encapsulator
(Par
) then
10108 Context
:= Parent
(Par
);
10110 -- The sole exception is when the encapsulator is the unit of
10111 -- compilation because this case requires special processing
10114 if Present
(Context
)
10115 and then Nkind
(Context
) = N_Compilation_Unit
10123 -- Reaching a compilation unit node without hitting a non-library-
10124 -- level encapsulator indicates that N is at the library level in
10125 -- which case the compilation unit is the context.
10127 elsif Nkind
(Par
) = N_Compilation_Unit
then
10131 Par
:= Parent
(Par
);
10135 end Find_Enclosing_Context
;
10137 -----------------------
10138 -- In_Nested_Context --
10139 -----------------------
10141 function In_Nested_Context
10143 Inner
: Node_Id
) return Boolean
10149 while Present
(Par
) loop
10151 -- A traversal from a subunit continues via the corresponding stub
10153 if Nkind
(Par
) = N_Subunit
then
10154 Par
:= Corresponding_Stub
(Par
);
10156 elsif Par
= Outer
then
10160 Par
:= Parent
(Par
);
10164 end In_Nested_Context
;
10168 Context_1
: constant Node_Id
:= Find_Enclosing_Context
(N1
);
10169 Context_2
: constant Node_Id
:= Find_Enclosing_Context
(N2
);
10171 -- Start of processing for In_Same_Context
10174 -- Both nodes appear within the same context
10176 if Context_1
= Context_2
then
10179 -- Both nodes appear in compilation units. Determine whether one unit
10180 -- is the body of the other.
10182 elsif Nkind
(Context_1
) = N_Compilation_Unit
10183 and then Nkind
(Context_2
) = N_Compilation_Unit
10187 (Unit_1
=> Defining_Entity
(Unit
(Context_1
)),
10188 Unit_2
=> Defining_Entity
(Unit
(Context_2
)));
10190 -- The context of N1 encloses the context of N2
10192 elsif Nested_OK
and then In_Nested_Context
(Context_1
, Context_2
) then
10197 end In_Same_Context
;
10203 procedure Initialize
is
10205 -- Set the soft link which enables Atree.Rewrite to update a scenario
10206 -- each time it is transformed into another node.
10208 Set_Rewriting_Proc
(Update_Elaboration_Scenario
'Access);
10210 -- Create all internal data structures and activate the elaboration
10211 -- phase of the compiler.
10213 Initialize_All_Data_Structures
;
10214 Set_Elaboration_Phase
(Active
);
10217 ------------------------------------
10218 -- Initialize_All_Data_Structures --
10219 ------------------------------------
10221 procedure Initialize_All_Data_Structures
is
10223 Initialize_Body_Processor
;
10224 Initialize_Early_Call_Region_Processor
;
10225 Initialize_Elaborated_Units
;
10226 Initialize_Internal_Representation
;
10227 Initialize_Invocation_Graph
;
10228 Initialize_Scenario_Storage
;
10229 end Initialize_All_Data_Structures
;
10231 --------------------------
10232 -- Instantiated_Generic --
10233 --------------------------
10235 function Instantiated_Generic
(Inst
: Node_Id
) return Entity_Id
is
10237 -- Traverse a possible chain of renamings to obtain the original generic
10238 -- being instantiatied.
10240 return Get_Renamed_Entity
(Entity
(Name
(Inst
)));
10241 end Instantiated_Generic
;
10243 -----------------------------
10244 -- Internal_Representation --
10245 -----------------------------
10247 package body Internal_Representation
is
10253 -- The following type represents the contents of a scenario
10255 type Scenario_Rep_Record
is record
10256 Elab_Checks_OK
: Boolean := False;
10257 -- The status of elaboration checks for the scenario
10259 Elab_Warnings_OK
: Boolean := False;
10260 -- The status of elaboration warnings for the scenario
10262 GM
: Extended_Ghost_Mode
:= Is_Checked_Or_Not_Specified
;
10263 -- The Ghost mode of the scenario
10265 Kind
: Scenario_Kind
:= No_Scenario
;
10266 -- The nature of the scenario
10268 Level
: Enclosing_Level_Kind
:= No_Level
;
10269 -- The enclosing level where the scenario resides
10271 SM
: Extended_SPARK_Mode
:= Is_Off_Or_Not_Specified
;
10272 -- The SPARK mode of the scenario
10274 Target
: Entity_Id
:= Empty
;
10275 -- The target of the scenario
10277 -- The following attributes are multiplexed and depend on the Kind of
10278 -- the scenario. They are mapped as follows:
10281 -- Is_Dispatching_Call (Flag_1)
10283 -- Task_Activation_Scenario
10284 -- Activated_Task_Objects (List_1)
10285 -- Activated_Task_Type (Field_1)
10287 -- Variable_Reference
10288 -- Is_Read_Reference (Flag_1)
10290 Flag_1
: Boolean := False;
10291 Field_1
: Node_Or_Entity_Id
:= Empty
;
10292 List_1
: NE_List
.Doubly_Linked_List
:= NE_List
.Nil
;
10295 -- The following type represents the contents of a target
10297 type Target_Rep_Record
is record
10298 Body_Decl
: Node_Id
:= Empty
;
10299 -- The declaration of the target body
10301 Elab_Checks_OK
: Boolean := False;
10302 -- The status of elaboration checks for the target
10304 Elab_Warnings_OK
: Boolean := False;
10305 -- The status of elaboration warnings for the target
10307 GM
: Extended_Ghost_Mode
:= Is_Checked_Or_Not_Specified
;
10308 -- The Ghost mode of the target
10310 Kind
: Target_Kind
:= No_Target
;
10311 -- The nature of the target
10313 SM
: Extended_SPARK_Mode
:= Is_Off_Or_Not_Specified
;
10314 -- The SPARK mode of the target
10316 Spec_Decl
: Node_Id
:= Empty
;
10317 -- The declaration of the target spec
10319 Unit
: Entity_Id
:= Empty
;
10320 -- The top unit where the target is declared
10322 Version
: Representation_Kind
:= No_Representation
;
10323 -- The version of the target representation
10325 -- The following attributes are multiplexed and depend on the Kind of
10326 -- the target. They are mapped as follows:
10328 -- Subprogram_Target
10329 -- Barrier_Body_Declaration (Field_1)
10332 -- Variable_Declaration (Field_1)
10334 Field_1
: Node_Or_Entity_Id
:= Empty
;
10337 ---------------------
10338 -- Data structures --
10339 ---------------------
10341 procedure Destroy
(T_Id
: in out Target_Rep_Id
);
10342 -- Destroy a target representation T_Id
10344 package ETT_Map
is new Dynamic_Hash_Tables
10345 (Key_Type
=> Entity_Id
,
10346 Value_Type
=> Target_Rep_Id
,
10347 No_Value
=> No_Target_Rep
,
10348 Expansion_Threshold
=> 1.5,
10349 Expansion_Factor
=> 2,
10350 Compression_Threshold
=> 0.3,
10351 Compression_Factor
=> 2,
10353 Destroy_Value
=> Destroy
,
10356 -- The following map relates target representations to entities
10358 Entity_To_Target_Map
: ETT_Map
.Dynamic_Hash_Table
:= ETT_Map
.Nil
;
10360 procedure Destroy
(S_Id
: in out Scenario_Rep_Id
);
10361 -- Destroy a scenario representation S_Id
10363 package NTS_Map
is new Dynamic_Hash_Tables
10364 (Key_Type
=> Node_Id
,
10365 Value_Type
=> Scenario_Rep_Id
,
10366 No_Value
=> No_Scenario_Rep
,
10367 Expansion_Threshold
=> 1.5,
10368 Expansion_Factor
=> 2,
10369 Compression_Threshold
=> 0.3,
10370 Compression_Factor
=> 2,
10372 Destroy_Value
=> Destroy
,
10375 -- The following map relates scenario representations to nodes
10377 Node_To_Scenario_Map
: NTS_Map
.Dynamic_Hash_Table
:= NTS_Map
.Nil
;
10379 -- The following table stores all scenario representations
10381 package Scenario_Reps
is new Table
.Table
10382 (Table_Index_Type
=> Scenario_Rep_Id
,
10383 Table_Component_Type
=> Scenario_Rep_Record
,
10384 Table_Low_Bound
=> First_Scenario_Rep
,
10385 Table_Initial
=> 1000,
10386 Table_Increment
=> 200,
10387 Table_Name
=> "Scenario_Reps");
10389 -- The following table stores all target representations
10391 package Target_Reps
is new Table
.Table
10392 (Table_Index_Type
=> Target_Rep_Id
,
10393 Table_Component_Type
=> Target_Rep_Record
,
10394 Table_Low_Bound
=> First_Target_Rep
,
10395 Table_Initial
=> 1000,
10396 Table_Increment
=> 200,
10397 Table_Name
=> "Target_Reps");
10403 function Create_Access_Taken_Rep
10404 (Attr
: Node_Id
) return Scenario_Rep_Record
;
10405 pragma Inline
(Create_Access_Taken_Rep
);
10406 -- Create the representation of 'Access attribute Attr
10408 function Create_Call_Or_Task_Activation_Rep
10409 (Call
: Node_Id
) return Scenario_Rep_Record
;
10410 pragma Inline
(Create_Call_Or_Task_Activation_Rep
);
10411 -- Create the representation of call or task activation Call
10413 function Create_Derived_Type_Rep
10414 (Typ_Decl
: Node_Id
) return Scenario_Rep_Record
;
10415 pragma Inline
(Create_Derived_Type_Rep
);
10416 -- Create the representation of a derived type described by declaration
10419 function Create_Generic_Rep
10420 (Gen_Id
: Entity_Id
) return Target_Rep_Record
;
10421 pragma Inline
(Create_Generic_Rep
);
10422 -- Create the representation of generic Gen_Id
10424 function Create_Instantiation_Rep
10425 (Inst
: Node_Id
) return Scenario_Rep_Record
;
10426 pragma Inline
(Create_Instantiation_Rep
);
10427 -- Create the representation of instantiation Inst
10429 function Create_Package_Rep
10430 (Pack_Id
: Entity_Id
) return Target_Rep_Record
;
10431 pragma Inline
(Create_Package_Rep
);
10432 -- Create the representation of package Pack_Id
10434 function Create_Protected_Entry_Rep
10435 (PE_Id
: Entity_Id
) return Target_Rep_Record
;
10436 pragma Inline
(Create_Protected_Entry_Rep
);
10437 -- Create the representation of protected entry PE_Id
10439 function Create_Protected_Subprogram_Rep
10440 (PS_Id
: Entity_Id
) return Target_Rep_Record
;
10441 pragma Inline
(Create_Protected_Subprogram_Rep
);
10442 -- Create the representation of protected subprogram PS_Id
10444 function Create_Refined_State_Pragma_Rep
10445 (Prag
: Node_Id
) return Scenario_Rep_Record
;
10446 pragma Inline
(Create_Refined_State_Pragma_Rep
);
10447 -- Create the representation of Refined_State pragma Prag
10449 function Create_Scenario_Rep
10451 In_State
: Processing_In_State
) return Scenario_Rep_Record
;
10452 pragma Inline
(Create_Scenario_Rep
);
10453 -- Top level dispatcher. Create the representation of elaboration
10454 -- scenario N. In_State is the current state of the Processing phase.
10456 function Create_Subprogram_Rep
10457 (Subp_Id
: Entity_Id
) return Target_Rep_Record
;
10458 pragma Inline
(Create_Subprogram_Rep
);
10459 -- Create the representation of entry, operator, or subprogram Subp_Id
10461 function Create_Target_Rep
10463 In_State
: Processing_In_State
) return Target_Rep_Record
;
10464 pragma Inline
(Create_Target_Rep
);
10465 -- Top level dispatcher. Create the representation of elaboration target
10466 -- Id. In_State is the current state of the Processing phase.
10468 function Create_Task_Entry_Rep
10469 (TE_Id
: Entity_Id
) return Target_Rep_Record
;
10470 pragma Inline
(Create_Task_Entry_Rep
);
10471 -- Create the representation of task entry TE_Id
10473 function Create_Task_Rep
(Task_Typ
: Entity_Id
) return Target_Rep_Record
;
10474 pragma Inline
(Create_Task_Rep
);
10475 -- Create the representation of task type Typ
10477 function Create_Variable_Assignment_Rep
10478 (Asmt
: Node_Id
) return Scenario_Rep_Record
;
10479 pragma Inline
(Create_Variable_Assignment_Rep
);
10480 -- Create the representation of variable assignment Asmt
10482 function Create_Variable_Reference_Rep
10483 (Ref
: Node_Id
) return Scenario_Rep_Record
;
10484 pragma Inline
(Create_Variable_Reference_Rep
);
10485 -- Create the representation of variable reference Ref
10487 function Create_Variable_Rep
10488 (Var_Id
: Entity_Id
) return Target_Rep_Record
;
10489 pragma Inline
(Create_Variable_Rep
);
10490 -- Create the representation of variable Var_Id
10492 -----------------------
10493 -- Local subprograms --
10494 -----------------------
10496 function Ghost_Mode_Of_Entity
10497 (Id
: Entity_Id
) return Extended_Ghost_Mode
;
10498 pragma Inline
(Ghost_Mode_Of_Entity
);
10499 -- Obtain the extended Ghost mode of arbitrary entity Id
10501 function Ghost_Mode_Of_Node
(N
: Node_Id
) return Extended_Ghost_Mode
;
10502 pragma Inline
(Ghost_Mode_Of_Node
);
10503 -- Obtain the extended Ghost mode of arbitrary node N
10505 function Present
(S_Id
: Scenario_Rep_Id
) return Boolean;
10506 pragma Inline
(Present
);
10507 -- Determine whether scenario representation S_Id exists
10509 function Present
(T_Id
: Target_Rep_Id
) return Boolean;
10510 pragma Inline
(Present
);
10511 -- Determine whether target representation T_Id exists
10513 function SPARK_Mode_Of_Entity
10514 (Id
: Entity_Id
) return Extended_SPARK_Mode
;
10515 pragma Inline
(SPARK_Mode_Of_Entity
);
10516 -- Obtain the extended SPARK mode of arbitrary entity Id
10518 function SPARK_Mode_Of_Node
(N
: Node_Id
) return Extended_SPARK_Mode
;
10519 pragma Inline
(SPARK_Mode_Of_Node
);
10520 -- Obtain the extended SPARK mode of arbitrary node N
10522 function To_Ghost_Mode
10523 (Ignored_Status
: Boolean) return Extended_Ghost_Mode
;
10524 pragma Inline
(To_Ghost_Mode
);
10525 -- Convert a Ghost mode indicated by Ignored_Status into its extended
10528 function To_SPARK_Mode
(On_Status
: Boolean) return Extended_SPARK_Mode
;
10529 pragma Inline
(To_SPARK_Mode
);
10530 -- Convert a SPARK mode indicated by On_Status into its extended
10533 function Version
(T_Id
: Target_Rep_Id
) return Representation_Kind
;
10534 pragma Inline
(Version
);
10535 -- Obtain the version of target representation T_Id
10537 ----------------------------
10538 -- Activated_Task_Objects --
10539 ----------------------------
10541 function Activated_Task_Objects
10542 (S_Id
: Scenario_Rep_Id
) return NE_List
.Doubly_Linked_List
10544 pragma Assert
(Present
(S_Id
));
10545 pragma Assert
(Kind
(S_Id
) = Task_Activation_Scenario
);
10548 return Scenario_Reps
.Table
(S_Id
).List_1
;
10549 end Activated_Task_Objects
;
10551 -------------------------
10552 -- Activated_Task_Type --
10553 -------------------------
10555 function Activated_Task_Type
10556 (S_Id
: Scenario_Rep_Id
) return Entity_Id
10558 pragma Assert
(Present
(S_Id
));
10559 pragma Assert
(Kind
(S_Id
) = Task_Activation_Scenario
);
10562 return Scenario_Reps
.Table
(S_Id
).Field_1
;
10563 end Activated_Task_Type
;
10565 ------------------------------
10566 -- Barrier_Body_Declaration --
10567 ------------------------------
10569 function Barrier_Body_Declaration
10570 (T_Id
: Target_Rep_Id
) return Node_Id
10572 pragma Assert
(Present
(T_Id
));
10573 pragma Assert
(Kind
(T_Id
) = Subprogram_Target
);
10576 return Target_Reps
.Table
(T_Id
).Field_1
;
10577 end Barrier_Body_Declaration
;
10579 ----------------------
10580 -- Body_Declaration --
10581 ----------------------
10583 function Body_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
is
10584 pragma Assert
(Present
(T_Id
));
10586 return Target_Reps
.Table
(T_Id
).Body_Decl
;
10587 end Body_Declaration
;
10589 -----------------------------
10590 -- Create_Access_Taken_Rep --
10591 -----------------------------
10593 function Create_Access_Taken_Rep
10594 (Attr
: Node_Id
) return Scenario_Rep_Record
10596 Rec
: Scenario_Rep_Record
;
10599 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Attr
);
10600 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Node
(Attr
);
10601 Rec
.GM
:= Is_Checked_Or_Not_Specified
;
10602 Rec
.SM
:= SPARK_Mode_Of_Node
(Attr
);
10603 Rec
.Kind
:= Access_Taken_Scenario
;
10604 Rec
.Target
:= Canonical_Subprogram
(Entity
(Prefix
(Attr
)));
10607 end Create_Access_Taken_Rep
;
10609 ----------------------------------------
10610 -- Create_Call_Or_Task_Activation_Rep --
10611 ----------------------------------------
10613 function Create_Call_Or_Task_Activation_Rep
10614 (Call
: Node_Id
) return Scenario_Rep_Record
10616 Subp_Id
: constant Entity_Id
:= Canonical_Subprogram
(Target
(Call
));
10617 Kind
: Scenario_Kind
;
10618 Rec
: Scenario_Rep_Record
;
10621 if Is_Activation_Proc
(Subp_Id
) then
10622 Kind
:= Task_Activation_Scenario
;
10624 Kind
:= Call_Scenario
;
10627 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Call
);
10628 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Node
(Call
);
10629 Rec
.GM
:= Ghost_Mode_Of_Node
(Call
);
10630 Rec
.SM
:= SPARK_Mode_Of_Node
(Call
);
10632 Rec
.Target
:= Subp_Id
;
10634 -- Scenario-specific attributes
10636 Rec
.Flag_1
:= Is_Dispatching_Call
(Call
); -- Dispatching_Call
10639 end Create_Call_Or_Task_Activation_Rep
;
10641 -----------------------------
10642 -- Create_Derived_Type_Rep --
10643 -----------------------------
10645 function Create_Derived_Type_Rep
10646 (Typ_Decl
: Node_Id
) return Scenario_Rep_Record
10648 Typ
: constant Entity_Id
:= Defining_Entity
(Typ_Decl
);
10649 Rec
: Scenario_Rep_Record
;
10652 Rec
.Elab_Checks_OK
:= False; -- not relevant
10653 Rec
.Elab_Warnings_OK
:= False; -- not relevant
10654 Rec
.GM
:= Ghost_Mode_Of_Entity
(Typ
);
10655 Rec
.SM
:= SPARK_Mode_Of_Entity
(Typ
);
10656 Rec
.Kind
:= Derived_Type_Scenario
;
10660 end Create_Derived_Type_Rep
;
10662 ------------------------
10663 -- Create_Generic_Rep --
10664 ------------------------
10666 function Create_Generic_Rep
10667 (Gen_Id
: Entity_Id
) return Target_Rep_Record
10669 Rec
: Target_Rep_Record
;
10672 Rec
.Kind
:= Generic_Target
;
10674 Spec_And_Body_From_Entity
10676 Body_Decl
=> Rec
.Body_Decl
,
10677 Spec_Decl
=> Rec
.Spec_Decl
);
10680 end Create_Generic_Rep
;
10682 ------------------------------
10683 -- Create_Instantiation_Rep --
10684 ------------------------------
10686 function Create_Instantiation_Rep
10687 (Inst
: Node_Id
) return Scenario_Rep_Record
10689 Rec
: Scenario_Rep_Record
;
10692 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Inst
);
10693 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Node
(Inst
);
10694 Rec
.GM
:= Ghost_Mode_Of_Node
(Inst
);
10695 Rec
.SM
:= SPARK_Mode_Of_Node
(Inst
);
10696 Rec
.Kind
:= Instantiation_Scenario
;
10697 Rec
.Target
:= Instantiated_Generic
(Inst
);
10700 end Create_Instantiation_Rep
;
10702 ------------------------
10703 -- Create_Package_Rep --
10704 ------------------------
10706 function Create_Package_Rep
10707 (Pack_Id
: Entity_Id
) return Target_Rep_Record
10709 Rec
: Target_Rep_Record
;
10712 Rec
.Kind
:= Package_Target
;
10714 Spec_And_Body_From_Entity
10716 Body_Decl
=> Rec
.Body_Decl
,
10717 Spec_Decl
=> Rec
.Spec_Decl
);
10720 end Create_Package_Rep
;
10722 --------------------------------
10723 -- Create_Protected_Entry_Rep --
10724 --------------------------------
10726 function Create_Protected_Entry_Rep
10727 (PE_Id
: Entity_Id
) return Target_Rep_Record
10729 Prot_Id
: constant Entity_Id
:= Protected_Body_Subprogram
(PE_Id
);
10731 Barf_Id
: Entity_Id
;
10733 Rec
: Target_Rep_Record
;
10734 Spec_Id
: Entity_Id
;
10737 -- When the entry [family] has already been expanded, it carries both
10738 -- the procedure which emulates the behavior of the entry [family] as
10739 -- well as the barrier function.
10741 if Present
(Prot_Id
) then
10742 Barf_Id
:= Barrier_Function
(PE_Id
);
10743 Spec_Id
:= Prot_Id
;
10745 -- Otherwise no expansion took place
10752 Rec
.Kind
:= Subprogram_Target
;
10754 Spec_And_Body_From_Entity
10756 Body_Decl
=> Rec
.Body_Decl
,
10757 Spec_Decl
=> Rec
.Spec_Decl
);
10759 -- Target-specific attributes
10761 if Present
(Barf_Id
) then
10762 Spec_And_Body_From_Entity
10764 Body_Decl
=> Rec
.Field_1
, -- Barrier_Body_Declaration
10765 Spec_Decl
=> Dummy
);
10769 end Create_Protected_Entry_Rep
;
10771 -------------------------------------
10772 -- Create_Protected_Subprogram_Rep --
10773 -------------------------------------
10775 function Create_Protected_Subprogram_Rep
10776 (PS_Id
: Entity_Id
) return Target_Rep_Record
10778 Prot_Id
: constant Entity_Id
:= Protected_Body_Subprogram
(PS_Id
);
10779 Rec
: Target_Rep_Record
;
10780 Spec_Id
: Entity_Id
;
10783 -- When the protected subprogram has already been expanded, it
10784 -- carries the subprogram which seizes the lock and invokes the
10785 -- original statements.
10787 if Present
(Prot_Id
) then
10788 Spec_Id
:= Prot_Id
;
10790 -- Otherwise no expansion took place
10796 Rec
.Kind
:= Subprogram_Target
;
10798 Spec_And_Body_From_Entity
10800 Body_Decl
=> Rec
.Body_Decl
,
10801 Spec_Decl
=> Rec
.Spec_Decl
);
10804 end Create_Protected_Subprogram_Rep
;
10806 -------------------------------------
10807 -- Create_Refined_State_Pragma_Rep --
10808 -------------------------------------
10810 function Create_Refined_State_Pragma_Rep
10811 (Prag
: Node_Id
) return Scenario_Rep_Record
10813 Rec
: Scenario_Rep_Record
;
10816 Rec
.Elab_Checks_OK
:= False; -- not relevant
10817 Rec
.Elab_Warnings_OK
:= False; -- not relevant
10819 To_Ghost_Mode
(Is_Ignored_Ghost_Pragma
(Prag
));
10820 Rec
.SM
:= Is_Off_Or_Not_Specified
;
10821 Rec
.Kind
:= Refined_State_Pragma_Scenario
;
10822 Rec
.Target
:= Empty
;
10825 end Create_Refined_State_Pragma_Rep
;
10827 -------------------------
10828 -- Create_Scenario_Rep --
10829 -------------------------
10831 function Create_Scenario_Rep
10833 In_State
: Processing_In_State
) return Scenario_Rep_Record
10835 pragma Unreferenced
(In_State
);
10837 Rec
: Scenario_Rep_Record
;
10840 if Is_Suitable_Access_Taken
(N
) then
10841 Rec
:= Create_Access_Taken_Rep
(N
);
10843 elsif Is_Suitable_Call
(N
) then
10844 Rec
:= Create_Call_Or_Task_Activation_Rep
(N
);
10846 elsif Is_Suitable_Instantiation
(N
) then
10847 Rec
:= Create_Instantiation_Rep
(N
);
10849 elsif Is_Suitable_SPARK_Derived_Type
(N
) then
10850 Rec
:= Create_Derived_Type_Rep
(N
);
10852 elsif Is_Suitable_SPARK_Refined_State_Pragma
(N
) then
10853 Rec
:= Create_Refined_State_Pragma_Rep
(N
);
10855 elsif Is_Suitable_Variable_Assignment
(N
) then
10856 Rec
:= Create_Variable_Assignment_Rep
(N
);
10858 elsif Is_Suitable_Variable_Reference
(N
) then
10859 Rec
:= Create_Variable_Reference_Rep
(N
);
10862 pragma Assert
(False);
10866 -- Common scenario attributes
10868 Rec
.Level
:= Find_Enclosing_Level
(N
);
10871 end Create_Scenario_Rep
;
10873 ---------------------------
10874 -- Create_Subprogram_Rep --
10875 ---------------------------
10877 function Create_Subprogram_Rep
10878 (Subp_Id
: Entity_Id
) return Target_Rep_Record
10880 Rec
: Target_Rep_Record
;
10881 Spec_Id
: Entity_Id
;
10884 Spec_Id
:= Subp_Id
;
10886 -- The elaboration target denotes an internal function that returns a
10887 -- constrained array type in a SPARK-to-C compilation. In this case
10888 -- the function receives a corresponding procedure which has an out
10889 -- parameter. The proper body for ABE checks and diagnostics is that
10890 -- of the procedure.
10892 if Ekind
(Spec_Id
) = E_Function
10893 and then Rewritten_For_C
(Spec_Id
)
10895 Spec_Id
:= Corresponding_Procedure
(Spec_Id
);
10898 Rec
.Kind
:= Subprogram_Target
;
10900 Spec_And_Body_From_Entity
10902 Body_Decl
=> Rec
.Body_Decl
,
10903 Spec_Decl
=> Rec
.Spec_Decl
);
10906 end Create_Subprogram_Rep
;
10908 -----------------------
10909 -- Create_Target_Rep --
10910 -----------------------
10912 function Create_Target_Rep
10914 In_State
: Processing_In_State
) return Target_Rep_Record
10916 Rec
: Target_Rep_Record
;
10919 if Is_Generic_Unit
(Id
) then
10920 Rec
:= Create_Generic_Rep
(Id
);
10922 elsif Is_Protected_Entry
(Id
) then
10923 Rec
:= Create_Protected_Entry_Rep
(Id
);
10925 elsif Is_Protected_Subp
(Id
) then
10926 Rec
:= Create_Protected_Subprogram_Rep
(Id
);
10928 elsif Is_Task_Entry
(Id
) then
10929 Rec
:= Create_Task_Entry_Rep
(Id
);
10931 elsif Is_Task_Type
(Id
) then
10932 Rec
:= Create_Task_Rep
(Id
);
10934 elsif Ekind
(Id
) in E_Constant | E_Variable
then
10935 Rec
:= Create_Variable_Rep
(Id
);
10937 elsif Ekind
(Id
) in E_Entry | E_Function | E_Operator | E_Procedure
10939 Rec
:= Create_Subprogram_Rep
(Id
);
10941 elsif Ekind
(Id
) = E_Package
then
10942 Rec
:= Create_Package_Rep
(Id
);
10945 pragma Assert
(False);
10949 -- Common target attributes
10951 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Id
(Id
);
10952 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Id
(Id
);
10953 Rec
.GM
:= Ghost_Mode_Of_Entity
(Id
);
10954 Rec
.SM
:= SPARK_Mode_Of_Entity
(Id
);
10955 Rec
.Unit
:= Find_Top_Unit
(Id
);
10956 Rec
.Version
:= In_State
.Representation
;
10959 end Create_Target_Rep
;
10961 ---------------------------
10962 -- Create_Task_Entry_Rep --
10963 ---------------------------
10965 function Create_Task_Entry_Rep
10966 (TE_Id
: Entity_Id
) return Target_Rep_Record
10968 Task_Typ
: constant Entity_Id
:= Non_Private_View
(Scope
(TE_Id
));
10969 Task_Body_Id
: constant Entity_Id
:= Task_Body_Procedure
(Task_Typ
);
10971 Rec
: Target_Rep_Record
;
10972 Spec_Id
: Entity_Id
;
10975 -- The task type has already been expanded, it carries the procedure
10976 -- which emulates the behavior of the task body.
10978 if Present
(Task_Body_Id
) then
10979 Spec_Id
:= Task_Body_Id
;
10981 -- Otherwise no expansion took place
10987 Rec
.Kind
:= Subprogram_Target
;
10989 Spec_And_Body_From_Entity
10991 Body_Decl
=> Rec
.Body_Decl
,
10992 Spec_Decl
=> Rec
.Spec_Decl
);
10995 end Create_Task_Entry_Rep
;
10997 ---------------------
10998 -- Create_Task_Rep --
10999 ---------------------
11001 function Create_Task_Rep
11002 (Task_Typ
: Entity_Id
) return Target_Rep_Record
11004 Task_Body_Id
: constant Entity_Id
:= Task_Body_Procedure
(Task_Typ
);
11006 Rec
: Target_Rep_Record
;
11007 Spec_Id
: Entity_Id
;
11010 -- The task type has already been expanded, it carries the procedure
11011 -- which emulates the behavior of the task body.
11013 if Present
(Task_Body_Id
) then
11014 Spec_Id
:= Task_Body_Id
;
11016 -- Otherwise no expansion took place
11019 Spec_Id
:= Task_Typ
;
11022 Rec
.Kind
:= Task_Target
;
11024 Spec_And_Body_From_Entity
11026 Body_Decl
=> Rec
.Body_Decl
,
11027 Spec_Decl
=> Rec
.Spec_Decl
);
11030 end Create_Task_Rep
;
11032 ------------------------------------
11033 -- Create_Variable_Assignment_Rep --
11034 ------------------------------------
11036 function Create_Variable_Assignment_Rep
11037 (Asmt
: Node_Id
) return Scenario_Rep_Record
11039 Var_Id
: constant Entity_Id
:= Entity
(Assignment_Target
(Asmt
));
11040 Rec
: Scenario_Rep_Record
;
11043 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Asmt
);
11044 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Id
(Var_Id
);
11045 Rec
.GM
:= Ghost_Mode_Of_Node
(Asmt
);
11046 Rec
.SM
:= SPARK_Mode_Of_Node
(Asmt
);
11047 Rec
.Kind
:= Variable_Assignment_Scenario
;
11048 Rec
.Target
:= Var_Id
;
11051 end Create_Variable_Assignment_Rep
;
11053 -----------------------------------
11054 -- Create_Variable_Reference_Rep --
11055 -----------------------------------
11057 function Create_Variable_Reference_Rep
11058 (Ref
: Node_Id
) return Scenario_Rep_Record
11060 Rec
: Scenario_Rep_Record
;
11063 Rec
.Elab_Checks_OK
:= Is_Elaboration_Checks_OK_Node
(Ref
);
11064 Rec
.Elab_Warnings_OK
:= Is_Elaboration_Warnings_OK_Node
(Ref
);
11065 Rec
.GM
:= Ghost_Mode_Of_Node
(Ref
);
11066 Rec
.SM
:= SPARK_Mode_Of_Node
(Ref
);
11067 Rec
.Kind
:= Variable_Reference_Scenario
;
11068 Rec
.Target
:= Target
(Ref
);
11070 -- Scenario-specific attributes
11072 Rec
.Flag_1
:= Is_Read
(Ref
); -- Is_Read_Reference
11075 end Create_Variable_Reference_Rep
;
11077 -------------------------
11078 -- Create_Variable_Rep --
11079 -------------------------
11081 function Create_Variable_Rep
11082 (Var_Id
: Entity_Id
) return Target_Rep_Record
11084 Rec
: Target_Rep_Record
;
11087 Rec
.Kind
:= Variable_Target
;
11089 -- Target-specific attributes
11091 Rec
.Field_1
:= Declaration_Node
(Var_Id
); -- Variable_Declaration
11094 end Create_Variable_Rep
;
11100 procedure Destroy
(S_Id
: in out Scenario_Rep_Id
) is
11101 pragma Unreferenced
(S_Id
);
11110 procedure Destroy
(T_Id
: in out Target_Rep_Id
) is
11111 pragma Unreferenced
(T_Id
);
11116 --------------------------------
11117 -- Disable_Elaboration_Checks --
11118 --------------------------------
11120 procedure Disable_Elaboration_Checks
(S_Id
: Scenario_Rep_Id
) is
11121 pragma Assert
(Present
(S_Id
));
11123 Scenario_Reps
.Table
(S_Id
).Elab_Checks_OK
:= False;
11124 end Disable_Elaboration_Checks
;
11126 --------------------------------
11127 -- Disable_Elaboration_Checks --
11128 --------------------------------
11130 procedure Disable_Elaboration_Checks
(T_Id
: Target_Rep_Id
) is
11131 pragma Assert
(Present
(T_Id
));
11133 Target_Reps
.Table
(T_Id
).Elab_Checks_OK
:= False;
11134 end Disable_Elaboration_Checks
;
11136 ---------------------------
11137 -- Elaboration_Checks_OK --
11138 ---------------------------
11140 function Elaboration_Checks_OK
(S_Id
: Scenario_Rep_Id
) return Boolean is
11141 pragma Assert
(Present
(S_Id
));
11143 return Scenario_Reps
.Table
(S_Id
).Elab_Checks_OK
;
11144 end Elaboration_Checks_OK
;
11146 ---------------------------
11147 -- Elaboration_Checks_OK --
11148 ---------------------------
11150 function Elaboration_Checks_OK
(T_Id
: Target_Rep_Id
) return Boolean is
11151 pragma Assert
(Present
(T_Id
));
11153 return Target_Reps
.Table
(T_Id
).Elab_Checks_OK
;
11154 end Elaboration_Checks_OK
;
11156 -----------------------------
11157 -- Elaboration_Warnings_OK --
11158 -----------------------------
11160 function Elaboration_Warnings_OK
11161 (S_Id
: Scenario_Rep_Id
) return Boolean
11163 pragma Assert
(Present
(S_Id
));
11165 return Scenario_Reps
.Table
(S_Id
).Elab_Warnings_OK
;
11166 end Elaboration_Warnings_OK
;
11168 -----------------------------
11169 -- Elaboration_Warnings_OK --
11170 -----------------------------
11172 function Elaboration_Warnings_OK
(T_Id
: Target_Rep_Id
) return Boolean is
11173 pragma Assert
(Present
(T_Id
));
11175 return Target_Reps
.Table
(T_Id
).Elab_Warnings_OK
;
11176 end Elaboration_Warnings_OK
;
11178 --------------------------------------
11179 -- Finalize_Internal_Representation --
11180 --------------------------------------
11182 procedure Finalize_Internal_Representation
is
11184 ETT_Map
.Destroy
(Entity_To_Target_Map
);
11185 NTS_Map
.Destroy
(Node_To_Scenario_Map
);
11186 end Finalize_Internal_Representation
;
11188 -------------------
11189 -- Ghost_Mode_Of --
11190 -------------------
11192 function Ghost_Mode_Of
11193 (S_Id
: Scenario_Rep_Id
) return Extended_Ghost_Mode
11195 pragma Assert
(Present
(S_Id
));
11197 return Scenario_Reps
.Table
(S_Id
).GM
;
11200 -------------------
11201 -- Ghost_Mode_Of --
11202 -------------------
11204 function Ghost_Mode_Of
11205 (T_Id
: Target_Rep_Id
) return Extended_Ghost_Mode
11207 pragma Assert
(Present
(T_Id
));
11209 return Target_Reps
.Table
(T_Id
).GM
;
11212 --------------------------
11213 -- Ghost_Mode_Of_Entity --
11214 --------------------------
11216 function Ghost_Mode_Of_Entity
11217 (Id
: Entity_Id
) return Extended_Ghost_Mode
11220 return To_Ghost_Mode
(Is_Ignored_Ghost_Entity
(Id
));
11221 end Ghost_Mode_Of_Entity
;
11223 ------------------------
11224 -- Ghost_Mode_Of_Node --
11225 ------------------------
11227 function Ghost_Mode_Of_Node
(N
: Node_Id
) return Extended_Ghost_Mode
is
11229 return To_Ghost_Mode
(Is_Ignored_Ghost_Node
(N
));
11230 end Ghost_Mode_Of_Node
;
11232 ----------------------------------------
11233 -- Initialize_Internal_Representation --
11234 ----------------------------------------
11236 procedure Initialize_Internal_Representation
is
11238 Entity_To_Target_Map
:= ETT_Map
.Create
(500);
11239 Node_To_Scenario_Map
:= NTS_Map
.Create
(500);
11240 end Initialize_Internal_Representation
;
11242 -------------------------
11243 -- Is_Dispatching_Call --
11244 -------------------------
11246 function Is_Dispatching_Call
(S_Id
: Scenario_Rep_Id
) return Boolean is
11247 pragma Assert
(Present
(S_Id
));
11248 pragma Assert
(Kind
(S_Id
) = Call_Scenario
);
11251 return Scenario_Reps
.Table
(S_Id
).Flag_1
;
11252 end Is_Dispatching_Call
;
11254 -----------------------
11255 -- Is_Read_Reference --
11256 -----------------------
11258 function Is_Read_Reference
(S_Id
: Scenario_Rep_Id
) return Boolean is
11259 pragma Assert
(Present
(S_Id
));
11260 pragma Assert
(Kind
(S_Id
) = Variable_Reference_Scenario
);
11263 return Scenario_Reps
.Table
(S_Id
).Flag_1
;
11264 end Is_Read_Reference
;
11270 function Kind
(S_Id
: Scenario_Rep_Id
) return Scenario_Kind
is
11271 pragma Assert
(Present
(S_Id
));
11273 return Scenario_Reps
.Table
(S_Id
).Kind
;
11280 function Kind
(T_Id
: Target_Rep_Id
) return Target_Kind
is
11281 pragma Assert
(Present
(T_Id
));
11283 return Target_Reps
.Table
(T_Id
).Kind
;
11290 function Level
(S_Id
: Scenario_Rep_Id
) return Enclosing_Level_Kind
is
11291 pragma Assert
(Present
(S_Id
));
11293 return Scenario_Reps
.Table
(S_Id
).Level
;
11300 function Present
(S_Id
: Scenario_Rep_Id
) return Boolean is
11302 return S_Id
/= No_Scenario_Rep
;
11309 function Present
(T_Id
: Target_Rep_Id
) return Boolean is
11311 return T_Id
/= No_Target_Rep
;
11314 --------------------------------
11315 -- Scenario_Representation_Of --
11316 --------------------------------
11318 function Scenario_Representation_Of
11320 In_State
: Processing_In_State
) return Scenario_Rep_Id
11322 S_Id
: Scenario_Rep_Id
;
11325 S_Id
:= NTS_Map
.Get
(Node_To_Scenario_Map
, N
);
11327 -- The elaboration scenario lacks a representation. This indicates
11328 -- that the scenario is encountered for the first time. Create the
11329 -- representation of it.
11331 if not Present
(S_Id
) then
11332 Scenario_Reps
.Append
(Create_Scenario_Rep
(N
, In_State
));
11333 S_Id
:= Scenario_Reps
.Last
;
11335 -- Associate the internal representation with the elaboration
11338 NTS_Map
.Put
(Node_To_Scenario_Map
, N
, S_Id
);
11341 pragma Assert
(Present
(S_Id
));
11344 end Scenario_Representation_Of
;
11346 --------------------------------
11347 -- Set_Activated_Task_Objects --
11348 --------------------------------
11350 procedure Set_Activated_Task_Objects
11351 (S_Id
: Scenario_Rep_Id
;
11352 Task_Objs
: NE_List
.Doubly_Linked_List
)
11354 pragma Assert
(Present
(S_Id
));
11355 pragma Assert
(Kind
(S_Id
) = Task_Activation_Scenario
);
11358 Scenario_Reps
.Table
(S_Id
).List_1
:= Task_Objs
;
11359 end Set_Activated_Task_Objects
;
11361 -----------------------------
11362 -- Set_Activated_Task_Type --
11363 -----------------------------
11365 procedure Set_Activated_Task_Type
11366 (S_Id
: Scenario_Rep_Id
;
11367 Task_Typ
: Entity_Id
)
11369 pragma Assert
(Present
(S_Id
));
11370 pragma Assert
(Kind
(S_Id
) = Task_Activation_Scenario
);
11373 Scenario_Reps
.Table
(S_Id
).Field_1
:= Task_Typ
;
11374 end Set_Activated_Task_Type
;
11376 -------------------
11377 -- SPARK_Mode_Of --
11378 -------------------
11380 function SPARK_Mode_Of
11381 (S_Id
: Scenario_Rep_Id
) return Extended_SPARK_Mode
11383 pragma Assert
(Present
(S_Id
));
11385 return Scenario_Reps
.Table
(S_Id
).SM
;
11388 -------------------
11389 -- SPARK_Mode_Of --
11390 -------------------
11392 function SPARK_Mode_Of
11393 (T_Id
: Target_Rep_Id
) return Extended_SPARK_Mode
11395 pragma Assert
(Present
(T_Id
));
11397 return Target_Reps
.Table
(T_Id
).SM
;
11400 --------------------------
11401 -- SPARK_Mode_Of_Entity --
11402 --------------------------
11404 function SPARK_Mode_Of_Entity
11405 (Id
: Entity_Id
) return Extended_SPARK_Mode
11407 Prag
: constant Node_Id
:= SPARK_Pragma
(Id
);
11413 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
);
11414 end SPARK_Mode_Of_Entity
;
11416 ------------------------
11417 -- SPARK_Mode_Of_Node --
11418 ------------------------
11420 function SPARK_Mode_Of_Node
(N
: Node_Id
) return Extended_SPARK_Mode
is
11422 return To_SPARK_Mode
(Is_SPARK_Mode_On_Node
(N
));
11423 end SPARK_Mode_Of_Node
;
11425 ----------------------
11426 -- Spec_Declaration --
11427 ----------------------
11429 function Spec_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
is
11430 pragma Assert
(Present
(T_Id
));
11432 return Target_Reps
.Table
(T_Id
).Spec_Decl
;
11433 end Spec_Declaration
;
11439 function Target
(S_Id
: Scenario_Rep_Id
) return Entity_Id
is
11440 pragma Assert
(Present
(S_Id
));
11442 return Scenario_Reps
.Table
(S_Id
).Target
;
11445 ------------------------------
11446 -- Target_Representation_Of --
11447 ------------------------------
11449 function Target_Representation_Of
11451 In_State
: Processing_In_State
) return Target_Rep_Id
11453 T_Id
: Target_Rep_Id
;
11456 T_Id
:= ETT_Map
.Get
(Entity_To_Target_Map
, Id
);
11458 -- The elaboration target lacks an internal representation. This
11459 -- indicates that the target is encountered for the first time.
11460 -- Create the internal representation of it.
11462 if not Present
(T_Id
) then
11463 Target_Reps
.Append
(Create_Target_Rep
(Id
, In_State
));
11464 T_Id
:= Target_Reps
.Last
;
11466 -- Associate the internal representation with the elaboration
11469 ETT_Map
.Put
(Entity_To_Target_Map
, Id
, T_Id
);
11471 -- The Processing phase is working with a partially analyzed tree,
11472 -- where various attributes become available as analysis continues.
11473 -- This case arrises in the context of guaranteed ABE processing.
11474 -- Update the existing representation by including new attributes.
11476 elsif In_State
.Representation
= Inconsistent_Representation
then
11477 Target_Reps
.Table
(T_Id
) := Create_Target_Rep
(Id
, In_State
);
11479 -- Otherwise the Processing phase imposes a particular representation
11480 -- version which is not satisfied by the target. This case arrises
11481 -- when the Processing phase switches from guaranteed ABE checks and
11482 -- diagnostics to some other mode of operation. Update the existing
11483 -- representation to include all attributes.
11485 elsif In_State
.Representation
/= Version
(T_Id
) then
11486 Target_Reps
.Table
(T_Id
) := Create_Target_Rep
(Id
, In_State
);
11489 pragma Assert
(Present
(T_Id
));
11492 end Target_Representation_Of
;
11494 -------------------
11495 -- To_Ghost_Mode --
11496 -------------------
11498 function To_Ghost_Mode
11499 (Ignored_Status
: Boolean) return Extended_Ghost_Mode
11502 if Ignored_Status
then
11505 return Is_Checked_Or_Not_Specified
;
11509 -------------------
11510 -- To_SPARK_Mode --
11511 -------------------
11513 function To_SPARK_Mode
11514 (On_Status
: Boolean) return Extended_SPARK_Mode
11520 return Is_Off_Or_Not_Specified
;
11528 function Unit
(T_Id
: Target_Rep_Id
) return Entity_Id
is
11529 pragma Assert
(Present
(T_Id
));
11531 return Target_Reps
.Table
(T_Id
).Unit
;
11534 --------------------------
11535 -- Variable_Declaration --
11536 --------------------------
11538 function Variable_Declaration
(T_Id
: Target_Rep_Id
) return Node_Id
is
11539 pragma Assert
(Present
(T_Id
));
11540 pragma Assert
(Kind
(T_Id
) = Variable_Target
);
11543 return Target_Reps
.Table
(T_Id
).Field_1
;
11544 end Variable_Declaration
;
11550 function Version
(T_Id
: Target_Rep_Id
) return Representation_Kind
is
11551 pragma Assert
(Present
(T_Id
));
11553 return Target_Reps
.Table
(T_Id
).Version
;
11555 end Internal_Representation
;
11557 ----------------------
11558 -- Invocation_Graph --
11559 ----------------------
11561 package body Invocation_Graph
is
11567 -- The following type represents simplified version of an invocation
11570 type Invoker_Target_Relation
is record
11571 Invoker
: Entity_Id
:= Empty
;
11572 Target
: Entity_Id
:= Empty
;
11575 -- The following variables define the entities of the dummy elaboration
11576 -- procedures used as origins of library level paths.
11578 Elab_Body_Id
: Entity_Id
:= Empty
;
11579 Elab_Spec_Id
: Entity_Id
:= Empty
;
11581 ---------------------
11582 -- Data structures --
11583 ---------------------
11585 -- The following set contains all declared invocation constructs. It
11586 -- ensures that the same construct is not declared multiple times in
11587 -- the ALI file of the main unit.
11589 Saved_Constructs_Set
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
11591 function Hash
(Key
: Invoker_Target_Relation
) return Bucket_Range_Type
;
11592 -- Obtain the hash value of pair Key
11594 package IR_Set
is new Membership_Sets
11595 (Element_Type
=> Invoker_Target_Relation
,
11599 -- The following set contains all recorded simple invocation relations.
11600 -- It ensures that multiple relations involving the same invoker and
11601 -- target do not appear in the ALI file of the main unit.
11603 Saved_Relations_Set
: IR_Set
.Membership_Set
:= IR_Set
.Nil
;
11609 function Signature_Of
(Id
: Entity_Id
) return Invocation_Signature_Id
;
11610 pragma Inline
(Signature_Of
);
11611 -- Obtain the invication signature id of arbitrary entity Id
11613 -----------------------
11614 -- Local subprograms --
11615 -----------------------
11617 procedure Build_Elaborate_Body_Procedure
;
11618 pragma Inline
(Build_Elaborate_Body_Procedure
);
11619 -- Create a dummy elaborate body procedure and store its entity in
11622 procedure Build_Elaborate_Procedure
11623 (Proc_Id
: out Entity_Id
;
11624 Proc_Nam
: Name_Id
;
11626 pragma Inline
(Build_Elaborate_Procedure
);
11627 -- Create a dummy elaborate procedure with name Proc_Nam and source
11628 -- location Loc. The entity is returned in Proc_Id.
11630 procedure Build_Elaborate_Spec_Procedure
;
11631 pragma Inline
(Build_Elaborate_Spec_Procedure
);
11632 -- Create a dummy elaborate spec procedure and store its entity in
11635 function Build_Subprogram_Invocation
11636 (Subp_Id
: Entity_Id
) return Node_Id
;
11637 pragma Inline
(Build_Subprogram_Invocation
);
11638 -- Create a dummy call marker that invokes subprogram Subp_Id
11640 function Build_Task_Activation
11641 (Task_Typ
: Entity_Id
;
11642 In_State
: Processing_In_State
) return Node_Id
;
11643 pragma Inline
(Build_Task_Activation
);
11644 -- Create a dummy call marker that activates an anonymous task object of
11647 procedure Declare_Invocation_Construct
11648 (Constr_Id
: Entity_Id
;
11649 In_State
: Processing_In_State
);
11650 pragma Inline
(Declare_Invocation_Construct
);
11651 -- Declare invocation construct Constr_Id by creating a declaration for
11652 -- it in the ALI file of the main unit. In_State is the current state of
11653 -- the Processing phase.
11655 function Invocation_Graph_Recording_OK
return Boolean;
11656 pragma Inline
(Invocation_Graph_Recording_OK
);
11657 -- Determine whether the invocation graph can be recorded
11659 function Is_Invocation_Scenario
(N
: Node_Id
) return Boolean;
11660 pragma Inline
(Is_Invocation_Scenario
);
11661 -- Determine whether node N is a suitable scenario for invocation graph
11662 -- recording purposes.
11664 function Is_Invocation_Target
(Id
: Entity_Id
) return Boolean;
11665 pragma Inline
(Is_Invocation_Target
);
11666 -- Determine whether arbitrary entity Id denotes an invocation target
11668 function Is_Saved_Construct
(Constr
: Entity_Id
) return Boolean;
11669 pragma Inline
(Is_Saved_Construct
);
11670 -- Determine whether invocation construct Constr has already been
11671 -- declared in the ALI file of the main unit.
11673 function Is_Saved_Relation
11674 (Rel
: Invoker_Target_Relation
) return Boolean;
11675 pragma Inline
(Is_Saved_Relation
);
11676 -- Determine whether simple invocation relation Rel has already been
11677 -- recorded in the ALI file of the main unit.
11679 procedure Process_Declarations
11681 In_State
: Processing_In_State
);
11682 pragma Inline
(Process_Declarations
);
11683 -- Process declaration list Decls by processing all invocation scenarios
11686 procedure Process_Freeze_Node
11688 In_State
: Processing_In_State
);
11689 pragma Inline
(Process_Freeze_Node
);
11690 -- Process freeze node Fnode by processing all invocation scenarios in
11691 -- its Actions list.
11693 procedure Process_Invocation_Activation
11695 Call_Rep
: Scenario_Rep_Id
;
11696 Obj_Id
: Entity_Id
;
11697 Obj_Rep
: Target_Rep_Id
;
11698 Task_Typ
: Entity_Id
;
11699 Task_Rep
: Target_Rep_Id
;
11700 In_State
: Processing_In_State
);
11701 pragma Inline
(Process_Invocation_Activation
);
11702 -- Process activation call Call which activates object Obj_Id of task
11703 -- type Task_Typ by processing all invocation scenarios within the task
11704 -- body. Call_Rep is the representation of the call. Obj_Rep denotes the
11705 -- representation of the object. Task_Rep is the representation of the
11706 -- task type. In_State is the current state of the Processing phase.
11708 procedure Process_Invocation_Body_Scenarios
;
11709 pragma Inline
(Process_Invocation_Body_Scenarios
);
11710 -- Process all library level body scenarios
11712 procedure Process_Invocation_Call
11714 Call_Rep
: Scenario_Rep_Id
;
11715 In_State
: Processing_In_State
);
11716 pragma Inline
(Process_Invocation_Call
);
11717 -- Process invocation call scenario Call with representation Call_Rep.
11718 -- In_State is the current state of the Processing phase.
11720 procedure Process_Invocation_Instantiation
11722 Inst_Rep
: Scenario_Rep_Id
;
11723 In_State
: Processing_In_State
);
11724 pragma Inline
(Process_Invocation_Instantiation
);
11725 -- Process invocation instantiation scenario Inst with representation
11726 -- Inst_Rep. In_State is the current state of the Processing phase.
11728 procedure Process_Invocation_Scenario
11730 In_State
: Processing_In_State
);
11731 pragma Inline
(Process_Invocation_Scenario
);
11732 -- Process single invocation scenario N. In_State is the current state
11733 -- of the Processing phase.
11735 procedure Process_Invocation_Scenarios
11736 (Iter
: in out NE_Set
.Iterator
;
11737 In_State
: Processing_In_State
);
11738 pragma Inline
(Process_Invocation_Scenarios
);
11739 -- Process all invocation scenarios obtained via iterator Iter. In_State
11740 -- is the current state of the Processing phase.
11742 procedure Process_Invocation_Spec_Scenarios
;
11743 pragma Inline
(Process_Invocation_Spec_Scenarios
);
11744 -- Process all library level spec scenarios
11746 procedure Process_Main_Unit
;
11747 pragma Inline
(Process_Main_Unit
);
11748 -- Process all invocation scenarios within the main unit
11750 procedure Process_Package_Declaration
11751 (Pack_Decl
: Node_Id
;
11752 In_State
: Processing_In_State
);
11753 pragma Inline
(Process_Package_Declaration
);
11754 -- Process package declaration Pack_Decl by processing all invocation
11755 -- scenarios in its visible and private declarations. If the main unit
11756 -- contains a generic, the declarations of the body are also examined.
11757 -- In_State is the current state of the Processing phase.
11759 procedure Process_Protected_Type_Declaration
11760 (Prot_Decl
: Node_Id
;
11761 In_State
: Processing_In_State
);
11762 pragma Inline
(Process_Protected_Type_Declaration
);
11763 -- Process the declarations of protected type Prot_Decl. In_State is the
11764 -- current state of the Processing phase.
11766 procedure Process_Subprogram_Declaration
11767 (Subp_Decl
: Node_Id
;
11768 In_State
: Processing_In_State
);
11769 pragma Inline
(Process_Subprogram_Declaration
);
11770 -- Process subprogram declaration Subp_Decl by processing all invocation
11771 -- scenarios within its body. In_State denotes the current state of the
11772 -- Processing phase.
11774 procedure Process_Subprogram_Instantiation
11776 In_State
: Processing_In_State
);
11777 pragma Inline
(Process_Subprogram_Instantiation
);
11778 -- Process subprogram instantiation Inst. In_State is the current state
11779 -- of the Processing phase.
11781 procedure Process_Task_Type_Declaration
11782 (Task_Decl
: Node_Id
;
11783 In_State
: Processing_In_State
);
11784 pragma Inline
(Process_Task_Type_Declaration
);
11785 -- Process task declaration Task_Decl by processing all invocation
11786 -- scenarios within its body. In_State is the current state of the
11787 -- Processing phase.
11789 procedure Record_Full_Invocation_Path
(In_State
: Processing_In_State
);
11790 pragma Inline
(Record_Full_Invocation_Path
);
11791 -- Record all relations between scenario pairs found in the stack of
11792 -- active scenarios. In_State is the current state of the Processing
11795 procedure Record_Invocation_Graph_Encoding
;
11796 pragma Inline
(Record_Invocation_Graph_Encoding
);
11797 -- Record the encoding format used to capture information related to
11798 -- invocation constructs and relations.
11800 procedure Record_Invocation_Path
(In_State
: Processing_In_State
);
11801 pragma Inline
(Record_Invocation_Path
);
11802 -- Record the invocation relations found within the path represented in
11803 -- the active scenario stack. In_State denotes the current state of the
11804 -- Processing phase.
11806 procedure Record_Simple_Invocation_Path
(In_State
: Processing_In_State
);
11807 pragma Inline
(Record_Simple_Invocation_Path
);
11808 -- Record a single relation from the start to the end of the stack of
11809 -- active scenarios. In_State is the current state of the Processing
11812 procedure Record_Invocation_Relation
11813 (Invk_Id
: Entity_Id
;
11814 Targ_Id
: Entity_Id
;
11815 In_State
: Processing_In_State
);
11816 pragma Inline
(Record_Invocation_Relation
);
11817 -- Record an invocation relation with invoker Invk_Id and target Targ_Id
11818 -- by creating an entry for it in the ALI file of the main unit. Formal
11819 -- In_State denotes the current state of the Processing phase.
11821 procedure Set_Is_Saved_Construct
(Constr
: Entity_Id
);
11822 pragma Inline
(Set_Is_Saved_Construct
);
11823 -- Mark invocation construct Constr as declared in the ALI file of the
11826 procedure Set_Is_Saved_Relation
(Rel
: Invoker_Target_Relation
);
11827 pragma Inline
(Set_Is_Saved_Relation
);
11828 -- Mark simple invocation relation Rel as recorded in the ALI file of
11832 (Pos
: Active_Scenario_Pos
;
11833 In_State
: Processing_In_State
) return Entity_Id
;
11834 pragma Inline
(Target_Of
);
11835 -- Given position within the active scenario stack Pos, obtain the
11836 -- target of the indicated scenario. In_State is the current state
11837 -- of the Processing phase.
11839 procedure Traverse_Invocation_Body
11841 In_State
: Processing_In_State
);
11842 pragma Inline
(Traverse_Invocation_Body
);
11843 -- Traverse subprogram body N looking for suitable invocation scenarios
11844 -- that need to be processed for invocation graph recording purposes.
11845 -- In_State is the current state of the Processing phase.
11847 procedure Write_Invocation_Path
(In_State
: Processing_In_State
);
11848 pragma Inline
(Write_Invocation_Path
);
11849 -- Write out a path represented by the active scenario on the stack to
11850 -- standard output. In_State denotes the current state of the Processing
11853 ------------------------------------
11854 -- Build_Elaborate_Body_Procedure --
11855 ------------------------------------
11857 procedure Build_Elaborate_Body_Procedure
is
11858 Body_Decl
: Node_Id
;
11859 Spec_Decl
: Node_Id
;
11862 -- Nothing to do when a previous call already created the procedure
11864 if Present
(Elab_Body_Id
) then
11868 Spec_And_Body_From_Entity
11869 (Id
=> Main_Unit_Entity
,
11870 Body_Decl
=> Body_Decl
,
11871 Spec_Decl
=> Spec_Decl
);
11873 pragma Assert
(Present
(Body_Decl
));
11875 Build_Elaborate_Procedure
11876 (Proc_Id
=> Elab_Body_Id
,
11877 Proc_Nam
=> Name_B
,
11878 Loc
=> Sloc
(Body_Decl
));
11879 end Build_Elaborate_Body_Procedure
;
11881 -------------------------------
11882 -- Build_Elaborate_Procedure --
11883 -------------------------------
11885 procedure Build_Elaborate_Procedure
11886 (Proc_Id
: out Entity_Id
;
11887 Proc_Nam
: Name_Id
;
11890 Proc_Decl
: Node_Id
;
11891 pragma Unreferenced
(Proc_Decl
);
11894 Proc_Id
:= Make_Defining_Identifier
(Loc
, Proc_Nam
);
11896 -- Partially decorate the elaboration procedure because it will not
11897 -- be insertred into the tree and analyzed.
11899 Mutate_Ekind
(Proc_Id
, E_Procedure
);
11900 Set_Etype
(Proc_Id
, Standard_Void_Type
);
11901 Set_Scope
(Proc_Id
, Unique_Entity
(Main_Unit_Entity
));
11903 -- Create a dummy declaration for the elaboration procedure. The
11904 -- declaration does not need to be syntactically legal, but must
11905 -- carry an accurate source location.
11908 Make_Subprogram_Body
(Loc
,
11910 Make_Procedure_Specification
(Loc
,
11911 Defining_Unit_Name
=> Proc_Id
),
11912 Declarations
=> No_List
,
11913 Handled_Statement_Sequence
=> Empty
);
11914 end Build_Elaborate_Procedure
;
11916 ------------------------------------
11917 -- Build_Elaborate_Spec_Procedure --
11918 ------------------------------------
11920 procedure Build_Elaborate_Spec_Procedure
is
11921 Body_Decl
: Node_Id
;
11922 Spec_Decl
: Node_Id
;
11925 -- Nothing to do when a previous call already created the procedure
11927 if Present
(Elab_Spec_Id
) then
11931 Spec_And_Body_From_Entity
11932 (Id
=> Main_Unit_Entity
,
11933 Body_Decl
=> Body_Decl
,
11934 Spec_Decl
=> Spec_Decl
);
11936 pragma Assert
(Present
(Spec_Decl
));
11938 Build_Elaborate_Procedure
11939 (Proc_Id
=> Elab_Spec_Id
,
11940 Proc_Nam
=> Name_S
,
11941 Loc
=> Sloc
(Spec_Decl
));
11942 end Build_Elaborate_Spec_Procedure
;
11944 ---------------------------------
11945 -- Build_Subprogram_Invocation --
11946 ---------------------------------
11948 function Build_Subprogram_Invocation
11949 (Subp_Id
: Entity_Id
) return Node_Id
11951 Marker
: constant Node_Id
:= Make_Call_Marker
(Sloc
(Subp_Id
));
11952 Subp_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp_Id
);
11955 -- Create a dummy call marker which invokes the subprogram
11957 Set_Is_Declaration_Level_Node
(Marker
, False);
11958 Set_Is_Dispatching_Call
(Marker
, False);
11959 Set_Is_Elaboration_Checks_OK_Node
(Marker
, False);
11960 Set_Is_Elaboration_Warnings_OK_Node
(Marker
, False);
11961 Set_Is_Ignored_Ghost_Node
(Marker
, False);
11962 Set_Is_Preelaborable_Call
(Marker
, False);
11963 Set_Is_Source_Call
(Marker
, False);
11964 Set_Is_SPARK_Mode_On_Node
(Marker
, False);
11966 -- Invoke the uniform canonical entity of the subprogram
11968 Set_Target
(Marker
, Canonical_Subprogram
(Subp_Id
));
11970 -- Partially insert the marker into the tree
11972 Set_Parent
(Marker
, Parent
(Subp_Decl
));
11975 end Build_Subprogram_Invocation
;
11977 ---------------------------
11978 -- Build_Task_Activation --
11979 ---------------------------
11981 function Build_Task_Activation
11982 (Task_Typ
: Entity_Id
;
11983 In_State
: Processing_In_State
) return Node_Id
11985 Loc
: constant Source_Ptr
:= Sloc
(Task_Typ
);
11986 Marker
: constant Node_Id
:= Make_Call_Marker
(Loc
);
11987 Task_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Task_Typ
);
11989 Activ_Id
: Entity_Id
;
11990 Marker_Rep_Id
: Scenario_Rep_Id
;
11991 Task_Obj
: Entity_Id
;
11992 Task_Objs
: NE_List
.Doubly_Linked_List
;
11995 -- Create a dummy call marker which activates some tasks
11997 Set_Is_Declaration_Level_Node
(Marker
, False);
11998 Set_Is_Dispatching_Call
(Marker
, False);
11999 Set_Is_Elaboration_Checks_OK_Node
(Marker
, False);
12000 Set_Is_Elaboration_Warnings_OK_Node
(Marker
, False);
12001 Set_Is_Ignored_Ghost_Node
(Marker
, False);
12002 Set_Is_Preelaborable_Call
(Marker
, False);
12003 Set_Is_Source_Call
(Marker
, False);
12004 Set_Is_SPARK_Mode_On_Node
(Marker
, False);
12006 -- Invoke the appropriate version of Activate_Tasks
12008 if Restricted_Profile
then
12009 Activ_Id
:= RTE
(RE_Activate_Restricted_Tasks
);
12011 Activ_Id
:= RTE
(RE_Activate_Tasks
);
12014 Set_Target
(Marker
, Activ_Id
);
12016 -- Partially insert the marker into the tree
12018 Set_Parent
(Marker
, Parent
(Task_Decl
));
12020 -- Create a dummy task object. Partially decorate the object because
12021 -- it will not be inserted into the tree and analyzed.
12023 Task_Obj
:= Make_Temporary
(Loc
, 'T');
12024 Mutate_Ekind
(Task_Obj
, E_Variable
);
12025 Set_Etype
(Task_Obj
, Task_Typ
);
12027 -- Associate the dummy task object with the activation call
12029 Task_Objs
:= NE_List
.Create
;
12030 NE_List
.Append
(Task_Objs
, Task_Obj
);
12032 Marker_Rep_Id
:= Scenario_Representation_Of
(Marker
, In_State
);
12033 Set_Activated_Task_Objects
(Marker_Rep_Id
, Task_Objs
);
12034 Set_Activated_Task_Type
(Marker_Rep_Id
, Task_Typ
);
12037 end Build_Task_Activation
;
12039 ----------------------------------
12040 -- Declare_Invocation_Construct --
12041 ----------------------------------
12043 procedure Declare_Invocation_Construct
12044 (Constr_Id
: Entity_Id
;
12045 In_State
: Processing_In_State
)
12047 function Body_Placement_Of
12048 (Id
: Entity_Id
) return Declaration_Placement_Kind
;
12049 pragma Inline
(Body_Placement_Of
);
12050 -- Obtain the placement of arbitrary entity Id's body
12052 function Declaration_Placement_Of_Node
12053 (N
: Node_Id
) return Declaration_Placement_Kind
;
12054 pragma Inline
(Declaration_Placement_Of_Node
);
12055 -- Obtain the placement of arbitrary node N
12057 function Kind_Of
(Id
: Entity_Id
) return Invocation_Construct_Kind
;
12058 pragma Inline
(Kind_Of
);
12059 -- Obtain the invocation construct kind of arbitrary entity Id
12061 function Spec_Placement_Of
12062 (Id
: Entity_Id
) return Declaration_Placement_Kind
;
12063 pragma Inline
(Spec_Placement_Of
);
12064 -- Obtain the placement of arbitrary entity Id's spec
12066 -----------------------
12067 -- Body_Placement_Of --
12068 -----------------------
12070 function Body_Placement_Of
12071 (Id
: Entity_Id
) return Declaration_Placement_Kind
12073 Id_Rep
: constant Target_Rep_Id
:=
12074 Target_Representation_Of
(Id
, In_State
);
12075 Body_Decl
: constant Node_Id
:= Body_Declaration
(Id_Rep
);
12076 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Id_Rep
);
12079 -- The entity has a body
12081 if Present
(Body_Decl
) then
12082 return Declaration_Placement_Of_Node
(Body_Decl
);
12084 -- Otherwise the entity must have a spec
12087 pragma Assert
(Present
(Spec_Decl
));
12088 return Declaration_Placement_Of_Node
(Spec_Decl
);
12090 end Body_Placement_Of
;
12092 -----------------------------------
12093 -- Declaration_Placement_Of_Node --
12094 -----------------------------------
12096 function Declaration_Placement_Of_Node
12097 (N
: Node_Id
) return Declaration_Placement_Kind
12099 Main_Unit_Id
: constant Entity_Id
:= Main_Unit_Entity
;
12100 N_Unit_Id
: constant Entity_Id
:= Find_Top_Unit
(N
);
12103 -- The node is in the main unit, its placement depends on the main
12106 if N_Unit_Id
= Main_Unit_Id
then
12108 -- The main unit is a body
12110 if Ekind
(Main_Unit_Id
) in E_Package_Body | E_Subprogram_Body
12114 -- The main unit is a stand-alone subprogram body
12116 elsif Ekind
(Main_Unit_Id
) in E_Function | E_Procedure
12117 and then Nkind
(Unit_Declaration_Node
(Main_Unit_Id
)) =
12122 -- Otherwise the main unit is a spec
12128 -- Otherwise the node is in the complementary unit of the main
12129 -- unit. The main unit is a body, the node is in the spec.
12131 elsif Ekind
(Main_Unit_Id
) in E_Package_Body | E_Subprogram_Body
12135 -- The main unit is a spec, the node is in the body
12140 end Declaration_Placement_Of_Node
;
12146 function Kind_Of
(Id
: Entity_Id
) return Invocation_Construct_Kind
is
12148 if Id
= Elab_Body_Id
then
12149 return Elaborate_Body_Procedure
;
12151 elsif Id
= Elab_Spec_Id
then
12152 return Elaborate_Spec_Procedure
;
12155 return Regular_Construct
;
12159 -----------------------
12160 -- Spec_Placement_Of --
12161 -----------------------
12163 function Spec_Placement_Of
12164 (Id
: Entity_Id
) return Declaration_Placement_Kind
12166 Id_Rep
: constant Target_Rep_Id
:=
12167 Target_Representation_Of
(Id
, In_State
);
12168 Body_Decl
: constant Node_Id
:= Body_Declaration
(Id_Rep
);
12169 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Id_Rep
);
12172 -- The entity has a spec
12174 if Present
(Spec_Decl
) then
12175 return Declaration_Placement_Of_Node
(Spec_Decl
);
12177 -- Otherwise the entity must have a body
12180 pragma Assert
(Present
(Body_Decl
));
12181 return Declaration_Placement_Of_Node
(Body_Decl
);
12183 end Spec_Placement_Of
;
12185 -- Start of processing for Declare_Invocation_Construct
12188 -- Nothing to do when the construct has already been declared in the
12191 if Is_Saved_Construct
(Constr_Id
) then
12195 -- Mark the construct as declared in the ALI file
12197 Set_Is_Saved_Construct
(Constr_Id
);
12199 -- Add the construct in the ALI file
12201 Add_Invocation_Construct
12202 (Body_Placement
=> Body_Placement_Of
(Constr_Id
),
12203 Kind
=> Kind_Of
(Constr_Id
),
12204 Signature
=> Signature_Of
(Constr_Id
),
12205 Spec_Placement
=> Spec_Placement_Of
(Constr_Id
),
12206 Update_Units
=> False);
12207 end Declare_Invocation_Construct
;
12209 -------------------------------
12210 -- Finalize_Invocation_Graph --
12211 -------------------------------
12213 procedure Finalize_Invocation_Graph
is
12215 NE_Set
.Destroy
(Saved_Constructs_Set
);
12216 IR_Set
.Destroy
(Saved_Relations_Set
);
12217 end Finalize_Invocation_Graph
;
12223 function Hash
(Key
: Invoker_Target_Relation
) return Bucket_Range_Type
is
12224 pragma Assert
(Present
(Key
.Invoker
));
12225 pragma Assert
(Present
(Key
.Target
));
12230 (Bucket_Range_Type
(Key
.Invoker
),
12231 Bucket_Range_Type
(Key
.Target
));
12234 ---------------------------------
12235 -- Initialize_Invocation_Graph --
12236 ---------------------------------
12238 procedure Initialize_Invocation_Graph
is
12240 Saved_Constructs_Set
:= NE_Set
.Create
(100);
12241 Saved_Relations_Set
:= IR_Set
.Create
(200);
12242 end Initialize_Invocation_Graph
;
12244 -----------------------------------
12245 -- Invocation_Graph_Recording_OK --
12246 -----------------------------------
12248 function Invocation_Graph_Recording_OK
return Boolean is
12249 Main_Cunit
: constant Node_Id
:= Cunit
(Main_Unit
);
12252 -- Nothing to do when compiling for GNATprove because the invocation
12253 -- graph is not needed.
12255 if GNATprove_Mode
then
12258 -- Nothing to do when the compilation will not produce an ALI file
12260 elsif Serious_Errors_Detected
> 0 then
12263 -- Nothing to do when the main unit requires a body. Processing the
12264 -- completing body will create the ALI file for the unit and record
12265 -- the invocation graph.
12267 elsif Body_Required
(Main_Cunit
) then
12272 end Invocation_Graph_Recording_OK
;
12274 ----------------------------
12275 -- Is_Invocation_Scenario --
12276 ----------------------------
12278 function Is_Invocation_Scenario
(N
: Node_Id
) return Boolean is
12281 Is_Suitable_Access_Taken
(N
)
12282 or else Is_Suitable_Call
(N
)
12283 or else Is_Suitable_Instantiation
(N
);
12284 end Is_Invocation_Scenario
;
12286 --------------------------
12287 -- Is_Invocation_Target --
12288 --------------------------
12290 function Is_Invocation_Target
(Id
: Entity_Id
) return Boolean is
12292 -- To qualify, the entity must either come from source, or denote an
12293 -- Ada, bridge, or SPARK target.
12296 Comes_From_Source
(Id
)
12297 or else Is_Ada_Semantic_Target
(Id
)
12298 or else Is_Bridge_Target
(Id
)
12299 or else Is_SPARK_Semantic_Target
(Id
);
12300 end Is_Invocation_Target
;
12302 ------------------------
12303 -- Is_Saved_Construct --
12304 ------------------------
12306 function Is_Saved_Construct
(Constr
: Entity_Id
) return Boolean is
12307 pragma Assert
(Present
(Constr
));
12309 return NE_Set
.Contains
(Saved_Constructs_Set
, Constr
);
12310 end Is_Saved_Construct
;
12312 -----------------------
12313 -- Is_Saved_Relation --
12314 -----------------------
12316 function Is_Saved_Relation
12317 (Rel
: Invoker_Target_Relation
) return Boolean
12319 pragma Assert
(Present
(Rel
.Invoker
));
12320 pragma Assert
(Present
(Rel
.Target
));
12323 return IR_Set
.Contains
(Saved_Relations_Set
, Rel
);
12324 end Is_Saved_Relation
;
12326 --------------------------
12327 -- Process_Declarations --
12328 --------------------------
12330 procedure Process_Declarations
12332 In_State
: Processing_In_State
)
12337 Decl
:= First
(Decls
);
12338 while Present
(Decl
) loop
12342 if Nkind
(Decl
) = N_Freeze_Entity
then
12343 Process_Freeze_Node
12345 In_State
=> In_State
);
12347 -- Package (nested)
12349 elsif Nkind
(Decl
) = N_Package_Declaration
then
12350 Process_Package_Declaration
12351 (Pack_Decl
=> Decl
,
12352 In_State
=> In_State
);
12356 elsif Nkind
(Decl
) in N_Protected_Type_Declaration
12357 | N_Single_Protected_Declaration
12359 Process_Protected_Type_Declaration
12360 (Prot_Decl
=> Decl
,
12361 In_State
=> In_State
);
12363 -- Subprogram or entry
12365 elsif Nkind
(Decl
) in N_Entry_Declaration
12366 | N_Subprogram_Declaration
12368 Process_Subprogram_Declaration
12369 (Subp_Decl
=> Decl
,
12370 In_State
=> In_State
);
12372 -- Subprogram body (stand alone)
12374 elsif Nkind
(Decl
) = N_Subprogram_Body
12375 and then No
(Corresponding_Spec
(Decl
))
12377 Process_Subprogram_Declaration
12378 (Subp_Decl
=> Decl
,
12379 In_State
=> In_State
);
12381 -- Subprogram instantiation
12383 elsif Nkind
(Decl
) in N_Subprogram_Instantiation
then
12384 Process_Subprogram_Instantiation
12386 In_State
=> In_State
);
12390 elsif Nkind
(Decl
) in N_Single_Task_Declaration
12391 | N_Task_Type_Declaration
12393 Process_Task_Type_Declaration
12394 (Task_Decl
=> Decl
,
12395 In_State
=> In_State
);
12397 -- Task type (derived)
12399 elsif Nkind
(Decl
) = N_Full_Type_Declaration
12400 and then Is_Task_Type
(Defining_Entity
(Decl
))
12402 Process_Task_Type_Declaration
12403 (Task_Decl
=> Decl
,
12404 In_State
=> In_State
);
12409 end Process_Declarations
;
12411 -------------------------
12412 -- Process_Freeze_Node --
12413 -------------------------
12415 procedure Process_Freeze_Node
12417 In_State
: Processing_In_State
)
12420 Process_Declarations
12421 (Decls
=> Actions
(Fnode
),
12422 In_State
=> In_State
);
12423 end Process_Freeze_Node
;
12425 -----------------------------------
12426 -- Process_Invocation_Activation --
12427 -----------------------------------
12429 procedure Process_Invocation_Activation
12431 Call_Rep
: Scenario_Rep_Id
;
12432 Obj_Id
: Entity_Id
;
12433 Obj_Rep
: Target_Rep_Id
;
12434 Task_Typ
: Entity_Id
;
12435 Task_Rep
: Target_Rep_Id
;
12436 In_State
: Processing_In_State
)
12438 pragma Unreferenced
(Call
);
12439 pragma Unreferenced
(Call_Rep
);
12440 pragma Unreferenced
(Obj_Id
);
12441 pragma Unreferenced
(Obj_Rep
);
12444 -- Nothing to do when the task type appears within an internal unit
12446 if In_Internal_Unit
(Task_Typ
) then
12450 -- The task type being activated is within the main unit. Extend the
12451 -- DFS traversal into its body.
12453 if In_Extended_Main_Code_Unit
(Task_Typ
) then
12454 Traverse_Invocation_Body
12455 (N
=> Body_Declaration
(Task_Rep
),
12456 In_State
=> In_State
);
12458 -- The task type being activated resides within an external unit
12460 -- Main unit External unit
12461 -- +-----------+ +-------------+
12463 -- | Start ------------> Task_Typ |
12465 -- +-----------+ +-------------+
12467 -- Record the invocation path which originates from Start and reaches
12471 Record_Invocation_Path
(In_State
);
12473 end Process_Invocation_Activation
;
12475 ---------------------------------------
12476 -- Process_Invocation_Body_Scenarios --
12477 ---------------------------------------
12479 procedure Process_Invocation_Body_Scenarios
is
12480 Iter
: NE_Set
.Iterator
:= Iterate_Library_Body_Scenarios
;
12482 Process_Invocation_Scenarios
12484 In_State
=> Invocation_Body_State
);
12485 end Process_Invocation_Body_Scenarios
;
12487 -----------------------------
12488 -- Process_Invocation_Call --
12489 -----------------------------
12491 procedure Process_Invocation_Call
12493 Call_Rep
: Scenario_Rep_Id
;
12494 In_State
: Processing_In_State
)
12496 pragma Unreferenced
(Call
);
12498 Subp_Id
: constant Entity_Id
:= Target
(Call_Rep
);
12499 Subp_Rep
: constant Target_Rep_Id
:=
12500 Target_Representation_Of
(Subp_Id
, In_State
);
12503 -- Nothing to do when the subprogram appears within an internal unit
12505 if In_Internal_Unit
(Subp_Id
) then
12508 -- Nothing to do for an abstract subprogram because it has no body to
12511 elsif Ekind
(Subp_Id
) in E_Function | E_Procedure
12512 and then Is_Abstract_Subprogram
(Subp_Id
)
12516 -- Nothin to do for a formal subprogram because it has no body to
12519 elsif Is_Formal_Subprogram
(Subp_Id
) then
12523 -- The subprogram being called is within the main unit. Extend the
12524 -- DFS traversal into its barrier function and body.
12526 if In_Extended_Main_Code_Unit
(Subp_Id
) then
12527 if Ekind
(Subp_Id
) in E_Entry | E_Entry_Family | E_Procedure
then
12528 Traverse_Invocation_Body
12529 (N
=> Barrier_Body_Declaration
(Subp_Rep
),
12530 In_State
=> In_State
);
12533 Traverse_Invocation_Body
12534 (N
=> Body_Declaration
(Subp_Rep
),
12535 In_State
=> In_State
);
12537 -- The subprogram being called resides within an external unit
12539 -- Main unit External unit
12540 -- +-----------+ +-------------+
12542 -- | Start ------------> Subp_Id |
12544 -- +-----------+ +-------------+
12546 -- Record the invocation path which originates from Start and reaches
12550 Record_Invocation_Path
(In_State
);
12552 end Process_Invocation_Call
;
12554 --------------------------------------
12555 -- Process_Invocation_Instantiation --
12556 --------------------------------------
12558 procedure Process_Invocation_Instantiation
12560 Inst_Rep
: Scenario_Rep_Id
;
12561 In_State
: Processing_In_State
)
12563 pragma Unreferenced
(Inst
);
12565 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
12568 -- Nothing to do when the generic appears within an internal unit
12570 if In_Internal_Unit
(Gen_Id
) then
12574 -- The generic being instantiated resides within an external unit
12576 -- Main unit External unit
12577 -- +-----------+ +-------------+
12579 -- | Start ------------> Generic |
12581 -- +-----------+ +-------------+
12583 -- Record the invocation path which originates from Start and reaches
12586 if not In_Extended_Main_Code_Unit
(Gen_Id
) then
12587 Record_Invocation_Path
(In_State
);
12589 end Process_Invocation_Instantiation
;
12591 ---------------------------------
12592 -- Process_Invocation_Scenario --
12593 ---------------------------------
12595 procedure Process_Invocation_Scenario
12597 In_State
: Processing_In_State
)
12599 Scen
: constant Node_Id
:= Scenario
(N
);
12600 Scen_Rep
: Scenario_Rep_Id
;
12603 -- Add the current scenario to the stack of active scenarios
12605 Push_Active_Scenario
(Scen
);
12607 -- Call or task activation
12609 if Is_Suitable_Call
(Scen
) then
12610 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
12612 -- Routine Build_Call_Marker creates call markers regardless of
12613 -- whether the call occurs within the main unit or not. This way
12614 -- the serialization of internal names is kept consistent. Only
12615 -- call markers found within the main unit must be processed.
12617 if In_Main_Context
(Scen
) then
12618 Scen_Rep
:= Scenario_Representation_Of
(Scen
, In_State
);
12620 if Kind
(Scen_Rep
) = Call_Scenario
then
12621 Process_Invocation_Call
12623 Call_Rep
=> Scen_Rep
,
12624 In_State
=> In_State
);
12627 pragma Assert
(Kind
(Scen_Rep
) = Task_Activation_Scenario
);
12631 Call_Rep
=> Scen_Rep
,
12632 Processor
=> Process_Invocation_Activation
'Access,
12633 In_State
=> In_State
);
12639 elsif Is_Suitable_Instantiation
(Scen
) then
12640 Process_Invocation_Instantiation
12642 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
12643 In_State
=> In_State
);
12646 -- Remove the current scenario from the stack of active scenarios
12647 -- once all invocation constructs and paths have been saved.
12649 Pop_Active_Scenario
(Scen
);
12650 end Process_Invocation_Scenario
;
12652 ----------------------------------
12653 -- Process_Invocation_Scenarios --
12654 ----------------------------------
12656 procedure Process_Invocation_Scenarios
12657 (Iter
: in out NE_Set
.Iterator
;
12658 In_State
: Processing_In_State
)
12663 while NE_Set
.Has_Next
(Iter
) loop
12664 NE_Set
.Next
(Iter
, N
);
12666 -- Reset the traversed status of all subprogram bodies because the
12667 -- current invocation scenario acts as a new DFS traversal root.
12669 Reset_Traversed_Bodies
;
12671 Process_Invocation_Scenario
(N
, In_State
);
12673 end Process_Invocation_Scenarios
;
12675 ---------------------------------------
12676 -- Process_Invocation_Spec_Scenarios --
12677 ---------------------------------------
12679 procedure Process_Invocation_Spec_Scenarios
is
12680 Iter
: NE_Set
.Iterator
:= Iterate_Library_Spec_Scenarios
;
12682 Process_Invocation_Scenarios
12684 In_State
=> Invocation_Spec_State
);
12685 end Process_Invocation_Spec_Scenarios
;
12687 -----------------------
12688 -- Process_Main_Unit --
12689 -----------------------
12691 procedure Process_Main_Unit
is
12692 Unit_Decl
: constant Node_Id
:= Unit
(Cunit
(Main_Unit
));
12693 Spec_Id
: Entity_Id
;
12696 -- The main unit is a [generic] package body
12698 if Nkind
(Unit_Decl
) = N_Package_Body
then
12699 Spec_Id
:= Corresponding_Spec
(Unit_Decl
);
12700 pragma Assert
(Present
(Spec_Id
));
12702 Process_Package_Declaration
12703 (Pack_Decl
=> Unit_Declaration_Node
(Spec_Id
),
12704 In_State
=> Invocation_Construct_State
);
12706 -- The main unit is a [generic] package declaration
12708 elsif Nkind
(Unit_Decl
) = N_Package_Declaration
then
12709 Process_Package_Declaration
12710 (Pack_Decl
=> Unit_Decl
,
12711 In_State
=> Invocation_Construct_State
);
12713 -- The main unit is a [generic] subprogram body
12715 elsif Nkind
(Unit_Decl
) = N_Subprogram_Body
then
12716 Spec_Id
:= Corresponding_Spec
(Unit_Decl
);
12718 -- The body completes a previous declaration
12720 if Present
(Spec_Id
) then
12721 Process_Subprogram_Declaration
12722 (Subp_Decl
=> Unit_Declaration_Node
(Spec_Id
),
12723 In_State
=> Invocation_Construct_State
);
12725 -- Otherwise the body is stand-alone
12728 Process_Subprogram_Declaration
12729 (Subp_Decl
=> Unit_Decl
,
12730 In_State
=> Invocation_Construct_State
);
12733 -- The main unit is a subprogram instantiation
12735 elsif Nkind
(Unit_Decl
) in N_Subprogram_Instantiation
then
12736 Process_Subprogram_Instantiation
12737 (Inst
=> Unit_Decl
,
12738 In_State
=> Invocation_Construct_State
);
12740 -- The main unit is an imported subprogram declaration
12742 elsif Nkind
(Unit_Decl
) = N_Subprogram_Declaration
then
12743 Process_Subprogram_Declaration
12744 (Subp_Decl
=> Unit_Decl
,
12745 In_State
=> Invocation_Construct_State
);
12747 end Process_Main_Unit
;
12749 ---------------------------------
12750 -- Process_Package_Declaration --
12751 ---------------------------------
12753 procedure Process_Package_Declaration
12754 (Pack_Decl
: Node_Id
;
12755 In_State
: Processing_In_State
)
12757 Body_Id
: constant Entity_Id
:= Corresponding_Body
(Pack_Decl
);
12758 Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
12759 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
12762 -- Add a declaration for the generic package in the ALI of the main
12763 -- unit in case a client unit instantiates it.
12765 if Ekind
(Spec_Id
) = E_Generic_Package
then
12766 Declare_Invocation_Construct
12767 (Constr_Id
=> Spec_Id
,
12768 In_State
=> In_State
);
12770 -- Otherwise inspect the visible and private declarations of the
12771 -- package for invocation constructs.
12774 Process_Declarations
12775 (Decls
=> Visible_Declarations
(Spec
),
12776 In_State
=> In_State
);
12778 Process_Declarations
12779 (Decls
=> Private_Declarations
(Spec
),
12780 In_State
=> In_State
);
12782 -- The package body containst at least one generic unit or an
12783 -- inlinable subprogram. Such constructs may grant clients of
12784 -- the main unit access to the private enclosing contexts of
12785 -- the constructs. Process the main unit body to discover and
12786 -- encode relevant invocation constructs and relations that
12787 -- may ultimately reach an external unit.
12789 if Present
(Body_Id
)
12790 and then Save_Invocation_Graph_Of_Body
(Cunit
(Main_Unit
))
12792 Process_Declarations
12793 (Decls
=> Declarations
(Unit_Declaration_Node
(Body_Id
)),
12794 In_State
=> In_State
);
12797 end Process_Package_Declaration
;
12799 ----------------------------------------
12800 -- Process_Protected_Type_Declaration --
12801 ----------------------------------------
12803 procedure Process_Protected_Type_Declaration
12804 (Prot_Decl
: Node_Id
;
12805 In_State
: Processing_In_State
)
12807 Prot_Def
: constant Node_Id
:= Protected_Definition
(Prot_Decl
);
12810 if Present
(Prot_Def
) then
12811 Process_Declarations
12812 (Decls
=> Visible_Declarations
(Prot_Def
),
12813 In_State
=> In_State
);
12815 end Process_Protected_Type_Declaration
;
12817 ------------------------------------
12818 -- Process_Subprogram_Declaration --
12819 ------------------------------------
12821 procedure Process_Subprogram_Declaration
12822 (Subp_Decl
: Node_Id
;
12823 In_State
: Processing_In_State
)
12825 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
12828 -- Nothing to do when the subprogram is not an invocation target
12830 if not Is_Invocation_Target
(Subp_Id
) then
12834 -- Add a declaration for the subprogram in the ALI file of the main
12835 -- unit in case a client unit calls or instantiates it.
12837 Declare_Invocation_Construct
12838 (Constr_Id
=> Subp_Id
,
12839 In_State
=> In_State
);
12841 -- Do not process subprograms without a body because they do not
12842 -- contain any invocation scenarios.
12844 if Is_Bodiless_Subprogram
(Subp_Id
) then
12847 -- Do not process generic subprograms because generics must not be
12850 elsif Is_Generic_Subprogram
(Subp_Id
) then
12853 -- Otherwise create a dummy scenario which calls the subprogram to
12854 -- act as a root for a DFS traversal.
12857 -- Reset the traversed status of all subprogram bodies because the
12858 -- subprogram acts as a new DFS traversal root.
12860 Reset_Traversed_Bodies
;
12862 Process_Invocation_Scenario
12863 (N
=> Build_Subprogram_Invocation
(Subp_Id
),
12864 In_State
=> In_State
);
12866 end Process_Subprogram_Declaration
;
12868 --------------------------------------
12869 -- Process_Subprogram_Instantiation --
12870 --------------------------------------
12872 procedure Process_Subprogram_Instantiation
12874 In_State
: Processing_In_State
)
12877 -- Add a declaration for the instantiation in the ALI file of the
12878 -- main unit in case a client unit calls it.
12880 Declare_Invocation_Construct
12881 (Constr_Id
=> Defining_Entity
(Inst
),
12882 In_State
=> In_State
);
12883 end Process_Subprogram_Instantiation
;
12885 -----------------------------------
12886 -- Process_Task_Type_Declaration --
12887 -----------------------------------
12889 procedure Process_Task_Type_Declaration
12890 (Task_Decl
: Node_Id
;
12891 In_State
: Processing_In_State
)
12893 Task_Typ
: constant Entity_Id
:= Defining_Entity
(Task_Decl
);
12894 Task_Def
: Node_Id
;
12897 -- Add a declaration for the task type the ALI file of the main unit
12898 -- in case a client unit creates a task object and activates it.
12900 Declare_Invocation_Construct
12901 (Constr_Id
=> Task_Typ
,
12902 In_State
=> In_State
);
12904 -- Process the entries of the task type because they represent valid
12905 -- entry points into the task body.
12907 if Nkind
(Task_Decl
) in N_Single_Task_Declaration
12908 | N_Task_Type_Declaration
12910 Task_Def
:= Task_Definition
(Task_Decl
);
12912 if Present
(Task_Def
) then
12913 Process_Declarations
12914 (Decls
=> Visible_Declarations
(Task_Def
),
12915 In_State
=> In_State
);
12919 -- Reset the traversed status of all subprogram bodies because the
12920 -- task type acts as a new DFS traversal root.
12922 Reset_Traversed_Bodies
;
12924 -- Create a dummy scenario which activates an anonymous object of the
12925 -- task type to acts as a root of a DFS traversal.
12927 Process_Invocation_Scenario
12928 (N
=> Build_Task_Activation
(Task_Typ
, In_State
),
12929 In_State
=> In_State
);
12930 end Process_Task_Type_Declaration
;
12932 ---------------------------------
12933 -- Record_Full_Invocation_Path --
12934 ---------------------------------
12936 procedure Record_Full_Invocation_Path
(In_State
: Processing_In_State
) is
12937 package Scenarios
renames Active_Scenario_Stack
;
12940 -- The path originates from the elaboration of the body. Add an extra
12941 -- relation from the elaboration body procedure to the first active
12944 if In_State
.Processing
= Invocation_Body_Processing
then
12945 Build_Elaborate_Body_Procedure
;
12947 Record_Invocation_Relation
12948 (Invk_Id
=> Elab_Body_Id
,
12949 Targ_Id
=> Target_Of
(Scenarios
.First
, In_State
),
12950 In_State
=> In_State
);
12952 -- The path originates from the elaboration of the spec. Add an extra
12953 -- relation from the elaboration spec procedure to the first active
12956 elsif In_State
.Processing
= Invocation_Spec_Processing
then
12957 Build_Elaborate_Spec_Procedure
;
12959 Record_Invocation_Relation
12960 (Invk_Id
=> Elab_Spec_Id
,
12961 Targ_Id
=> Target_Of
(Scenarios
.First
, In_State
),
12962 In_State
=> In_State
);
12965 -- Record individual relations formed by pairs of scenarios
12967 for Index
in Scenarios
.First
.. Scenarios
.Last
- 1 loop
12968 Record_Invocation_Relation
12969 (Invk_Id
=> Target_Of
(Index
, In_State
),
12970 Targ_Id
=> Target_Of
(Index
+ 1, In_State
),
12971 In_State
=> In_State
);
12973 end Record_Full_Invocation_Path
;
12975 -----------------------------
12976 -- Record_Invocation_Graph --
12977 -----------------------------
12979 procedure Record_Invocation_Graph
is
12981 -- Nothing to do when the invocation graph is not recorded
12983 if not Invocation_Graph_Recording_OK
then
12987 -- Save the encoding format used to capture information about the
12988 -- invocation constructs and relations in the ALI file of the main
12991 Record_Invocation_Graph_Encoding
;
12993 -- Examine all library level invocation scenarios and perform DFS
12994 -- traversals from each one. Encode a path in the ALI file of the
12995 -- main unit if it reaches into an external unit.
12997 Process_Invocation_Body_Scenarios
;
12998 Process_Invocation_Spec_Scenarios
;
13000 -- Examine all invocation constructs within the spec and body of the
13001 -- main unit and perform DFS traversals from each one. Encode a path
13002 -- in the ALI file of the main unit if it reaches into an external
13006 end Record_Invocation_Graph
;
13008 --------------------------------------
13009 -- Record_Invocation_Graph_Encoding --
13010 --------------------------------------
13012 procedure Record_Invocation_Graph_Encoding
is
13013 Kind
: Invocation_Graph_Encoding_Kind
:= No_Encoding
;
13016 -- Switch -gnatd_F (encode full invocation paths in ALI files) is in
13019 if Debug_Flag_Underscore_FF
then
13020 Kind
:= Full_Path_Encoding
;
13022 Kind
:= Endpoints_Encoding
;
13025 -- Save the encoding format in the ALI file of the main unit
13027 Set_Invocation_Graph_Encoding
13029 Update_Units
=> False);
13030 end Record_Invocation_Graph_Encoding
;
13032 ----------------------------
13033 -- Record_Invocation_Path --
13034 ----------------------------
13036 procedure Record_Invocation_Path
(In_State
: Processing_In_State
) is
13037 package Scenarios
renames Active_Scenario_Stack
;
13040 -- Save a path when the active scenario stack contains at least one
13041 -- invocation scenario.
13043 if Scenarios
.Last
- Scenarios
.First
< 0 then
13047 -- Register all relations in the path when switch -gnatd_F (encode
13048 -- full invocation paths in ALI files) is in effect.
13050 if Debug_Flag_Underscore_FF
then
13051 Record_Full_Invocation_Path
(In_State
);
13053 -- Otherwise register a single relation
13056 Record_Simple_Invocation_Path
(In_State
);
13059 Write_Invocation_Path
(In_State
);
13060 end Record_Invocation_Path
;
13062 --------------------------------
13063 -- Record_Invocation_Relation --
13064 --------------------------------
13066 procedure Record_Invocation_Relation
13067 (Invk_Id
: Entity_Id
;
13068 Targ_Id
: Entity_Id
;
13069 In_State
: Processing_In_State
)
13071 pragma Assert
(Present
(Invk_Id
));
13072 pragma Assert
(Present
(Targ_Id
));
13074 procedure Get_Invocation_Attributes
13075 (Extra
: out Entity_Id
;
13076 Kind
: out Invocation_Kind
);
13077 pragma Inline
(Get_Invocation_Attributes
);
13078 -- Return the additional entity used in error diagnostics in Extra
13079 -- and the invocation kind in Kind which pertain to the invocation
13080 -- relation with invoker Invk_Id and target Targ_Id.
13082 -------------------------------
13083 -- Get_Invocation_Attributes --
13084 -------------------------------
13086 procedure Get_Invocation_Attributes
13087 (Extra
: out Entity_Id
;
13088 Kind
: out Invocation_Kind
)
13091 -- Accept within a task body
13093 if Is_Accept_Alternative_Proc
(Targ_Id
) then
13094 Extra
:= Receiving_Entry
(Targ_Id
);
13095 Kind
:= Accept_Alternative
;
13097 -- Activation of a task object
13099 elsif Is_Activation_Proc
(Targ_Id
)
13100 or else Is_Task_Type
(Targ_Id
)
13103 Kind
:= Task_Activation
;
13105 -- Controlled adjustment actions
13107 elsif Is_Controlled_Procedure
(Targ_Id
, Name_Adjust
) then
13108 Extra
:= First_Formal_Type
(Targ_Id
);
13109 Kind
:= Controlled_Adjustment
;
13111 -- Controlled finalization actions
13113 elsif Is_Controlled_Procedure
(Targ_Id
, Name_Finalize
)
13114 or else Is_Finalizer_Proc
(Targ_Id
)
13116 Extra
:= First_Formal_Type
(Targ_Id
);
13117 Kind
:= Controlled_Finalization
;
13119 -- Controlled initialization actions
13121 elsif Is_Controlled_Procedure
(Targ_Id
, Name_Initialize
) then
13122 Extra
:= First_Formal_Type
(Targ_Id
);
13123 Kind
:= Controlled_Initialization
;
13125 -- Default_Initial_Condition verification
13127 elsif Is_Default_Initial_Condition_Proc
(Targ_Id
) then
13128 Extra
:= First_Formal_Type
(Targ_Id
);
13129 Kind
:= Default_Initial_Condition_Verification
;
13131 -- Initialization of object
13133 elsif Is_Init_Proc
(Targ_Id
) then
13134 Extra
:= First_Formal_Type
(Targ_Id
);
13135 Kind
:= Type_Initialization
;
13137 -- Initial_Condition verification
13139 elsif Is_Initial_Condition_Proc
(Targ_Id
) then
13140 Extra
:= First_Formal_Type
(Targ_Id
);
13141 Kind
:= Initial_Condition_Verification
;
13145 elsif Is_Generic_Unit
(Targ_Id
) then
13147 Kind
:= Instantiation
;
13149 -- Internal controlled adjustment actions
13151 elsif Is_TSS
(Targ_Id
, TSS_Deep_Adjust
) then
13152 Extra
:= First_Formal_Type
(Targ_Id
);
13153 Kind
:= Internal_Controlled_Adjustment
;
13155 -- Internal controlled finalization actions
13157 elsif Is_TSS
(Targ_Id
, TSS_Deep_Finalize
) then
13158 Extra
:= First_Formal_Type
(Targ_Id
);
13159 Kind
:= Internal_Controlled_Finalization
;
13161 -- Internal controlled initialization actions
13163 elsif Is_TSS
(Targ_Id
, TSS_Deep_Initialize
) then
13164 Extra
:= First_Formal_Type
(Targ_Id
);
13165 Kind
:= Internal_Controlled_Initialization
;
13167 -- Invariant verification
13169 elsif Is_Invariant_Proc
(Targ_Id
)
13170 or else Is_Partial_Invariant_Proc
(Targ_Id
)
13172 Extra
:= First_Formal_Type
(Targ_Id
);
13173 Kind
:= Invariant_Verification
;
13175 -- Protected entry call
13177 elsif Is_Protected_Entry
(Targ_Id
) then
13179 Kind
:= Protected_Entry_Call
;
13181 -- Protected subprogram call
13183 elsif Is_Protected_Subp
(Targ_Id
) then
13185 Kind
:= Protected_Subprogram_Call
;
13189 elsif Is_Task_Entry
(Targ_Id
) then
13191 Kind
:= Task_Entry_Call
;
13193 -- Entry, operator, or subprogram call. This case must come last
13194 -- because most invocations above are variations of this case.
13196 elsif Ekind
(Targ_Id
) in
13197 E_Entry | E_Function | E_Operator | E_Procedure
13203 pragma Assert
(False);
13205 Kind
:= No_Invocation
;
13207 end Get_Invocation_Attributes
;
13212 Extra_Nam
: Name_Id
;
13213 Kind
: Invocation_Kind
;
13214 Rel
: Invoker_Target_Relation
;
13216 -- Start of processing for Record_Invocation_Relation
13219 Rel
.Invoker
:= Invk_Id
;
13220 Rel
.Target
:= Targ_Id
;
13222 -- Nothing to do when the invocation relation has already been
13223 -- recorded in ALI file of the main unit.
13225 if Is_Saved_Relation
(Rel
) then
13229 -- Mark the relation as recorded in the ALI file
13231 Set_Is_Saved_Relation
(Rel
);
13233 -- Declare the invoker in the ALI file
13235 Declare_Invocation_Construct
13236 (Constr_Id
=> Invk_Id
,
13237 In_State
=> In_State
);
13239 -- Obtain the invocation-specific attributes of the relation
13241 Get_Invocation_Attributes
(Extra
, Kind
);
13243 -- Certain invocations lack an extra entity used in error diagnostics
13245 if Present
(Extra
) then
13246 Extra_Nam
:= Chars
(Extra
);
13248 Extra_Nam
:= No_Name
;
13251 -- Add the relation in the ALI file
13253 Add_Invocation_Relation
13254 (Extra
=> Extra_Nam
,
13255 Invoker
=> Signature_Of
(Invk_Id
),
13257 Target
=> Signature_Of
(Targ_Id
),
13258 Update_Units
=> False);
13259 end Record_Invocation_Relation
;
13261 -----------------------------------
13262 -- Record_Simple_Invocation_Path --
13263 -----------------------------------
13265 procedure Record_Simple_Invocation_Path
13266 (In_State
: Processing_In_State
)
13268 package Scenarios
renames Active_Scenario_Stack
;
13270 Last_Targ
: constant Entity_Id
:=
13271 Target_Of
(Scenarios
.Last
, In_State
);
13272 First_Targ
: Entity_Id
;
13275 -- The path originates from the elaboration of the body. Add an extra
13276 -- relation from the elaboration body procedure to the first active
13279 if In_State
.Processing
= Invocation_Body_Processing
then
13280 Build_Elaborate_Body_Procedure
;
13281 First_Targ
:= Elab_Body_Id
;
13283 -- The path originates from the elaboration of the spec. Add an extra
13284 -- relation from the elaboration spec procedure to the first active
13287 elsif In_State
.Processing
= Invocation_Spec_Processing
then
13288 Build_Elaborate_Spec_Procedure
;
13289 First_Targ
:= Elab_Spec_Id
;
13292 First_Targ
:= Target_Of
(Scenarios
.First
, In_State
);
13295 -- Record a single relation from the first to the last scenario
13297 if First_Targ
/= Last_Targ
then
13298 Record_Invocation_Relation
13299 (Invk_Id
=> First_Targ
,
13300 Targ_Id
=> Last_Targ
,
13301 In_State
=> In_State
);
13303 end Record_Simple_Invocation_Path
;
13305 ----------------------------
13306 -- Set_Is_Saved_Construct --
13307 ----------------------------
13309 procedure Set_Is_Saved_Construct
(Constr
: Entity_Id
) is
13310 pragma Assert
(Present
(Constr
));
13313 NE_Set
.Insert
(Saved_Constructs_Set
, Constr
);
13314 end Set_Is_Saved_Construct
;
13316 ---------------------------
13317 -- Set_Is_Saved_Relation --
13318 ---------------------------
13320 procedure Set_Is_Saved_Relation
(Rel
: Invoker_Target_Relation
) is
13322 IR_Set
.Insert
(Saved_Relations_Set
, Rel
);
13323 end Set_Is_Saved_Relation
;
13329 function Signature_Of
(Id
: Entity_Id
) return Invocation_Signature_Id
is
13330 Loc
: constant Source_Ptr
:= Sloc
(Id
);
13332 function Instantiation_Locations
return Name_Id
;
13333 pragma Inline
(Instantiation_Locations
);
13334 -- Create a concatenation of all lines and colums of each instance
13335 -- where source location Loc appears. Return No_Name if no instances
13338 function Qualified_Scope
return Name_Id
;
13339 pragma Inline
(Qualified_Scope
);
13340 -- Obtain the qualified name of Id's scope
13342 -----------------------------
13343 -- Instantiation_Locations --
13344 -----------------------------
13346 function Instantiation_Locations
return Name_Id
is
13347 Buffer
: Bounded_String
(2052);
13350 SFI
: Source_File_Index
;
13353 SFI
:= Get_Source_File_Index
(Loc
);
13354 Inst
:= Instantiation
(SFI
);
13356 -- The location is within an instance. Construct a concatenation
13357 -- of all lines and colums of each individual instance using the
13358 -- following format:
13360 -- line1_column1_line2_column2_ ... _lineN_columnN
13362 if Inst
/= No_Location
then
13364 Append
(Buffer
, Nat
(Get_Logical_Line_Number
(Inst
)));
13365 Append
(Buffer
, '_');
13366 Append
(Buffer
, Nat
(Get_Column_Number
(Inst
)));
13368 SFI
:= Get_Source_File_Index
(Inst
);
13369 Inst
:= Instantiation
(SFI
);
13371 exit when Inst
= No_Location
;
13373 Append
(Buffer
, '_');
13376 Loc_Nam
:= Name_Find
(Buffer
);
13379 -- Otherwise there no instances are involved
13384 end Instantiation_Locations
;
13386 ---------------------
13387 -- Qualified_Scope --
13388 ---------------------
13390 function Qualified_Scope
return Name_Id
is
13394 Scop
:= Scope
(Id
);
13396 -- The entity appears within an anonymous concurrent type created
13397 -- for a single protected or task type declaration. Use the entity
13398 -- of the anonymous object as it represents the original scope.
13400 if Is_Concurrent_Type
(Scop
)
13401 and then Present
(Anonymous_Object
(Scop
))
13403 Scop
:= Anonymous_Object
(Scop
);
13406 return Get_Qualified_Name
(Scop
);
13407 end Qualified_Scope
;
13409 -- Start of processing for Signature_Of
13413 Invocation_Signature_Of
13414 (Column
=> Nat
(Get_Column_Number
(Loc
)),
13415 Line
=> Nat
(Get_Logical_Line_Number
(Loc
)),
13416 Locations
=> Instantiation_Locations
,
13417 Name
=> Chars
(Id
),
13418 Scope
=> Qualified_Scope
);
13426 (Pos
: Active_Scenario_Pos
;
13427 In_State
: Processing_In_State
) return Entity_Id
13429 package Scenarios
renames Active_Scenario_Stack
;
13431 -- Ensure that the position is within the bounds of the active
13434 pragma Assert
(Scenarios
.First
<= Pos
);
13435 pragma Assert
(Pos
<= Scenarios
.Last
);
13437 Scen_Rep
: constant Scenario_Rep_Id
:=
13438 Scenario_Representation_Of
13439 (Scenarios
.Table
(Pos
), In_State
);
13442 -- The true target of an activation call is the current task type
13443 -- rather than routine Activate_Tasks.
13445 if Kind
(Scen_Rep
) = Task_Activation_Scenario
then
13446 return Activated_Task_Type
(Scen_Rep
);
13448 return Target
(Scen_Rep
);
13452 ------------------------------
13453 -- Traverse_Invocation_Body --
13454 ------------------------------
13456 procedure Traverse_Invocation_Body
13458 In_State
: Processing_In_State
)
13463 Requires_Processing
=> Is_Invocation_Scenario
'Access,
13464 Processor
=> Process_Invocation_Scenario
'Access,
13465 In_State
=> In_State
);
13466 end Traverse_Invocation_Body
;
13468 ---------------------------
13469 -- Write_Invocation_Path --
13470 ---------------------------
13472 procedure Write_Invocation_Path
(In_State
: Processing_In_State
) is
13473 procedure Write_Target
(Targ_Id
: Entity_Id
; Is_First
: Boolean);
13474 pragma Inline
(Write_Target
);
13475 -- Write out invocation target Targ_Id to standard output. Flag
13476 -- Is_First should be set when the target is first in a path.
13482 procedure Write_Target
(Targ_Id
: Entity_Id
; Is_First
: Boolean) is
13484 if not Is_First
then
13485 Write_Str
(" --> ");
13488 Write_Name
(Get_Qualified_Name
(Targ_Id
));
13494 package Scenarios
renames Active_Scenario_Stack
;
13496 First_Seen
: Boolean := False;
13498 -- Start of processing for Write_Invocation_Path
13501 -- Nothing to do when flag -gnatd_T (output trace information on
13502 -- invocation path recording) is not in effect.
13504 if not Debug_Flag_Underscore_TT
then
13508 -- The path originates from the elaboration of the body. Write the
13509 -- elaboration body procedure.
13511 if In_State
.Processing
= Invocation_Body_Processing
then
13512 Write_Target
(Elab_Body_Id
, True);
13513 First_Seen
:= True;
13515 -- The path originates from the elaboration of the spec. Write the
13516 -- elaboration spec procedure.
13518 elsif In_State
.Processing
= Invocation_Spec_Processing
then
13519 Write_Target
(Elab_Spec_Id
, True);
13520 First_Seen
:= True;
13523 -- Write each individual target invoked by its corresponding scenario
13524 -- on the active scenario stack.
13526 for Index
in Scenarios
.First
.. Scenarios
.Last
loop
13528 (Targ_Id
=> Target_Of
(Index
, In_State
),
13529 Is_First
=> Index
= Scenarios
.First
and then not First_Seen
);
13533 end Write_Invocation_Path
;
13534 end Invocation_Graph
;
13536 ------------------------
13537 -- Is_Safe_Activation --
13538 ------------------------
13540 function Is_Safe_Activation
13542 Task_Rep
: Target_Rep_Id
) return Boolean
13545 -- The activation of a task coming from an external instance cannot
13546 -- cause an ABE because the generic was already instantiated. Note
13547 -- that the instantiation itself may lead to an ABE.
13550 In_External_Instance
13552 Target_Decl
=> Spec_Declaration
(Task_Rep
));
13553 end Is_Safe_Activation
;
13559 function Is_Safe_Call
13561 Subp_Id
: Entity_Id
;
13562 Subp_Rep
: Target_Rep_Id
) return Boolean
13564 Body_Decl
: constant Node_Id
:= Body_Declaration
(Subp_Rep
);
13565 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Subp_Rep
);
13568 -- The target is either an abstract subprogram, formal subprogram, or
13569 -- imported, in which case it does not have a body at compile or bind
13570 -- time. Assume that the call is ABE-safe.
13572 if Is_Bodiless_Subprogram
(Subp_Id
) then
13575 -- The target is an instantiation of a generic subprogram. The call
13576 -- cannot cause an ABE because the generic was already instantiated.
13577 -- Note that the instantiation itself may lead to an ABE.
13579 elsif Is_Generic_Instance
(Subp_Id
) then
13582 -- The invocation of a target coming from an external instance cannot
13583 -- cause an ABE because the generic was already instantiated. Note that
13584 -- the instantiation itself may lead to an ABE.
13586 elsif In_External_Instance
13588 Target_Decl
=> Spec_Decl
)
13592 -- The target is a subprogram body without a previous declaration. The
13593 -- call cannot cause an ABE because the body has already been seen.
13595 elsif Nkind
(Spec_Decl
) = N_Subprogram_Body
13596 and then No
(Corresponding_Spec
(Spec_Decl
))
13600 -- The target is a subprogram body stub without a prior declaration.
13601 -- The call cannot cause an ABE because the proper body substitutes
13604 elsif Nkind
(Spec_Decl
) = N_Subprogram_Body_Stub
13605 and then No
(Corresponding_Spec_Of_Stub
(Spec_Decl
))
13609 -- A call to an expression function that is not a completion cannot
13610 -- cause an ABE because it has no prior declaration; this remains
13611 -- true even if the FE transforms the callee into something else.
13613 elsif Nkind
(Original_Node
(Spec_Decl
)) = N_Expression_Function
then
13616 -- Subprogram bodies which wrap attribute references used as actuals
13617 -- in instantiations are always ABE-safe. These bodies are artifacts
13620 elsif Present
(Body_Decl
)
13621 and then Nkind
(Body_Decl
) = N_Subprogram_Body
13622 and then Was_Attribute_Reference
(Body_Decl
)
13630 ---------------------------
13631 -- Is_Safe_Instantiation --
13632 ---------------------------
13634 function Is_Safe_Instantiation
13636 Gen_Id
: Entity_Id
;
13637 Gen_Rep
: Target_Rep_Id
) return Boolean
13639 Spec_Decl
: constant Node_Id
:= Spec_Declaration
(Gen_Rep
);
13642 -- The generic is an intrinsic subprogram in which case it does not
13643 -- have a body at compile or bind time. Assume that the instantiation
13646 if Is_Bodiless_Subprogram
(Gen_Id
) then
13649 -- The instantiation of an external nested generic cannot cause an ABE
13650 -- if the outer generic was already instantiated. Note that the instance
13651 -- of the outer generic may lead to an ABE.
13653 elsif In_External_Instance
13655 Target_Decl
=> Spec_Decl
)
13659 -- The generic is a package. The instantiation cannot cause an ABE when
13660 -- the package has no body.
13662 elsif Ekind
(Gen_Id
) = E_Generic_Package
13663 and then not Has_Body
(Spec_Decl
)
13669 end Is_Safe_Instantiation
;
13675 function Is_Same_Unit
13676 (Unit_1
: Entity_Id
;
13677 Unit_2
: Entity_Id
) return Boolean
13680 return Unit_Entity
(Unit_1
) = Unit_Entity
(Unit_2
);
13683 -------------------------------
13684 -- Kill_Elaboration_Scenario --
13685 -------------------------------
13687 procedure Kill_Elaboration_Scenario
(N
: Node_Id
) is
13689 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
13690 -- enabled) is in effect because the legacy ABE lechanism does not need
13691 -- to carry out this action.
13693 if Legacy_Elaboration_Checks
then
13696 -- Nothing to do when the elaboration phase of the compiler is not
13699 elsif not Elaboration_Phase_Active
then
13703 -- Eliminate a recorded scenario when it appears within dead code
13704 -- because it will not be executed at elaboration time.
13706 if Is_Scenario
(N
) then
13707 Delete_Scenario
(N
);
13709 end Kill_Elaboration_Scenario
;
13711 ----------------------
13712 -- Main_Unit_Entity --
13713 ----------------------
13715 function Main_Unit_Entity
return Entity_Id
is
13717 -- Note that Cunit_Entity (Main_Unit) is not reliable in the presence of
13718 -- generic bodies and may return an outdated entity.
13720 return Defining_Entity
(Unit
(Cunit
(Main_Unit
)));
13721 end Main_Unit_Entity
;
13723 ----------------------
13724 -- Non_Private_View --
13725 ----------------------
13727 function Non_Private_View
(Typ
: Entity_Id
) return Entity_Id
is
13729 if Is_Private_Type
(Typ
) and then Present
(Full_View
(Typ
)) then
13730 return Full_View
(Typ
);
13734 end Non_Private_View
;
13736 ---------------------------------
13737 -- Record_Elaboration_Scenario --
13738 ---------------------------------
13740 procedure Record_Elaboration_Scenario
(N
: Node_Id
) is
13741 procedure Check_Preelaborated_Call
13743 Call_Lvl
: Enclosing_Level_Kind
);
13744 pragma Inline
(Check_Preelaborated_Call
);
13745 -- Verify that entry, operator, or subprogram call Call with enclosing
13746 -- level Call_Lvl does not appear at the library level of preelaborated
13749 function Find_Code_Unit
(Nod
: Node_Or_Entity_Id
) return Entity_Id
;
13750 pragma Inline
(Find_Code_Unit
);
13751 -- Return the code unit which contains arbitrary node or entity Nod.
13752 -- This is the unit of the file which physically contains the related
13753 -- construct denoted by Nod except when Nod is within an instantiation.
13754 -- In that case the unit is that of the top-level instantiation.
13756 function In_Preelaborated_Context
(Nod
: Node_Id
) return Boolean;
13757 pragma Inline
(In_Preelaborated_Context
);
13758 -- Determine whether arbitrary node Nod appears within a preelaborated
13761 procedure Record_Access_Taken
13763 Attr_Lvl
: Enclosing_Level_Kind
);
13764 pragma Inline
(Record_Access_Taken
);
13765 -- Record 'Access scenario Attr with enclosing level Attr_Lvl
13767 procedure Record_Call_Or_Task_Activation
13769 Call_Lvl
: Enclosing_Level_Kind
);
13770 pragma Inline
(Record_Call_Or_Task_Activation
);
13771 -- Record call scenario Call with enclosing level Call_Lvl
13773 procedure Record_Instantiation
13775 Inst_Lvl
: Enclosing_Level_Kind
);
13776 pragma Inline
(Record_Instantiation
);
13777 -- Record instantiation scenario Inst with enclosing level Inst_Lvl
13779 procedure Record_Variable_Assignment
13781 Asmt_Lvl
: Enclosing_Level_Kind
);
13782 pragma Inline
(Record_Variable_Assignment
);
13783 -- Record variable assignment scenario Asmt with enclosing level
13786 procedure Record_Variable_Reference
13788 Ref_Lvl
: Enclosing_Level_Kind
);
13789 pragma Inline
(Record_Variable_Reference
);
13790 -- Record variable reference scenario Ref with enclosing level Ref_Lvl
13792 ------------------------------
13793 -- Check_Preelaborated_Call --
13794 ------------------------------
13796 procedure Check_Preelaborated_Call
13798 Call_Lvl
: Enclosing_Level_Kind
)
13801 -- Nothing to do when the call is internally generated because it is
13802 -- assumed that it will never violate preelaboration.
13804 if not Is_Source_Call
(Call
) then
13807 -- Nothing to do when the call is preelaborable by definition
13809 elsif Is_Preelaborable_Call
(Call
) then
13812 -- Library-level calls are always considered because they are part of
13813 -- the associated unit's elaboration actions.
13815 elsif Call_Lvl
in Library_Level
then
13818 -- Calls at the library level of a generic package body have to be
13819 -- checked because they would render an instantiation illegal if the
13820 -- template is marked as preelaborated. Note that this does not apply
13821 -- to calls at the library level of a generic package spec.
13823 elsif Call_Lvl
= Generic_Body_Level
then
13826 -- Otherwise the call does not appear at the proper level and must
13827 -- not be considered for this check.
13833 -- If the call appears within a preelaborated unit, give an error
13835 if In_Preelaborated_Context
(Call
) then
13836 Error_Preelaborated_Call
(Call
);
13838 end Check_Preelaborated_Call
;
13840 --------------------
13841 -- Find_Code_Unit --
13842 --------------------
13844 function Find_Code_Unit
(Nod
: Node_Or_Entity_Id
) return Entity_Id
is
13846 return Find_Unit_Entity
(Unit
(Cunit
(Get_Code_Unit
(Nod
))));
13847 end Find_Code_Unit
;
13849 ------------------------------
13850 -- In_Preelaborated_Context --
13851 ------------------------------
13853 function In_Preelaborated_Context
(Nod
: Node_Id
) return Boolean is
13854 Body_Id
: constant Entity_Id
:= Find_Code_Unit
(Nod
);
13855 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Body_Id
);
13858 -- The node appears within a package body whose corresponding spec is
13859 -- subject to pragma Remote_Call_Interface or Remote_Types. This does
13860 -- not result in a preelaborated context because the package body may
13861 -- be on another machine.
13863 if Ekind
(Body_Id
) = E_Package_Body
13864 and then Is_Package_Or_Generic_Package
(Spec_Id
)
13865 and then (Is_Remote_Call_Interface
(Spec_Id
)
13866 or else Is_Remote_Types
(Spec_Id
))
13870 -- Otherwise the node appears within a preelaborated context when the
13871 -- associated unit is preelaborated.
13874 return Is_Preelaborated_Unit
(Spec_Id
);
13876 end In_Preelaborated_Context
;
13878 -------------------------
13879 -- Record_Access_Taken --
13880 -------------------------
13882 procedure Record_Access_Taken
13884 Attr_Lvl
: Enclosing_Level_Kind
)
13887 -- Signal any enclosing local exception handlers that the 'Access may
13888 -- raise Program_Error due to a failed ABE check when switch -gnatd.o
13889 -- (conservative elaboration order for indirect calls) is in effect.
13890 -- Marking the exception handlers ensures proper expansion by both
13891 -- the front and back end restriction when No_Exception_Propagation
13894 if Debug_Flag_Dot_O
then
13895 Possible_Local_Raise
(Attr
, Standard_Program_Error
);
13898 -- Add 'Access to the appropriate set
13900 if Attr_Lvl
= Library_Body_Level
then
13901 Add_Library_Body_Scenario
(Attr
);
13903 elsif Attr_Lvl
= Library_Spec_Level
13904 or else Attr_Lvl
= Instantiation_Level
13906 Add_Library_Spec_Scenario
(Attr
);
13909 -- 'Access requires a conditional ABE check when the dynamic model is
13912 Add_Dynamic_ABE_Check_Scenario
(Attr
);
13913 end Record_Access_Taken
;
13915 ------------------------------------
13916 -- Record_Call_Or_Task_Activation --
13917 ------------------------------------
13919 procedure Record_Call_Or_Task_Activation
13921 Call_Lvl
: Enclosing_Level_Kind
)
13924 -- Signal any enclosing local exception handlers that the call may
13925 -- raise Program_Error due to failed ABE check. Marking the exception
13926 -- handlers ensures proper expansion by both the front and back end
13927 -- restriction when No_Exception_Propagation is in effect.
13929 Possible_Local_Raise
(Call
, Standard_Program_Error
);
13931 -- Perform early detection of guaranteed ABEs in order to suppress
13932 -- the instantiation of generic bodies because gigi cannot handle
13933 -- certain types of premature instantiations.
13935 Process_Guaranteed_ABE
13937 In_State
=> Guaranteed_ABE_State
);
13939 -- Add the call or task activation to the appropriate set
13941 if Call_Lvl
= Declaration_Level
then
13942 Add_Declaration_Scenario
(Call
);
13944 elsif Call_Lvl
= Library_Body_Level
then
13945 Add_Library_Body_Scenario
(Call
);
13947 elsif Call_Lvl
= Library_Spec_Level
13948 or else Call_Lvl
= Instantiation_Level
13950 Add_Library_Spec_Scenario
(Call
);
13953 -- A call or a task activation requires a conditional ABE check when
13954 -- the dynamic model is in effect.
13956 Add_Dynamic_ABE_Check_Scenario
(Call
);
13957 end Record_Call_Or_Task_Activation
;
13959 --------------------------
13960 -- Record_Instantiation --
13961 --------------------------
13963 procedure Record_Instantiation
13965 Inst_Lvl
: Enclosing_Level_Kind
)
13968 -- Signal enclosing local exception handlers that instantiation may
13969 -- raise Program_Error due to failed ABE check. Marking the exception
13970 -- handlers ensures proper expansion by both the front and back end
13971 -- restriction when No_Exception_Propagation is in effect.
13973 Possible_Local_Raise
(Inst
, Standard_Program_Error
);
13975 -- Perform early detection of guaranteed ABEs in order to suppress
13976 -- the instantiation of generic bodies because gigi cannot handle
13977 -- certain types of premature instantiations.
13979 Process_Guaranteed_ABE
13981 In_State
=> Guaranteed_ABE_State
);
13983 -- Add the instantiation to the appropriate set
13985 if Inst_Lvl
= Declaration_Level
then
13986 Add_Declaration_Scenario
(Inst
);
13988 elsif Inst_Lvl
= Library_Body_Level
then
13989 Add_Library_Body_Scenario
(Inst
);
13991 elsif Inst_Lvl
= Library_Spec_Level
13992 or else Inst_Lvl
= Instantiation_Level
13994 Add_Library_Spec_Scenario
(Inst
);
13997 -- Instantiations of generics subject to SPARK_Mode On require
13998 -- elaboration-related checks even though the instantiations may
13999 -- not appear within elaboration code.
14001 if Is_Suitable_SPARK_Instantiation
(Inst
) then
14002 Add_SPARK_Scenario
(Inst
);
14005 -- An instantiation requires a conditional ABE check when the dynamic
14006 -- model is in effect.
14008 Add_Dynamic_ABE_Check_Scenario
(Inst
);
14009 end Record_Instantiation
;
14011 --------------------------------
14012 -- Record_Variable_Assignment --
14013 --------------------------------
14015 procedure Record_Variable_Assignment
14017 Asmt_Lvl
: Enclosing_Level_Kind
)
14020 -- Add the variable assignment to the appropriate set
14022 if Asmt_Lvl
= Library_Body_Level
then
14023 Add_Library_Body_Scenario
(Asmt
);
14025 elsif Asmt_Lvl
= Library_Spec_Level
14026 or else Asmt_Lvl
= Instantiation_Level
14028 Add_Library_Spec_Scenario
(Asmt
);
14030 end Record_Variable_Assignment
;
14032 -------------------------------
14033 -- Record_Variable_Reference --
14034 -------------------------------
14036 procedure Record_Variable_Reference
14038 Ref_Lvl
: Enclosing_Level_Kind
)
14041 -- Add the variable reference to the appropriate set
14043 if Ref_Lvl
= Library_Body_Level
then
14044 Add_Library_Body_Scenario
(Ref
);
14046 elsif Ref_Lvl
= Library_Spec_Level
14047 or else Ref_Lvl
= Instantiation_Level
14049 Add_Library_Spec_Scenario
(Ref
);
14051 end Record_Variable_Reference
;
14055 Scen
: constant Node_Id
:= Scenario
(N
);
14056 Scen_Lvl
: Enclosing_Level_Kind
;
14058 -- Start of processing for Record_Elaboration_Scenario
14061 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
14062 -- enabled) is in effect because the legacy ABE mechanism does not need
14063 -- to carry out this action.
14065 if Legacy_Elaboration_Checks
then
14068 -- Nothing to do when the scenario is being preanalyzed
14070 elsif Preanalysis_Active
then
14073 -- Nothing to do when the elaboration phase of the compiler is not
14076 elsif not Elaboration_Phase_Active
then
14080 Scen_Lvl
:= Find_Enclosing_Level
(Scen
);
14082 -- Ensure that a library-level call does not appear in a preelaborated
14083 -- unit. The check must come before ignoring scenarios within external
14084 -- units or inside generics because calls in those context must also be
14087 if Is_Suitable_Call
(Scen
) then
14088 Check_Preelaborated_Call
(Scen
, Scen_Lvl
);
14091 -- Nothing to do when the scenario does not appear within the main unit
14093 if not In_Main_Context
(Scen
) then
14096 -- Nothing to do when the scenario appears within a generic
14098 elsif Inside_A_Generic
then
14103 elsif Is_Suitable_Access_Taken
(Scen
) then
14104 Record_Access_Taken
14106 Attr_Lvl
=> Scen_Lvl
);
14108 -- Call or task activation
14110 elsif Is_Suitable_Call
(Scen
) then
14111 Record_Call_Or_Task_Activation
14113 Call_Lvl
=> Scen_Lvl
);
14115 -- Derived type declaration
14117 elsif Is_Suitable_SPARK_Derived_Type
(Scen
) then
14118 Add_SPARK_Scenario
(Scen
);
14122 elsif Is_Suitable_Instantiation
(Scen
) then
14123 Record_Instantiation
14125 Inst_Lvl
=> Scen_Lvl
);
14127 -- Refined_State pragma
14129 elsif Is_Suitable_SPARK_Refined_State_Pragma
(Scen
) then
14130 Add_SPARK_Scenario
(Scen
);
14132 -- Variable assignment
14134 elsif Is_Suitable_Variable_Assignment
(Scen
) then
14135 Record_Variable_Assignment
14137 Asmt_Lvl
=> Scen_Lvl
);
14139 -- Variable reference
14141 elsif Is_Suitable_Variable_Reference
(Scen
) then
14142 Record_Variable_Reference
14144 Ref_Lvl
=> Scen_Lvl
);
14146 end Record_Elaboration_Scenario
;
14152 function Scenario
(N
: Node_Id
) return Node_Id
is
14153 Orig_N
: constant Node_Id
:= Original_Node
(N
);
14156 -- An expanded instantiation is rewritten into a spec-body pair where
14157 -- N denotes the spec. In this case the original instantiation is the
14158 -- proper elaboration scenario.
14160 if Nkind
(Orig_N
) in N_Generic_Instantiation
then
14163 -- Otherwise the scenario is already in its proper form
14170 ----------------------
14171 -- Scenario_Storage --
14172 ----------------------
14174 package body Scenario_Storage
is
14176 ---------------------
14177 -- Data structures --
14178 ---------------------
14180 -- The following sets store all scenarios
14182 Declaration_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14183 Dynamic_ABE_Check_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14184 Library_Body_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14185 Library_Spec_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14186 SPARK_Scenarios
: NE_Set
.Membership_Set
:= NE_Set
.Nil
;
14188 -------------------------------
14189 -- Finalize_Scenario_Storage --
14190 -------------------------------
14192 procedure Finalize_Scenario_Storage
is
14194 NE_Set
.Destroy
(Declaration_Scenarios
);
14195 NE_Set
.Destroy
(Dynamic_ABE_Check_Scenarios
);
14196 NE_Set
.Destroy
(Library_Body_Scenarios
);
14197 NE_Set
.Destroy
(Library_Spec_Scenarios
);
14198 NE_Set
.Destroy
(SPARK_Scenarios
);
14199 end Finalize_Scenario_Storage
;
14201 ---------------------------------
14202 -- Initialize_Scenario_Storage --
14203 ---------------------------------
14205 procedure Initialize_Scenario_Storage
is
14207 Declaration_Scenarios
:= NE_Set
.Create
(1000);
14208 Dynamic_ABE_Check_Scenarios
:= NE_Set
.Create
(500);
14209 Library_Body_Scenarios
:= NE_Set
.Create
(1000);
14210 Library_Spec_Scenarios
:= NE_Set
.Create
(1000);
14211 SPARK_Scenarios
:= NE_Set
.Create
(100);
14212 end Initialize_Scenario_Storage
;
14214 ------------------------------
14215 -- Add_Declaration_Scenario --
14216 ------------------------------
14218 procedure Add_Declaration_Scenario
(N
: Node_Id
) is
14219 pragma Assert
(Present
(N
));
14221 NE_Set
.Insert
(Declaration_Scenarios
, N
);
14222 end Add_Declaration_Scenario
;
14224 ------------------------------------
14225 -- Add_Dynamic_ABE_Check_Scenario --
14226 ------------------------------------
14228 procedure Add_Dynamic_ABE_Check_Scenario
(N
: Node_Id
) is
14229 pragma Assert
(Present
(N
));
14232 if not Check_Or_Failure_Generation_OK
then
14235 -- Nothing to do if the dynamic model is not in effect
14237 elsif not Dynamic_Elaboration_Checks
then
14241 NE_Set
.Insert
(Dynamic_ABE_Check_Scenarios
, N
);
14242 end Add_Dynamic_ABE_Check_Scenario
;
14244 -------------------------------
14245 -- Add_Library_Body_Scenario --
14246 -------------------------------
14248 procedure Add_Library_Body_Scenario
(N
: Node_Id
) is
14249 pragma Assert
(Present
(N
));
14251 NE_Set
.Insert
(Library_Body_Scenarios
, N
);
14252 end Add_Library_Body_Scenario
;
14254 -------------------------------
14255 -- Add_Library_Spec_Scenario --
14256 -------------------------------
14258 procedure Add_Library_Spec_Scenario
(N
: Node_Id
) is
14259 pragma Assert
(Present
(N
));
14261 NE_Set
.Insert
(Library_Spec_Scenarios
, N
);
14262 end Add_Library_Spec_Scenario
;
14264 ------------------------
14265 -- Add_SPARK_Scenario --
14266 ------------------------
14268 procedure Add_SPARK_Scenario
(N
: Node_Id
) is
14269 pragma Assert
(Present
(N
));
14271 NE_Set
.Insert
(SPARK_Scenarios
, N
);
14272 end Add_SPARK_Scenario
;
14274 ---------------------
14275 -- Delete_Scenario --
14276 ---------------------
14278 procedure Delete_Scenario
(N
: Node_Id
) is
14279 pragma Assert
(Present
(N
));
14282 -- Delete the scenario from whichever set it belongs to
14284 NE_Set
.Delete
(Declaration_Scenarios
, N
);
14285 NE_Set
.Delete
(Dynamic_ABE_Check_Scenarios
, N
);
14286 NE_Set
.Delete
(Library_Body_Scenarios
, N
);
14287 NE_Set
.Delete
(Library_Spec_Scenarios
, N
);
14288 NE_Set
.Delete
(SPARK_Scenarios
, N
);
14289 end Delete_Scenario
;
14291 -----------------------------------
14292 -- Iterate_Declaration_Scenarios --
14293 -----------------------------------
14295 function Iterate_Declaration_Scenarios
return NE_Set
.Iterator
is
14297 return NE_Set
.Iterate
(Declaration_Scenarios
);
14298 end Iterate_Declaration_Scenarios
;
14300 -----------------------------------------
14301 -- Iterate_Dynamic_ABE_Check_Scenarios --
14302 -----------------------------------------
14304 function Iterate_Dynamic_ABE_Check_Scenarios
return NE_Set
.Iterator
is
14306 return NE_Set
.Iterate
(Dynamic_ABE_Check_Scenarios
);
14307 end Iterate_Dynamic_ABE_Check_Scenarios
;
14309 ------------------------------------
14310 -- Iterate_Library_Body_Scenarios --
14311 ------------------------------------
14313 function Iterate_Library_Body_Scenarios
return NE_Set
.Iterator
is
14315 return NE_Set
.Iterate
(Library_Body_Scenarios
);
14316 end Iterate_Library_Body_Scenarios
;
14318 ------------------------------------
14319 -- Iterate_Library_Spec_Scenarios --
14320 ------------------------------------
14322 function Iterate_Library_Spec_Scenarios
return NE_Set
.Iterator
is
14324 return NE_Set
.Iterate
(Library_Spec_Scenarios
);
14325 end Iterate_Library_Spec_Scenarios
;
14327 -----------------------------
14328 -- Iterate_SPARK_Scenarios --
14329 -----------------------------
14331 function Iterate_SPARK_Scenarios
return NE_Set
.Iterator
is
14333 return NE_Set
.Iterate
(SPARK_Scenarios
);
14334 end Iterate_SPARK_Scenarios
;
14336 ----------------------
14337 -- Replace_Scenario --
14338 ----------------------
14340 procedure Replace_Scenario
(Old_N
: Node_Id
; New_N
: Node_Id
) is
14341 procedure Replace_Scenario_In
(Scenarios
: NE_Set
.Membership_Set
);
14342 -- Determine whether scenario Old_N is present in set Scenarios, and
14343 -- if this is the case it, replace it with New_N.
14345 -------------------------
14346 -- Replace_Scenario_In --
14347 -------------------------
14349 procedure Replace_Scenario_In
(Scenarios
: NE_Set
.Membership_Set
) is
14351 -- The set is intentionally checked for existance because node
14352 -- rewriting may occur after Sem_Elab has verified all scenarios
14353 -- and data structures have been destroyed.
14355 if NE_Set
.Present
(Scenarios
)
14356 and then NE_Set
.Contains
(Scenarios
, Old_N
)
14358 NE_Set
.Delete
(Scenarios
, Old_N
);
14359 NE_Set
.Insert
(Scenarios
, New_N
);
14361 end Replace_Scenario_In
;
14363 -- Start of processing for Replace_Scenario
14366 Replace_Scenario_In
(Declaration_Scenarios
);
14367 Replace_Scenario_In
(Dynamic_ABE_Check_Scenarios
);
14368 Replace_Scenario_In
(Library_Body_Scenarios
);
14369 Replace_Scenario_In
(Library_Spec_Scenarios
);
14370 Replace_Scenario_In
(SPARK_Scenarios
);
14371 end Replace_Scenario
;
14372 end Scenario_Storage
;
14378 package body Semantics
is
14380 --------------------------------
14381 -- Is_Accept_Alternative_Proc --
14382 --------------------------------
14384 function Is_Accept_Alternative_Proc
(Id
: Entity_Id
) return Boolean is
14386 -- To qualify, the entity must denote a procedure with a receiving
14390 Ekind
(Id
) = E_Procedure
and then Present
(Receiving_Entry
(Id
));
14391 end Is_Accept_Alternative_Proc
;
14393 ------------------------
14394 -- Is_Activation_Proc --
14395 ------------------------
14397 function Is_Activation_Proc
(Id
: Entity_Id
) return Boolean is
14399 -- To qualify, the entity must denote one of the runtime procedures
14400 -- in charge of task activation.
14402 if Ekind
(Id
) = E_Procedure
then
14403 if Restricted_Profile
then
14404 return Is_RTE
(Id
, RE_Activate_Restricted_Tasks
);
14406 return Is_RTE
(Id
, RE_Activate_Tasks
);
14411 end Is_Activation_Proc
;
14413 ----------------------------
14414 -- Is_Ada_Semantic_Target --
14415 ----------------------------
14417 function Is_Ada_Semantic_Target
(Id
: Entity_Id
) return Boolean is
14420 Is_Activation_Proc
(Id
)
14421 or else Is_Controlled_Procedure
(Id
, Name_Adjust
)
14422 or else Is_Controlled_Procedure
(Id
, Name_Finalize
)
14423 or else Is_Controlled_Procedure
(Id
, Name_Initialize
)
14424 or else Is_Init_Proc
(Id
)
14425 or else Is_Invariant_Proc
(Id
)
14426 or else Is_Protected_Entry
(Id
)
14427 or else Is_Protected_Subp
(Id
)
14428 or else Is_Protected_Body_Subp
(Id
)
14429 or else Is_Subprogram_Inst
(Id
)
14430 or else Is_Task_Entry
(Id
);
14431 end Is_Ada_Semantic_Target
;
14433 --------------------------------
14434 -- Is_Assertion_Pragma_Target --
14435 --------------------------------
14437 function Is_Assertion_Pragma_Target
(Id
: Entity_Id
) return Boolean is
14440 Is_Default_Initial_Condition_Proc
(Id
)
14441 or else Is_Initial_Condition_Proc
(Id
)
14442 or else Is_Invariant_Proc
(Id
)
14443 or else Is_Partial_Invariant_Proc
(Id
);
14444 end Is_Assertion_Pragma_Target
;
14446 ----------------------------
14447 -- Is_Bodiless_Subprogram --
14448 ----------------------------
14450 function Is_Bodiless_Subprogram
(Subp_Id
: Entity_Id
) return Boolean is
14452 -- An abstract subprogram does not have a body
14454 if Ekind
(Subp_Id
) in E_Function | E_Operator | E_Procedure
14455 and then Is_Abstract_Subprogram
(Subp_Id
)
14459 -- A formal subprogram does not have a body
14461 elsif Is_Formal_Subprogram
(Subp_Id
) then
14464 -- An imported subprogram may have a body, however it is not known at
14465 -- compile or bind time where the body resides and whether it will be
14466 -- elaborated on time.
14468 elsif Is_Imported
(Subp_Id
) then
14473 end Is_Bodiless_Subprogram
;
14475 ----------------------
14476 -- Is_Bridge_Target --
14477 ----------------------
14479 function Is_Bridge_Target
(Id
: Entity_Id
) return Boolean is
14482 Is_Accept_Alternative_Proc
(Id
)
14483 or else Is_Finalizer_Proc
(Id
)
14484 or else Is_Partial_Invariant_Proc
(Id
)
14485 or else Is_TSS
(Id
, TSS_Deep_Adjust
)
14486 or else Is_TSS
(Id
, TSS_Deep_Finalize
)
14487 or else Is_TSS
(Id
, TSS_Deep_Initialize
);
14488 end Is_Bridge_Target
;
14490 ---------------------------------------
14491 -- Is_Default_Initial_Condition_Proc --
14492 ---------------------------------------
14494 function Is_Default_Initial_Condition_Proc
14495 (Id
: Entity_Id
) return Boolean
14498 -- To qualify, the entity must denote a Default_Initial_Condition
14501 return Ekind
(Id
) = E_Procedure
and then Is_DIC_Procedure
(Id
);
14502 end Is_Default_Initial_Condition_Proc
;
14504 -----------------------
14505 -- Is_Finalizer_Proc --
14506 -----------------------
14508 function Is_Finalizer_Proc
(Id
: Entity_Id
) return Boolean is
14510 -- To qualify, the entity must denote a _Finalizer procedure
14512 return Ekind
(Id
) = E_Procedure
and then Chars
(Id
) = Name_uFinalizer
;
14513 end Is_Finalizer_Proc
;
14515 -------------------------------
14516 -- Is_Initial_Condition_Proc --
14517 -------------------------------
14519 function Is_Initial_Condition_Proc
(Id
: Entity_Id
) return Boolean is
14521 -- To qualify, the entity must denote an Initial_Condition procedure
14524 Ekind
(Id
) = E_Procedure
14525 and then Is_Initial_Condition_Procedure
(Id
);
14526 end Is_Initial_Condition_Proc
;
14528 --------------------
14529 -- Is_Initialized --
14530 --------------------
14532 function Is_Initialized
(Obj_Decl
: Node_Id
) return Boolean is
14534 -- To qualify, the object declaration must have an expression
14537 Present
(Expression
(Obj_Decl
))
14538 or else Has_Init_Expression
(Obj_Decl
);
14539 end Is_Initialized
;
14541 -----------------------
14542 -- Is_Invariant_Proc --
14543 -----------------------
14545 function Is_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
14547 -- To qualify, the entity must denote the "full" invariant procedure
14549 return Ekind
(Id
) = E_Procedure
and then Is_Invariant_Procedure
(Id
);
14550 end Is_Invariant_Proc
;
14552 ---------------------------------------
14553 -- Is_Non_Library_Level_Encapsulator --
14554 ---------------------------------------
14556 function Is_Non_Library_Level_Encapsulator
14557 (N
: Node_Id
) return Boolean
14561 when N_Abstract_Subprogram_Declaration
14562 | N_Aspect_Specification
14563 | N_Component_Declaration
14565 | N_Entry_Declaration
14566 | N_Expression_Function
14567 | N_Formal_Abstract_Subprogram_Declaration
14568 | N_Formal_Concrete_Subprogram_Declaration
14569 | N_Formal_Object_Declaration
14570 | N_Formal_Package_Declaration
14571 | N_Formal_Type_Declaration
14572 | N_Generic_Association
14573 | N_Implicit_Label_Declaration
14574 | N_Incomplete_Type_Declaration
14575 | N_Private_Extension_Declaration
14576 | N_Private_Type_Declaration
14578 | N_Protected_Type_Declaration
14579 | N_Single_Protected_Declaration
14580 | N_Single_Task_Declaration
14581 | N_Subprogram_Body
14582 | N_Subprogram_Declaration
14584 | N_Task_Type_Declaration
14589 return Is_Generic_Declaration_Or_Body
(N
);
14591 end Is_Non_Library_Level_Encapsulator
;
14593 -------------------------------
14594 -- Is_Partial_Invariant_Proc --
14595 -------------------------------
14597 function Is_Partial_Invariant_Proc
(Id
: Entity_Id
) return Boolean is
14599 -- To qualify, the entity must denote the "partial" invariant
14603 Ekind
(Id
) = E_Procedure
14604 and then Is_Partial_Invariant_Procedure
(Id
);
14605 end Is_Partial_Invariant_Proc
;
14607 ---------------------------
14608 -- Is_Preelaborated_Unit --
14609 ---------------------------
14611 function Is_Preelaborated_Unit
(Id
: Entity_Id
) return Boolean is
14614 Is_Preelaborated
(Id
)
14615 or else Is_Pure
(Id
)
14616 or else Is_Remote_Call_Interface
(Id
)
14617 or else Is_Remote_Types
(Id
)
14618 or else Is_Shared_Passive
(Id
);
14619 end Is_Preelaborated_Unit
;
14621 ------------------------
14622 -- Is_Protected_Entry --
14623 ------------------------
14625 function Is_Protected_Entry
(Id
: Entity_Id
) return Boolean is
14627 -- To qualify, the entity must denote an entry defined in a protected
14632 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
14633 end Is_Protected_Entry
;
14635 -----------------------
14636 -- Is_Protected_Subp --
14637 -----------------------
14639 function Is_Protected_Subp
(Id
: Entity_Id
) return Boolean is
14641 -- To qualify, the entity must denote a subprogram defined within a
14645 Ekind
(Id
) in E_Function | E_Procedure
14646 and then Is_Protected_Type
(Non_Private_View
(Scope
(Id
)));
14647 end Is_Protected_Subp
;
14649 ----------------------------
14650 -- Is_Protected_Body_Subp --
14651 ----------------------------
14653 function Is_Protected_Body_Subp
(Id
: Entity_Id
) return Boolean is
14655 -- To qualify, the entity must denote a subprogram with attribute
14656 -- Protected_Subprogram set.
14659 Ekind
(Id
) in E_Function | E_Procedure
14660 and then Present
(Protected_Subprogram
(Id
));
14661 end Is_Protected_Body_Subp
;
14667 function Is_Scenario
(N
: Node_Id
) return Boolean is
14670 when N_Assignment_Statement
14671 | N_Attribute_Reference
14673 | N_Entry_Call_Statement
14676 | N_Function_Instantiation
14678 | N_Package_Instantiation
14679 | N_Procedure_Call_Statement
14680 | N_Procedure_Instantiation
14681 | N_Requeue_Statement
14690 ------------------------------
14691 -- Is_SPARK_Semantic_Target --
14692 ------------------------------
14694 function Is_SPARK_Semantic_Target
(Id
: Entity_Id
) return Boolean is
14697 Is_Default_Initial_Condition_Proc
(Id
)
14698 or else Is_Initial_Condition_Proc
(Id
);
14699 end Is_SPARK_Semantic_Target
;
14701 ------------------------
14702 -- Is_Subprogram_Inst --
14703 ------------------------
14705 function Is_Subprogram_Inst
(Id
: Entity_Id
) return Boolean is
14707 -- To qualify, the entity must denote a function or a procedure which
14708 -- is hidden within an anonymous package, and is a generic instance.
14711 Ekind
(Id
) in E_Function | E_Procedure
14712 and then Is_Hidden
(Id
)
14713 and then Is_Generic_Instance
(Id
);
14714 end Is_Subprogram_Inst
;
14716 ------------------------------
14717 -- Is_Suitable_Access_Taken --
14718 ------------------------------
14720 function Is_Suitable_Access_Taken
(N
: Node_Id
) return Boolean is
14723 Subp_Id
: Entity_Id
;
14726 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
14728 if Debug_Flag_Dot_UU
then
14731 -- Nothing to do when the scenario is not an attribute reference
14733 elsif Nkind
(N
) /= N_Attribute_Reference
then
14736 -- Nothing to do for internally-generated attributes because they are
14737 -- assumed to be ABE safe.
14739 elsif not Comes_From_Source
(N
) then
14743 Nam
:= Attribute_Name
(N
);
14744 Pref
:= Prefix
(N
);
14746 -- Sanitize the prefix of the attribute
14748 if not Is_Entity_Name
(Pref
) then
14751 elsif No
(Entity
(Pref
)) then
14755 Subp_Id
:= Entity
(Pref
);
14757 if not Is_Subprogram_Or_Entry
(Subp_Id
) then
14761 -- Traverse a possible chain of renamings to obtain the original
14762 -- entry or subprogram which the prefix may rename.
14764 Subp_Id
:= Get_Renamed_Entity
(Subp_Id
);
14766 -- To qualify, the attribute must meet the following prerequisites:
14770 -- The prefix must denote a source entry, operator, or subprogram
14771 -- which is not imported.
14773 Comes_From_Source
(Subp_Id
)
14774 and then Is_Subprogram_Or_Entry
(Subp_Id
)
14775 and then not Is_Bodiless_Subprogram
(Subp_Id
)
14777 -- The attribute name must be one of the 'Access forms. Note that
14778 -- 'Unchecked_Access cannot apply to a subprogram.
14780 and then Nam
in Name_Access | Name_Unrestricted_Access
;
14781 end Is_Suitable_Access_Taken
;
14783 ----------------------
14784 -- Is_Suitable_Call --
14785 ----------------------
14787 function Is_Suitable_Call
(N
: Node_Id
) return Boolean is
14789 -- Entry and subprogram calls are intentionally ignored because they
14790 -- may undergo expansion depending on the compilation mode, previous
14791 -- errors, generic context, etc. Call markers play the role of calls
14792 -- and provide a uniform foundation for ABE processing.
14794 return Nkind
(N
) = N_Call_Marker
;
14795 end Is_Suitable_Call
;
14797 -------------------------------
14798 -- Is_Suitable_Instantiation --
14799 -------------------------------
14801 function Is_Suitable_Instantiation
(N
: Node_Id
) return Boolean is
14802 Inst
: constant Node_Id
:= Scenario
(N
);
14805 -- To qualify, the instantiation must come from source
14808 Comes_From_Source
(Inst
)
14809 and then Nkind
(Inst
) in N_Generic_Instantiation
;
14810 end Is_Suitable_Instantiation
;
14812 ------------------------------------
14813 -- Is_Suitable_SPARK_Derived_Type --
14814 ------------------------------------
14816 function Is_Suitable_SPARK_Derived_Type
(N
: Node_Id
) return Boolean is
14821 -- To qualify, the type declaration must denote a derived tagged type
14822 -- with primitive operations, subject to pragma SPARK_Mode On.
14824 if Nkind
(N
) = N_Full_Type_Declaration
14825 and then Nkind
(Type_Definition
(N
)) = N_Derived_Type_Definition
14827 Typ
:= Defining_Entity
(N
);
14828 Prag
:= SPARK_Pragma
(Typ
);
14831 Is_Tagged_Type
(Typ
)
14832 and then Has_Primitive_Operations
(Typ
)
14833 and then Present
(Prag
)
14834 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
;
14838 end Is_Suitable_SPARK_Derived_Type
;
14840 -------------------------------------
14841 -- Is_Suitable_SPARK_Instantiation --
14842 -------------------------------------
14844 function Is_Suitable_SPARK_Instantiation
(N
: Node_Id
) return Boolean is
14845 Inst
: constant Node_Id
:= Scenario
(N
);
14847 Gen_Id
: Entity_Id
;
14851 -- To qualify, both the instantiation and the generic must be subject
14852 -- to SPARK_Mode On.
14854 if Is_Suitable_Instantiation
(N
) then
14855 Gen_Id
:= Instantiated_Generic
(Inst
);
14856 Prag
:= SPARK_Pragma
(Gen_Id
);
14859 Is_SPARK_Mode_On_Node
(Inst
)
14860 and then Present
(Prag
)
14861 and then Get_SPARK_Mode_From_Annotation
(Prag
) = On
;
14865 end Is_Suitable_SPARK_Instantiation
;
14867 --------------------------------------------
14868 -- Is_Suitable_SPARK_Refined_State_Pragma --
14869 --------------------------------------------
14871 function Is_Suitable_SPARK_Refined_State_Pragma
14872 (N
: Node_Id
) return Boolean
14875 -- To qualfy, the pragma must denote Refined_State
14878 Nkind
(N
) = N_Pragma
14879 and then Pragma_Name
(N
) = Name_Refined_State
;
14880 end Is_Suitable_SPARK_Refined_State_Pragma
;
14882 -------------------------------------
14883 -- Is_Suitable_Variable_Assignment --
14884 -------------------------------------
14886 function Is_Suitable_Variable_Assignment
(N
: Node_Id
) return Boolean is
14888 N_Unit_Id
: Entity_Id
;
14890 Var_Decl
: Node_Id
;
14891 Var_Id
: Entity_Id
;
14892 Var_Unit
: Node_Id
;
14893 Var_Unit_Id
: Entity_Id
;
14896 -- Nothing to do when the scenario is not an assignment
14898 if Nkind
(N
) /= N_Assignment_Statement
then
14901 -- Nothing to do for internally-generated assignments because they
14902 -- are assumed to be ABE safe.
14904 elsif not Comes_From_Source
(N
) then
14907 -- Assignments are ignored in GNAT mode on the assumption that
14908 -- they are ABE-safe. This behavior parallels that of the old
14911 elsif GNAT_Mode
then
14915 Nam
:= Assignment_Target
(N
);
14917 -- Sanitize the left hand side of the assignment
14919 if not Is_Entity_Name
(Nam
) then
14922 elsif No
(Entity
(Nam
)) then
14926 Var_Id
:= Entity
(Nam
);
14928 -- Sanitize the variable
14930 if Var_Id
= Any_Id
then
14933 elsif Ekind
(Var_Id
) /= E_Variable
then
14937 Var_Decl
:= Declaration_Node
(Var_Id
);
14939 if Nkind
(Var_Decl
) /= N_Object_Declaration
then
14943 N_Unit_Id
:= Find_Top_Unit
(N
);
14944 N_Unit
:= Unit_Declaration_Node
(N_Unit_Id
);
14946 Var_Unit_Id
:= Find_Top_Unit
(Var_Decl
);
14947 Var_Unit
:= Unit_Declaration_Node
(Var_Unit_Id
);
14949 -- To qualify, the assignment must meet the following prerequisites:
14952 Comes_From_Source
(Var_Id
)
14954 -- The variable must be declared in the spec of compilation unit
14957 and then Nkind
(Var_Unit
) = N_Package_Declaration
14958 and then Find_Enclosing_Level
(Var_Decl
) = Library_Spec_Level
14960 -- The assignment must occur in the body of compilation unit U
14962 and then Nkind
(N_Unit
) = N_Package_Body
14963 and then Present
(Corresponding_Body
(Var_Unit
))
14964 and then Corresponding_Body
(Var_Unit
) = N_Unit_Id
;
14965 end Is_Suitable_Variable_Assignment
;
14967 ------------------------------------
14968 -- Is_Suitable_Variable_Reference --
14969 ------------------------------------
14971 function Is_Suitable_Variable_Reference
(N
: Node_Id
) return Boolean is
14973 -- Expanded names and identifiers are intentionally ignored because
14974 -- they be folded, optimized away, etc. Variable references markers
14975 -- play the role of variable references and provide a uniform
14976 -- foundation for ABE processing.
14978 return Nkind
(N
) = N_Variable_Reference_Marker
;
14979 end Is_Suitable_Variable_Reference
;
14981 -------------------
14982 -- Is_Task_Entry --
14983 -------------------
14985 function Is_Task_Entry
(Id
: Entity_Id
) return Boolean is
14987 -- To qualify, the entity must denote an entry defined in a task type
14990 Is_Entry
(Id
) and then Is_Task_Type
(Non_Private_View
(Scope
(Id
)));
14993 ------------------------
14994 -- Is_Up_Level_Target --
14995 ------------------------
14997 function Is_Up_Level_Target
14998 (Targ_Decl
: Node_Id
;
14999 In_State
: Processing_In_State
) return Boolean
15001 Root
: constant Node_Id
:= Root_Scenario
;
15002 Root_Rep
: constant Scenario_Rep_Id
:=
15003 Scenario_Representation_Of
(Root
, In_State
);
15006 -- The root appears within the declaratons of a block statement,
15007 -- entry body, subprogram body, or task body ignoring enclosing
15008 -- packages. The root is always within the main unit.
15010 if not In_State
.Suppress_Up_Level_Targets
15011 and then Level
(Root_Rep
) = Declaration_Level
15013 -- The target is within the main unit. It acts as an up-level
15014 -- target when it appears within a context which encloses the
15017 -- package body Main_Unit is
15018 -- function Func ...; -- target
15020 -- procedure Proc is
15021 -- X : ... := Func; -- root scenario
15023 if In_Extended_Main_Code_Unit
(Targ_Decl
) then
15024 return not In_Same_Context
(Root
, Targ_Decl
, Nested_OK
=> True);
15026 -- Otherwise the target is external to the main unit which makes
15027 -- it an up-level target.
15035 end Is_Up_Level_Target
;
15038 ---------------------------
15039 -- Set_Elaboration_Phase --
15040 ---------------------------
15042 procedure Set_Elaboration_Phase
(Status
: Elaboration_Phase_Status
) is
15044 Elaboration_Phase
:= Status
;
15045 end Set_Elaboration_Phase
;
15047 ---------------------
15048 -- SPARK_Processor --
15049 ---------------------
15051 package body SPARK_Processor
is
15053 -----------------------
15054 -- Local subprograms --
15055 -----------------------
15057 procedure Process_SPARK_Derived_Type
15058 (Typ_Decl
: Node_Id
;
15059 Typ_Rep
: Scenario_Rep_Id
;
15060 In_State
: Processing_In_State
);
15061 pragma Inline
(Process_SPARK_Derived_Type
);
15062 -- Verify that the freeze node of a derived type denoted by declaration
15063 -- Typ_Decl is within the early call region of each overriding primitive
15064 -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is
15065 -- the representation of the type. In_State denotes the current state of
15066 -- the Processing phase.
15068 procedure Process_SPARK_Instantiation
15070 Inst_Rep
: Scenario_Rep_Id
;
15071 In_State
: Processing_In_State
);
15072 pragma Inline
(Process_SPARK_Instantiation
);
15073 -- Verify that instantiation Inst does not precede the generic body it
15074 -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the
15075 -- instantiation. In_State is the current state of the Processing phase.
15077 procedure Process_SPARK_Refined_State_Pragma
15079 Prag_Rep
: Scenario_Rep_Id
;
15080 In_State
: Processing_In_State
);
15081 pragma Inline
(Process_SPARK_Refined_State_Pragma
);
15082 -- Verify that each constituent of Refined_State pragma Prag which
15083 -- belongs to abstract state mentioned in pragma Initializes has prior
15084 -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)).
15085 -- Prag_Rep is the representation of the pragma. In_State denotes the
15086 -- current state of the Processing phase.
15088 procedure Process_SPARK_Scenario
15090 In_State
: Processing_In_State
);
15091 pragma Inline
(Process_SPARK_Scenario
);
15092 -- Top-level dispatcher for verifying SPARK scenarios which are not
15093 -- always executable during elaboration but still need elaboration-
15094 -- related checks. In_State is the current state of the Processing
15097 ---------------------------------
15098 -- Check_SPARK_Model_In_Effect --
15099 ---------------------------------
15101 SPARK_Model_Warning_Posted
: Boolean := False;
15102 -- This flag prevents the same SPARK model-related warning from being
15103 -- emitted multiple times.
15105 procedure Check_SPARK_Model_In_Effect
is
15106 Spec_Id
: constant Entity_Id
:= Unique_Entity
(Main_Unit_Entity
);
15109 -- Do not emit the warning multiple times as this creates useless
15112 if SPARK_Model_Warning_Posted
then
15115 -- SPARK rule verification requires the "strict" static model
15117 elsif Static_Elaboration_Checks
15118 and not Relaxed_Elaboration_Checks
15122 -- Any other combination of models does not guarantee the absence of
15123 -- ABE problems for SPARK rule verification purposes. Note that there
15124 -- is no need to check for the presence of the legacy ABE mechanism
15125 -- because the legacy code has its own dedicated processing for SPARK
15129 SPARK_Model_Warning_Posted
:= True;
15132 ("??SPARK elaboration checks require static elaboration model",
15135 if Dynamic_Elaboration_Checks
then
15137 ("\dynamic elaboration model is in effect", Spec_Id
);
15140 pragma Assert
(Relaxed_Elaboration_Checks
);
15142 ("\relaxed elaboration model is in effect", Spec_Id
);
15145 end Check_SPARK_Model_In_Effect
;
15147 ---------------------------
15148 -- Check_SPARK_Scenarios --
15149 ---------------------------
15151 procedure Check_SPARK_Scenarios
is
15152 Iter
: NE_Set
.Iterator
;
15156 Iter
:= Iterate_SPARK_Scenarios
;
15157 while NE_Set
.Has_Next
(Iter
) loop
15158 NE_Set
.Next
(Iter
, N
);
15160 Process_SPARK_Scenario
15162 In_State
=> SPARK_State
);
15164 end Check_SPARK_Scenarios
;
15166 --------------------------------
15167 -- Process_SPARK_Derived_Type --
15168 --------------------------------
15170 procedure Process_SPARK_Derived_Type
15171 (Typ_Decl
: Node_Id
;
15172 Typ_Rep
: Scenario_Rep_Id
;
15173 In_State
: Processing_In_State
)
15175 pragma Unreferenced
(In_State
);
15177 Typ
: constant Entity_Id
:= Target
(Typ_Rep
);
15179 Stop_Check
: exception;
15180 -- This exception is raised when the freeze node violates the
15181 -- placement rules.
15183 procedure Check_Overriding_Primitive
15186 pragma Inline
(Check_Overriding_Primitive
);
15187 -- Verify that freeze node FNode is within the early call region of
15188 -- overriding primitive Prim's body.
15190 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
;
15191 pragma Inline
(Freeze_Node_Location
);
15192 -- Return a more accurate source location associated with freeze node
15195 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean;
15196 pragma Inline
(Precedes_Source_Construct
);
15197 -- Determine whether arbitrary node N appears prior to some source
15200 procedure Suggest_Elaborate_Body
15202 Body_Decl
: Node_Id
;
15203 Error_Nod
: Node_Id
);
15204 pragma Inline
(Suggest_Elaborate_Body
);
15205 -- Suggest the use of pragma Elaborate_Body when the pragma will
15206 -- allow for node N to appear within the early call region of
15207 -- subprogram body Body_Decl. The suggestion is attached to
15208 -- Error_Nod as a continuation error.
15210 --------------------------------
15211 -- Check_Overriding_Primitive --
15212 --------------------------------
15214 procedure Check_Overriding_Primitive
15218 Prim_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Prim
);
15219 Body_Decl
: Node_Id
;
15220 Body_Id
: Entity_Id
;
15224 -- Nothing to do for predefined primitives because they are
15225 -- artifacts of tagged type expansion and cannot override source
15226 -- primitives. Nothing to do as well for inherited primitives, as
15227 -- the check concerns overriding ones. Finally, nothing to do for
15228 -- abstract subprograms, because they have no body that could be
15231 if Is_Predefined_Dispatching_Operation
(Prim
)
15232 or else not Is_Overriding_Subprogram
(Prim
)
15233 or else Is_Abstract_Subprogram
(Prim
)
15238 Body_Id
:= Corresponding_Body
(Prim_Decl
);
15240 -- Nothing to do when the primitive does not have a corresponding
15241 -- body. This can happen when the unit with the bodies is not the
15242 -- main unit subjected to ABE checks.
15244 if No
(Body_Id
) then
15247 -- The primitive overrides a parent or progenitor primitive
15249 elsif Present
(Overridden_Operation
(Prim
)) then
15251 -- Nothing to do when overriding an interface primitive happens
15252 -- by inheriting a non-interface primitive as the check would
15253 -- be done on the parent primitive.
15255 if Present
(Alias
(Prim
)) then
15259 -- Nothing to do when the primitive is not overriding. The body of
15260 -- such a primitive cannot be targeted by a dispatching call which
15261 -- is executable during elaboration, and cannot cause an ABE.
15267 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
15268 Region
:= Find_Early_Call_Region
(Body_Decl
);
15270 -- The freeze node appears prior to the early call region of the
15273 -- IMPORTANT: This check must always be performed even when
15274 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
15275 -- specified because the static model cannot guarantee the absence
15276 -- of ABEs in the presence of dispatching calls.
15278 if Earlier_In_Extended_Unit
(FNode
, Region
) then
15279 Error_Msg_Node_2
:= Prim
;
15280 Error_Msg_Code
:= GEC_Type_Early_Call_Region
;
15282 ("first freezing point of type & must appear within early "
15283 & "call region of primitive body '[[]']",
15286 Error_Msg_Sloc
:= Sloc
(Region
);
15287 Error_Msg_N
("\region starts #", Typ_Decl
);
15289 Error_Msg_Sloc
:= Sloc
(Body_Decl
);
15290 Error_Msg_N
("\region ends #", Typ_Decl
);
15292 Error_Msg_Sloc
:= Freeze_Node_Location
(FNode
);
15293 Error_Msg_N
("\first freezing point #", Typ_Decl
);
15295 -- If applicable, suggest the use of pragma Elaborate_Body in
15296 -- the associated package spec.
15298 Suggest_Elaborate_Body
15300 Body_Decl
=> Body_Decl
,
15301 Error_Nod
=> Typ_Decl
);
15305 end Check_Overriding_Primitive
;
15307 --------------------------
15308 -- Freeze_Node_Location --
15309 --------------------------
15311 function Freeze_Node_Location
(FNode
: Node_Id
) return Source_Ptr
is
15312 Context
: constant Node_Id
:= Parent
(FNode
);
15313 Loc
: constant Source_Ptr
:= Sloc
(FNode
);
15315 Prv_Decls
: List_Id
;
15316 Vis_Decls
: List_Id
;
15319 -- In general, the source location of the freeze node is as close
15320 -- as possible to the real freeze point, except when the freeze
15321 -- node is at the "bottom" of a package spec.
15323 if Nkind
(Context
) = N_Package_Specification
then
15324 Prv_Decls
:= Private_Declarations
(Context
);
15325 Vis_Decls
:= Visible_Declarations
(Context
);
15327 -- The freeze node appears in the private declarations of the
15330 if Present
(Prv_Decls
)
15331 and then List_Containing
(FNode
) = Prv_Decls
15335 -- The freeze node appears in the visible declarations of the
15336 -- package and there are no private declarations.
15338 elsif Present
(Vis_Decls
)
15339 and then List_Containing
(FNode
) = Vis_Decls
15340 and then Is_Empty_List
(Prv_Decls
)
15344 -- Otherwise the freeze node is not in the "last" declarative
15345 -- list of the package. Use the existing source location of the
15352 -- The freeze node appears at the "bottom" of the package when
15353 -- it is in the "last" declarative list and is either the last
15354 -- in the list or is followed by internal constructs only. In
15355 -- that case the more appropriate source location is that of
15356 -- the package end label.
15358 if not Precedes_Source_Construct
(FNode
) then
15359 return Sloc
(End_Label
(Context
));
15364 end Freeze_Node_Location
;
15366 -------------------------------
15367 -- Precedes_Source_Construct --
15368 -------------------------------
15370 function Precedes_Source_Construct
(N
: Node_Id
) return Boolean is
15375 while Present
(Decl
) loop
15376 if Comes_From_Source
(Decl
) then
15379 -- A generated body for a source expression function is treated
15380 -- as a source construct.
15382 elsif Nkind
(Decl
) = N_Subprogram_Body
15383 and then Was_Expression_Function
(Decl
)
15384 and then Comes_From_Source
(Original_Node
(Decl
))
15393 end Precedes_Source_Construct
;
15395 ----------------------------
15396 -- Suggest_Elaborate_Body --
15397 ----------------------------
15399 procedure Suggest_Elaborate_Body
15401 Body_Decl
: Node_Id
;
15402 Error_Nod
: Node_Id
)
15404 Unit_Id
: constant Node_Id
:= Unit
(Cunit
(Main_Unit
));
15408 -- The suggestion applies only when the subprogram body resides in
15409 -- a compilation package body, and a pragma Elaborate_Body would
15410 -- allow for the node to appear in the early call region of the
15411 -- subprogram body. This implies that all code from the subprogram
15412 -- body up to the node is preelaborable.
15414 if Nkind
(Unit_Id
) = N_Package_Body
then
15416 -- Find the start of the early call region again assuming that
15417 -- the package spec has pragma Elaborate_Body. Note that the
15418 -- internal data structures are intentionally not updated
15419 -- because this is a speculative search.
15422 Find_Early_Call_Region
15423 (Body_Decl
=> Body_Decl
,
15424 Assume_Elab_Body
=> True,
15425 Skip_Memoization
=> True);
15427 -- If the node appears within the early call region, assuming
15428 -- that the package spec carries pragma Elaborate_Body, then it
15429 -- is safe to suggest the pragma.
15431 if Earlier_In_Extended_Unit
(Region
, N
) then
15432 Error_Msg_Name_1
:= Name_Elaborate_Body
;
15434 ("\consider adding pragma % in spec of unit &",
15435 Error_Nod
, Defining_Entity
(Unit_Id
));
15438 end Suggest_Elaborate_Body
;
15442 FNode
: constant Node_Id
:= Freeze_Node
(Typ
);
15443 Prims
: constant Elist_Id
:= Direct_Primitive_Operations
(Typ
);
15445 Prim_Elmt
: Elmt_Id
;
15447 -- Start of processing for Process_SPARK_Derived_Type
15450 -- A type should have its freeze node set by the time SPARK scenarios
15451 -- are being verified.
15453 pragma Assert
(Present
(FNode
));
15455 -- Verify that the freeze node of the derived type is within the
15456 -- early call region of each overriding primitive body
15457 -- (SPARK RM 7.7(8)).
15459 if Present
(Prims
) then
15460 Prim_Elmt
:= First_Elmt
(Prims
);
15461 while Present
(Prim_Elmt
) loop
15462 Check_Overriding_Primitive
15463 (Prim
=> Node
(Prim_Elmt
),
15466 Next_Elmt
(Prim_Elmt
);
15473 end Process_SPARK_Derived_Type
;
15475 ---------------------------------
15476 -- Process_SPARK_Instantiation --
15477 ---------------------------------
15479 procedure Process_SPARK_Instantiation
15481 Inst_Rep
: Scenario_Rep_Id
;
15482 In_State
: Processing_In_State
)
15484 Gen_Id
: constant Entity_Id
:= Target
(Inst_Rep
);
15485 Gen_Rep
: constant Target_Rep_Id
:=
15486 Target_Representation_Of
(Gen_Id
, In_State
);
15487 Body_Decl
: constant Node_Id
:= Body_Declaration
(Gen_Rep
);
15490 -- The instantiation and the generic body are both in the main unit
15492 if Present
(Body_Decl
)
15493 and then In_Extended_Main_Code_Unit
(Body_Decl
)
15495 -- If the instantiation appears prior to the generic body, then the
15496 -- instantiation is illegal (SPARK RM 7.7(6)).
15498 -- IMPORTANT: This check must always be performed even when
15499 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
15500 -- specified because the rule prevents use-before-declaration of
15501 -- objects that may precede the generic body.
15503 and then Earlier_In_Extended_Unit
(Inst
, Body_Decl
)
15506 ("cannot instantiate & before body seen", Inst
, Gen_Id
);
15508 end Process_SPARK_Instantiation
;
15510 ----------------------------
15511 -- Process_SPARK_Scenario --
15512 ----------------------------
15514 procedure Process_SPARK_Scenario
15516 In_State
: Processing_In_State
)
15518 Scen
: constant Node_Id
:= Scenario
(N
);
15521 -- Ensure that a suitable elaboration model is in effect for SPARK
15522 -- rule verification.
15524 Check_SPARK_Model_In_Effect
;
15526 -- Add the current scenario to the stack of active scenarios
15528 Push_Active_Scenario
(Scen
);
15532 if Is_Suitable_SPARK_Derived_Type
(Scen
) then
15533 Process_SPARK_Derived_Type
15535 Typ_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
15536 In_State
=> In_State
);
15540 elsif Is_Suitable_SPARK_Instantiation
(Scen
) then
15541 Process_SPARK_Instantiation
15543 Inst_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
15544 In_State
=> In_State
);
15546 -- Refined_State pragma
15548 elsif Is_Suitable_SPARK_Refined_State_Pragma
(Scen
) then
15549 Process_SPARK_Refined_State_Pragma
15551 Prag_Rep
=> Scenario_Representation_Of
(Scen
, In_State
),
15552 In_State
=> In_State
);
15555 -- Remove the current scenario from the stack of active scenarios
15556 -- once all ABE diagnostics and checks have been performed.
15558 Pop_Active_Scenario
(Scen
);
15559 end Process_SPARK_Scenario
;
15561 ----------------------------------------
15562 -- Process_SPARK_Refined_State_Pragma --
15563 ----------------------------------------
15565 procedure Process_SPARK_Refined_State_Pragma
15567 Prag_Rep
: Scenario_Rep_Id
;
15568 In_State
: Processing_In_State
)
15570 pragma Unreferenced
(Prag_Rep
);
15572 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
);
15573 pragma Inline
(Check_SPARK_Constituent
);
15574 -- Ensure that a single constituent Constit_Id is elaborated prior to
15577 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
);
15578 pragma Inline
(Check_SPARK_Constituents
);
15579 -- Ensure that all constituents found in list Constits are elaborated
15580 -- prior to the main unit.
15582 procedure Check_SPARK_Initialized_State
(State
: Node_Id
);
15583 pragma Inline
(Check_SPARK_Initialized_State
);
15584 -- Ensure that the constituents of single abstract state State are
15585 -- elaborated prior to the main unit.
15587 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
);
15588 pragma Inline
(Check_SPARK_Initialized_States
);
15589 -- Ensure that the constituents of all abstract states which appear
15590 -- in the Initializes pragma of package Pack_Id are elaborated prior
15591 -- to the main unit.
15593 -----------------------------
15594 -- Check_SPARK_Constituent --
15595 -----------------------------
15597 procedure Check_SPARK_Constituent
(Constit_Id
: Entity_Id
) is
15601 -- Nothing to do for "null" constituents
15603 if Nkind
(Constit_Id
) = N_Null
then
15606 -- Nothing to do for illegal constituents
15608 elsif Error_Posted
(Constit_Id
) then
15612 SM_Prag
:= SPARK_Pragma
(Constit_Id
);
15614 -- The check applies only when the constituent is subject to
15615 -- pragma SPARK_Mode On.
15617 if Present
(SM_Prag
)
15618 and then Get_SPARK_Mode_From_Annotation
(SM_Prag
) = On
15620 -- An external constituent of an abstract state which appears
15621 -- in the Initializes pragma of a package spec imposes an
15622 -- Elaborate requirement on the context of the main unit.
15623 -- Determine whether the context has a pragma strong enough to
15624 -- meet the requirement.
15626 -- IMPORTANT: This check is performed only when -gnatd.v
15627 -- (enforce SPARK elaboration rules in SPARK code) is in effect
15628 -- because the static model can ensure the prior elaboration of
15629 -- the unit which contains a constituent by installing implicit
15630 -- Elaborate pragma.
15632 if Debug_Flag_Dot_V
then
15633 Meet_Elaboration_Requirement
15635 Targ_Id
=> Constit_Id
,
15636 Req_Nam
=> Name_Elaborate
,
15637 In_State
=> In_State
);
15639 -- Otherwise ensure that the unit with the external constituent
15640 -- is elaborated prior to the main unit.
15643 Ensure_Prior_Elaboration
15645 Unit_Id
=> Find_Top_Unit
(Constit_Id
),
15646 Prag_Nam
=> Name_Elaborate
,
15647 In_State
=> In_State
);
15650 end Check_SPARK_Constituent
;
15652 ------------------------------
15653 -- Check_SPARK_Constituents --
15654 ------------------------------
15656 procedure Check_SPARK_Constituents
(Constits
: Elist_Id
) is
15657 Constit_Elmt
: Elmt_Id
;
15660 if Present
(Constits
) then
15661 Constit_Elmt
:= First_Elmt
(Constits
);
15662 while Present
(Constit_Elmt
) loop
15663 Check_SPARK_Constituent
(Node
(Constit_Elmt
));
15664 Next_Elmt
(Constit_Elmt
);
15667 end Check_SPARK_Constituents
;
15669 -----------------------------------
15670 -- Check_SPARK_Initialized_State --
15671 -----------------------------------
15673 procedure Check_SPARK_Initialized_State
(State
: Node_Id
) is
15675 State_Id
: Entity_Id
;
15678 -- Nothing to do for "null" initialization items
15680 if Nkind
(State
) = N_Null
then
15683 -- Nothing to do for illegal states
15685 elsif Error_Posted
(State
) then
15689 State_Id
:= Entity_Of
(State
);
15691 -- Sanitize the state
15693 if No
(State_Id
) then
15696 elsif Error_Posted
(State_Id
) then
15699 elsif Ekind
(State_Id
) /= E_Abstract_State
then
15703 -- The check is performed only when the abstract state is subject
15704 -- to SPARK_Mode On.
15706 SM_Prag
:= SPARK_Pragma
(State_Id
);
15708 if Present
(SM_Prag
)
15709 and then Get_SPARK_Mode_From_Annotation
(SM_Prag
) = On
15711 Check_SPARK_Constituents
(Refinement_Constituents
(State_Id
));
15713 end Check_SPARK_Initialized_State
;
15715 ------------------------------------
15716 -- Check_SPARK_Initialized_States --
15717 ------------------------------------
15719 procedure Check_SPARK_Initialized_States
(Pack_Id
: Entity_Id
) is
15720 Init_Prag
: constant Node_Id
:=
15721 Get_Pragma
(Pack_Id
, Pragma_Initializes
);
15727 if Present
(Init_Prag
) then
15728 Inits
:= Expression
(Get_Argument
(Init_Prag
, Pack_Id
));
15730 -- Avoid processing a "null" initialization list. The only
15731 -- other alternative is an aggregate.
15733 if Nkind
(Inits
) = N_Aggregate
then
15735 -- The initialization items appear in list form:
15737 -- (state1, state2)
15739 if Present
(Expressions
(Inits
)) then
15740 Init
:= First
(Expressions
(Inits
));
15741 while Present
(Init
) loop
15742 Check_SPARK_Initialized_State
(Init
);
15747 -- The initialization items appear in associated form:
15749 -- (state1 => item1,
15750 -- state2 => (item2, item3))
15752 if Present
(Component_Associations
(Inits
)) then
15753 Init
:= First
(Component_Associations
(Inits
));
15754 while Present
(Init
) loop
15755 Check_SPARK_Initialized_State
(Init
);
15761 end Check_SPARK_Initialized_States
;
15765 Pack_Body
: constant Node_Id
:= Find_Related_Package_Or_Body
(Prag
);
15767 -- Start of processing for Process_SPARK_Refined_State_Pragma
15770 -- Pragma Refined_State must be associated with a package body
15773 (Present
(Pack_Body
) and then Nkind
(Pack_Body
) = N_Package_Body
);
15775 -- Verify that each external contitunent of an abstract state
15776 -- mentioned in pragma Initializes is properly elaborated.
15778 Check_SPARK_Initialized_States
(Unique_Defining_Entity
(Pack_Body
));
15779 end Process_SPARK_Refined_State_Pragma
;
15780 end SPARK_Processor
;
15782 -------------------------------
15783 -- Spec_And_Body_From_Entity --
15784 -------------------------------
15786 procedure Spec_And_Body_From_Entity
15788 Spec_Decl
: out Node_Id
;
15789 Body_Decl
: out Node_Id
)
15792 Spec_And_Body_From_Node
15793 (N
=> Unit_Declaration_Node
(Id
),
15794 Spec_Decl
=> Spec_Decl
,
15795 Body_Decl
=> Body_Decl
);
15796 end Spec_And_Body_From_Entity
;
15798 -----------------------------
15799 -- Spec_And_Body_From_Node --
15800 -----------------------------
15802 procedure Spec_And_Body_From_Node
15804 Spec_Decl
: out Node_Id
;
15805 Body_Decl
: out Node_Id
)
15807 Body_Id
: Entity_Id
;
15808 Spec_Id
: Entity_Id
;
15811 -- Assume that the construct lacks spec and body
15813 Body_Decl
:= Empty
;
15814 Spec_Decl
:= Empty
;
15818 if Nkind
(N
) in N_Package_Body
15820 | N_Subprogram_Body
15823 Spec_Id
:= Corresponding_Spec
(N
);
15825 -- The body completes a previous declaration
15827 if Present
(Spec_Id
) then
15828 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
15830 -- Otherwise the body acts as the initial declaration, and is both a
15831 -- spec and body. There is no need to look for an optional body.
15841 elsif Nkind
(N
) in N_Entry_Declaration
15842 | N_Generic_Package_Declaration
15843 | N_Generic_Subprogram_Declaration
15844 | N_Package_Declaration
15845 | N_Protected_Type_Declaration
15846 | N_Subprogram_Declaration
15847 | N_Task_Type_Declaration
15851 -- Expression function
15853 elsif Nkind
(N
) = N_Expression_Function
then
15854 Spec_Id
:= Corresponding_Spec
(N
);
15855 pragma Assert
(Present
(Spec_Id
));
15857 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
15861 elsif Nkind
(N
) in N_Generic_Instantiation
then
15862 Spec_Decl
:= Instance_Spec
(N
);
15863 pragma Assert
(Present
(Spec_Decl
));
15867 elsif Nkind
(N
) in N_Body_Stub
then
15868 Spec_Id
:= Corresponding_Spec_Of_Stub
(N
);
15870 -- The stub completes a previous declaration
15872 if Present
(Spec_Id
) then
15873 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
15875 -- Otherwise the stub acts as a spec
15882 -- Obtain an optional or mandatory body
15884 if Present
(Spec_Decl
) then
15885 Body_Id
:= Corresponding_Body
(Spec_Decl
);
15887 if Present
(Body_Id
) then
15888 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
15891 end Spec_And_Body_From_Node
;
15893 -------------------------------
15894 -- Static_Elaboration_Checks --
15895 -------------------------------
15897 function Static_Elaboration_Checks
return Boolean is
15899 return not Dynamic_Elaboration_Checks
;
15900 end Static_Elaboration_Checks
;
15906 function Unit_Entity
(Unit_Id
: Entity_Id
) return Entity_Id
is
15907 function Is_Subunit
(Id
: Entity_Id
) return Boolean;
15908 pragma Inline
(Is_Subunit
);
15909 -- Determine whether the entity of an initial declaration denotes a
15916 function Is_Subunit
(Id
: Entity_Id
) return Boolean is
15917 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Id
);
15921 Nkind
(Decl
) in N_Generic_Package_Declaration
15922 | N_Generic_Subprogram_Declaration
15923 | N_Package_Declaration
15924 | N_Protected_Type_Declaration
15925 | N_Subprogram_Declaration
15926 | N_Task_Type_Declaration
15927 and then Present
(Corresponding_Body
(Decl
))
15928 and then Nkind
(Parent
(Unit_Declaration_Node
15929 (Corresponding_Body
(Decl
)))) = N_Subunit
;
15936 -- Start of processing for Unit_Entity
15939 Id
:= Unique_Entity
(Unit_Id
);
15941 -- Skip all subunits found in the scope chain which ends at the input
15944 while Is_Subunit
(Id
) loop
15951 ---------------------------------
15952 -- Update_Elaboration_Scenario --
15953 ---------------------------------
15955 procedure Update_Elaboration_Scenario
(New_N
: Node_Id
; Old_N
: Node_Id
) is
15957 -- Nothing to do when the elaboration phase of the compiler is not
15960 if not Elaboration_Phase_Active
then
15963 -- Nothing to do when the old and new scenarios are one and the same
15965 elsif Old_N
= New_N
then
15969 -- A scenario is being transformed by Atree.Rewrite. Update all relevant
15970 -- internal data structures to reflect this change. This ensures that a
15971 -- potential run-time conditional ABE check or a guaranteed ABE failure
15972 -- is inserted at the proper place in the tree.
15974 if Is_Scenario
(Old_N
) then
15975 Replace_Scenario
(Old_N
, New_N
);
15977 end Update_Elaboration_Scenario
;
15979 ---------------------------------------------------------------------------
15981 -- 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 --
15983 -- M E C H A N I S M --
15985 ---------------------------------------------------------------------------
15987 -- This section contains the implementation of the pre-18.x legacy ABE
15988 -- mechanism. The mechanism can be activated using switch -gnatH (legacy
15989 -- elaboration checking mode enabled).
15991 -----------------------------
15992 -- Description of Approach --
15993 -----------------------------
15995 -- Every non-static call that is encountered by Sem_Res results in a call
15996 -- to Check_Elab_Call, with N being the call node, and Outer set to its
15997 -- default value of True. In addition X'Access is treated like a call
15998 -- for the access-to-procedure case, and in SPARK mode only we also
15999 -- check variable references.
16001 -- The goal of Check_Elab_Call is to determine whether or not the reference
16002 -- in question can generate an access before elaboration error (raising
16003 -- Program_Error) either by directly calling a subprogram whose body
16004 -- has not yet been elaborated, or indirectly, by calling a subprogram
16005 -- whose body has been elaborated, but which contains a call to such a
16008 -- In addition, in SPARK mode, we are checking for a variable reference in
16009 -- another package, which requires an explicit Elaborate_All pragma.
16011 -- The only references that we need to look at the outer level are
16012 -- references that occur in elaboration code. There are two cases. The
16013 -- reference can be at the outer level of elaboration code, or it can
16014 -- be within another unit, e.g. the elaboration code of a subprogram.
16016 -- In the case of an elaboration call at the outer level, we must trace
16017 -- all calls to outer level routines either within the current unit or to
16018 -- other units that are with'ed. For calls within the current unit, we can
16019 -- determine if the body has been elaborated or not, and if it has not,
16020 -- then a warning is generated.
16022 -- Note that there are two subcases. If the original call directly calls a
16023 -- subprogram whose body has not been elaborated, then we know that an ABE
16024 -- will take place, and we replace the call by a raise of Program_Error.
16025 -- If the call is indirect, then we don't know that the PE will be raised,
16026 -- since the call might be guarded by a conditional. In this case we set
16027 -- Do_Elab_Check on the call so that a dynamic check is generated, and
16028 -- output a warning.
16030 -- For calls to a subprogram in a with'ed unit or a 'Access or variable
16031 -- reference (SPARK mode case), we require that a pragma Elaborate_All
16032 -- or pragma Elaborate be present, or that the referenced unit have a
16033 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
16034 -- of these conditions is met, then a warning is generated that a pragma
16035 -- Elaborate_All may be needed (error in the SPARK case), or an implicit
16036 -- pragma is generated.
16038 -- For the case of an elaboration call at some inner level, we are
16039 -- interested in tracing only calls to subprograms at the same level, i.e.
16040 -- those that can be called during elaboration. Any calls to outer level
16041 -- routines cannot cause ABE's as a result of the original call (there
16042 -- might be an outer level call to the subprogram from outside that causes
16043 -- the ABE, but that gets analyzed separately).
16045 -- Note that we never trace calls to inner level subprograms, since these
16046 -- cannot result in ABE's unless there is an elaboration problem at a lower
16047 -- level, which will be separately detected.
16049 -- Note on pragma Elaborate. The checking here assumes that a pragma
16050 -- Elaborate on a with'ed unit guarantees that subprograms within the unit
16051 -- can be called without causing an ABE. This is not in fact the case since
16052 -- pragma Elaborate does not guarantee the transitive coverage guaranteed
16053 -- by Elaborate_All. However, we decide to trust the user in this case.
16055 --------------------------------------
16056 -- Instantiation Elaboration Errors --
16057 --------------------------------------
16059 -- A special case arises when an instantiation appears in a context that is
16060 -- known to be before the body is elaborated, e.g.
16062 -- generic package x is ...
16064 -- package xx is new x;
16066 -- package body x is ...
16068 -- In this situation it is certain that an elaboration error will occur,
16069 -- and an unconditional raise Program_Error statement is inserted before
16070 -- the instantiation, and a warning generated.
16072 -- The problem is that in this case we have no place to put the body of
16073 -- the instantiation. We can't put it in the normal place, because it is
16074 -- too early, and will cause errors to occur as a result of referencing
16075 -- entities before they are declared.
16077 -- Our approach in this case is simply to avoid creating the body of the
16078 -- instantiation in such a case. The instantiation spec is modified to
16079 -- include dummy bodies for all subprograms, so that the resulting code
16080 -- does not contain subprogram specs with no corresponding bodies.
16082 -- The following table records the recursive call chain for output in the
16083 -- Output routine. Each entry records the call node and the entity of the
16084 -- called routine. The number of entries in the table (i.e. the value of
16085 -- Elab_Call.Last) indicates the current depth of recursion and is used to
16086 -- identify the outer level.
16088 type Elab_Call_Element
is record
16093 package Elab_Call
is new Table
.Table
16094 (Table_Component_Type
=> Elab_Call_Element
,
16095 Table_Index_Type
=> Int
,
16096 Table_Low_Bound
=> 1,
16097 Table_Initial
=> 50,
16098 Table_Increment
=> 100,
16099 Table_Name
=> "Elab_Call");
16101 -- The following table records all calls that have been processed starting
16102 -- from an outer level call. The table prevents both infinite recursion and
16103 -- useless reanalysis of calls within the same context. The use of context
16104 -- is important because it allows for proper checks in more complex code:
16107 -- Call; -- requires a check
16108 -- Call; -- does not need a check thanks to the table
16110 -- Call; -- requires a check, different context
16113 -- Call; -- requires a check, different context
16115 type Visited_Element
is record
16116 Subp_Id
: Entity_Id
;
16117 -- The entity of the subprogram being called
16120 -- The context where the call to the subprogram occurs
16123 package Elab_Visited
is new Table
.Table
16124 (Table_Component_Type
=> Visited_Element
,
16125 Table_Index_Type
=> Int
,
16126 Table_Low_Bound
=> 1,
16127 Table_Initial
=> 200,
16128 Table_Increment
=> 100,
16129 Table_Name
=> "Elab_Visited");
16131 -- The following table records delayed calls which must be examined after
16132 -- all generic bodies have been instantiated.
16134 type Delay_Element
is record
16136 -- The parameter N from the call to Check_Internal_Call. Note that this
16137 -- node may get rewritten over the delay period by expansion in the call
16138 -- case (but not in the instantiation case).
16141 -- The parameter E from the call to Check_Internal_Call
16143 Orig_Ent
: Entity_Id
;
16144 -- The parameter Orig_Ent from the call to Check_Internal_Call
16146 Curscop
: Entity_Id
;
16147 -- The current scope of the call. This is restored when we complete the
16148 -- delayed call, so that we do this in the right scope.
16150 Outer_Scope
: Entity_Id
;
16151 -- Save scope of outer level call
16153 From_Elab_Code
: Boolean;
16154 -- Save indication of whether this call is from elaboration code
16156 In_Task_Activation
: Boolean;
16157 -- Save indication of whether this call is from a task body. Tasks are
16158 -- activated at the "begin", which is after all local procedure bodies,
16159 -- so calls to those procedures can't fail, even if they occur after the
16162 From_SPARK_Code
: Boolean;
16163 -- Save indication of whether this call is under SPARK_Mode => On
16166 package Delay_Check
is new Table
.Table
16167 (Table_Component_Type
=> Delay_Element
,
16168 Table_Index_Type
=> Int
,
16169 Table_Low_Bound
=> 1,
16170 Table_Initial
=> 1000,
16171 Table_Increment
=> 100,
16172 Table_Name
=> "Delay_Check");
16174 C_Scope
: Entity_Id
;
16175 -- Top-level scope of current scope. Compute this only once at the outer
16176 -- level, i.e. for a call to Check_Elab_Call from outside this unit.
16178 Outer_Level_Sloc
: Source_Ptr
;
16179 -- Save Sloc value for outer level call node for comparisons of source
16180 -- locations. A body is too late if it appears after the *outer* level
16181 -- call, not the particular call that is being analyzed.
16183 From_Elab_Code
: Boolean;
16184 -- This flag shows whether the outer level call currently being examined
16185 -- is or is not in elaboration code. We are only interested in calls to
16186 -- routines in other units if this flag is True.
16188 In_Task_Activation
: Boolean := False;
16189 -- This flag indicates whether we are performing elaboration checks on task
16190 -- bodies, at the point of activation. If true, we do not raise
16191 -- Program_Error for calls to local procedures, because all local bodies
16192 -- are known to be elaborated. However, we still need to trace such calls,
16193 -- because a local procedure could call a procedure in another package,
16194 -- so we might need an implicit Elaborate_All.
16196 Delaying_Elab_Checks
: Boolean := True;
16197 -- This is set True till the compilation is complete, including the
16198 -- insertion of all instance bodies. Then when Check_Elab_Calls is called,
16199 -- the delay table is used to make the delayed calls and this flag is reset
16200 -- to False, so that the calls are processed.
16202 -----------------------
16203 -- Local Subprograms --
16204 -----------------------
16206 -- Note: Outer_Scope in all following specs represents the scope of
16207 -- interest of the outer level call. If it is set to Standard_Standard,
16208 -- then it means the outer level call was at elaboration level, and that
16209 -- thus all calls are of interest. If it was set to some other scope,
16210 -- then the original call was an inner call, and we are not interested
16211 -- in calls that go outside this scope.
16213 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
);
16214 -- Analysis of construct N shows that we should set Elaborate_All_Desirable
16215 -- for the WITH clause for unit U (which will always be present). A special
16216 -- case is when N is a function or procedure instantiation, in which case
16217 -- it is sufficient to set Elaborate_Desirable, since in this case there is
16218 -- no possibility of transitive elaboration issues.
16220 procedure Check_A_Call
16223 Outer_Scope
: Entity_Id
;
16224 Inter_Unit_Only
: Boolean;
16225 Generate_Warnings
: Boolean := True;
16226 In_Init_Proc
: Boolean := False);
16227 -- This is the internal recursive routine that is called to check for
16228 -- possible elaboration error. The argument N is a subprogram call or
16229 -- generic instantiation, or 'Access attribute reference to be checked, and
16230 -- E is the entity of the called subprogram, or instantiated generic unit,
16231 -- or subprogram referenced by 'Access.
16233 -- In SPARK mode, N can also be a variable reference, since in SPARK this
16234 -- also triggers a requirement for Elaborate_All, and in this case E is the
16235 -- entity being referenced.
16237 -- Outer_Scope is the outer level scope for the original reference.
16238 -- Inter_Unit_Only is set if the call is only to be checked in the
16239 -- case where it is to another unit (and skipped if within a unit).
16240 -- Generate_Warnings is set to False to suppress warning messages about
16241 -- missing pragma Elaborate_All's. These messages are not wanted for
16242 -- inner calls in the dynamic model. Note that an instance of the Access
16243 -- attribute applied to a subprogram also generates a call to this
16244 -- procedure (since the referenced subprogram may be called later
16245 -- indirectly). Flag In_Init_Proc should be set whenever the current
16246 -- context is a type init proc.
16248 -- Note: this might better be called Check_A_Reference to recognize the
16249 -- variable case for SPARK, but we prefer to retain the historical name
16250 -- since in practice this is mostly about checking calls for the possible
16251 -- occurrence of an access-before-elaboration exception.
16253 procedure Check_Bad_Instantiation
(N
: Node_Id
);
16254 -- N is a node for an instantiation (if called with any other node kind,
16255 -- Check_Bad_Instantiation ignores the call). This subprogram checks for
16256 -- the special case of a generic instantiation of a generic spec in the
16257 -- same declarative part as the instantiation where a body is present and
16258 -- has not yet been seen. This is an obvious error, but needs to be checked
16259 -- specially at the time of the instantiation, since it is a case where we
16260 -- cannot insert the body anywhere. If this case is detected, warnings are
16261 -- generated, and a raise of Program_Error is inserted. In addition any
16262 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation
16263 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this
16264 -- flag as an indication that no attempt should be made to insert an
16267 procedure Check_Internal_Call
16270 Outer_Scope
: Entity_Id
;
16271 Orig_Ent
: Entity_Id
);
16272 -- N is a function call or procedure statement call node and E is the
16273 -- entity of the called function, which is within the current compilation
16274 -- unit (where subunits count as part of the parent). This call checks if
16275 -- this call, or any call within any accessed body could cause an ABE, and
16276 -- if so, outputs a warning. Orig_Ent differs from E only in the case of
16277 -- renamings, and points to the original name of the entity. This is used
16278 -- for error messages. Outer_Scope is the outer level scope for the
16281 procedure Check_Internal_Call_Continue
16284 Outer_Scope
: Entity_Id
;
16285 Orig_Ent
: Entity_Id
);
16286 -- The processing for Check_Internal_Call is divided up into two phases,
16287 -- and this represents the second phase. The second phase is delayed if
16288 -- Delaying_Elab_Checks is set to True. In this delayed case, the first
16289 -- phase makes an entry in the Delay_Check table, which is processed when
16290 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
16291 -- Check_Internal_Call. Outer_Scope is the outer level scope for the
16294 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
;
16295 -- N is either a function or procedure call or an access attribute that
16296 -- references a subprogram. This call retrieves the relevant entity. If
16297 -- this is a call to a protected subprogram, the entity is a selected
16298 -- component. The callable entity may be absent, in which case Empty is
16299 -- returned. This happens with non-analyzed calls in nested generics.
16301 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable
16302 -- entity, in which case, the value returned is simply this entity.
16304 function Has_Generic_Body
(N
: Node_Id
) return Boolean;
16305 -- N is a generic package instantiation node, and this routine determines
16306 -- if this package spec does in fact have a generic body. If so, then
16307 -- True is returned, otherwise False. Note that this is not at all the
16308 -- same as checking if the unit requires a body, since it deals with
16309 -- the case of optional bodies accurately (i.e. if a body is optional,
16310 -- then it looks to see if a body is actually present). Note: this
16311 -- function can only do a fully correct job if in generating code mode
16312 -- where all bodies have to be present. If we are operating in semantics
16313 -- check only mode, then in some cases of optional bodies, a result of
16314 -- False may incorrectly be given. In practice this simply means that
16315 -- some cases of warnings for incorrect order of elaboration will only
16316 -- be given when generating code, which is not a big problem (and is
16317 -- inevitable, given the optional body semantics of Ada).
16319 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
);
16320 -- Given code for an elaboration check (or unconditional raise if the check
16321 -- is not needed), inserts the code in the appropriate place. N is the call
16322 -- or instantiation node for which the check code is required. C is the
16323 -- test whose failure triggers the raise.
16325 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean;
16326 -- Returns True if node N is a call to a generic formal subprogram
16328 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean;
16329 -- Determine whether entity Id denotes a [Deep_]Finalize procedure
16331 procedure Output_Calls
16333 Check_Elab_Flag
: Boolean);
16334 -- Outputs chain of calls stored in the Elab_Call table. The caller has
16335 -- already generated the main warning message, so the warnings generated
16336 -- are all continuation messages. The argument is the call node at which
16337 -- the messages are to be placed. When Check_Elab_Flag is set, calls are
16338 -- enumerated only when flag Elab_Warning is set for the dynamic case or
16339 -- when flag Elab_Info_Messages is set for the static case.
16341 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean;
16342 -- Given two scopes, determine whether they are the same scope from an
16343 -- elaboration point of view, i.e. packages and blocks are ignored.
16345 procedure Set_C_Scope
;
16346 -- On entry C_Scope is set to some scope. On return, C_Scope is reset
16347 -- to be the enclosing compilation unit of this scope.
16349 procedure Set_Elaboration_Constraint
16353 -- The current unit U may depend semantically on some unit P that is not
16354 -- in the current context. If there is an elaboration call that reaches P,
16355 -- we need to indicate that P requires an Elaborate_All, but this is not
16356 -- effective in U's ali file, if there is no with_clause for P. In this
16357 -- case we add the Elaborate_All on the unit Q that directly or indirectly
16358 -- makes P available. This can happen in two cases:
16360 -- a) Q declares a subtype of a type declared in P, and the call is an
16361 -- initialization call for an object of that subtype.
16363 -- b) Q declares an object of some tagged type whose root type is
16364 -- declared in P, and the initialization call uses object notation on
16365 -- that object to reach a primitive operation or a classwide operation
16368 -- If P appears in the context of U, the current processing is correct.
16369 -- Otherwise we must identify these two cases to retrieve Q and place the
16370 -- Elaborate_All_Desirable on it.
16372 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
;
16373 -- Given a compilation unit entity, if it is a spec entity, it is returned
16374 -- unchanged. If it is a body entity, then the spec for the corresponding
16375 -- spec is returned
16377 function Within
(E1
, E2
: Entity_Id
) return Boolean;
16378 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
16379 -- of its contained scopes, False otherwise.
16381 function Within_Elaborate_All
16382 (Unit
: Unit_Number_Type
;
16383 E
: Entity_Id
) return Boolean;
16384 -- Return True if we are within the scope of an Elaborate_All for E, or if
16385 -- we are within the scope of an Elaborate_All for some other unit U, and U
16386 -- with's E. This prevents spurious warnings when the called entity is
16387 -- renamed within U, or in case of generic instances.
16389 --------------------------------------
16390 -- Activate_Elaborate_All_Desirable --
16391 --------------------------------------
16393 procedure Activate_Elaborate_All_Desirable
(N
: Node_Id
; U
: Entity_Id
) is
16394 UN
: constant Unit_Number_Type
:= Get_Code_Unit
(N
);
16395 CU
: constant Node_Id
:= Cunit
(UN
);
16396 UE
: constant Entity_Id
:= Cunit_Entity
(UN
);
16397 Unm
: constant Unit_Name_Type
:= Unit_Name
(UN
);
16398 CI
: constant List_Id
:= Context_Items
(CU
);
16402 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
);
16403 -- This procedure is called when the elaborate indication must be
16404 -- applied to a unit not in the context of the referencing unit. The
16405 -- unit gets added to the context as an implicit with.
16407 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean;
16408 -- UEs is the spec entity of a unit. If the unit to be marked is
16409 -- in the context item list of this unit spec, then the call returns
16410 -- True and Itm is left set to point to the relevant N_With_Clause node.
16412 procedure Set_Elab_Flag
(Itm
: Node_Id
);
16413 -- Sets Elaborate_[All_]Desirable as appropriate on Itm
16415 -----------------------------
16416 -- Add_To_Context_And_Mark --
16417 -----------------------------
16419 procedure Add_To_Context_And_Mark
(Itm
: Node_Id
) is
16420 CW
: constant Node_Id
:=
16421 Make_With_Clause
(Sloc
(Itm
),
16422 Name
=> Name
(Itm
));
16425 Set_Library_Unit
(CW
, Library_Unit
(Itm
));
16426 Set_Implicit_With
(CW
);
16428 -- Set elaborate all desirable on copy and then append the copy to
16429 -- the list of body with's and we are done.
16431 Set_Elab_Flag
(CW
);
16432 Append_To
(CI
, CW
);
16433 end Add_To_Context_And_Mark
;
16439 function In_Withs_Of
(UEs
: Entity_Id
) return Boolean is
16440 UNs
: constant Unit_Number_Type
:= Get_Source_Unit
(UEs
);
16441 CUs
: constant Node_Id
:= Cunit
(UNs
);
16442 CIs
: constant List_Id
:= Context_Items
(CUs
);
16445 Itm
:= First
(CIs
);
16446 while Present
(Itm
) loop
16447 if Nkind
(Itm
) = N_With_Clause
then
16449 Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
16462 -------------------
16463 -- Set_Elab_Flag --
16464 -------------------
16466 procedure Set_Elab_Flag
(Itm
: Node_Id
) is
16468 if Nkind
(N
) in N_Subprogram_Instantiation
then
16469 Set_Elaborate_Desirable
(Itm
);
16471 Set_Elaborate_All_Desirable
(Itm
);
16475 -- Start of processing for Activate_Elaborate_All_Desirable
16478 -- Do not set binder indication if expansion is disabled, as when
16479 -- compiling a generic unit.
16481 if not Expander_Active
then
16485 -- If an instance of a generic package contains a controlled object (so
16486 -- we're calling Initialize at elaboration time), and the instance is in
16487 -- a package body P that says "with P;", then we need to return without
16488 -- adding "pragma Elaborate_All (P);" to P.
16490 if U
= Main_Unit_Entity
then
16495 while Present
(Itm
) loop
16496 if Nkind
(Itm
) = N_With_Clause
then
16497 Ent
:= Cunit_Entity
(Get_Cunit_Unit_Number
(Library_Unit
(Itm
)));
16499 -- If we find it, then mark elaborate all desirable and return
16502 Set_Elab_Flag
(Itm
);
16510 -- If we fall through then the with clause is not present in the
16511 -- current unit. One legitimate possibility is that the with clause
16512 -- is present in the spec when we are a body.
16514 if Is_Body_Name
(Unm
)
16515 and then In_Withs_Of
(Spec_Entity
(UE
))
16517 Add_To_Context_And_Mark
(Itm
);
16521 -- Similarly, we may be in the spec or body of a child unit, where
16522 -- the unit in question is with'ed by some ancestor of the child unit.
16524 if Is_Child_Name
(Unm
) then
16531 Pkg
:= Scope
(Pkg
);
16532 exit when Pkg
= Standard_Standard
;
16534 if In_Withs_Of
(Pkg
) then
16535 Add_To_Context_And_Mark
(Itm
);
16542 -- Here if we do not find with clause on spec or body. We just ignore
16543 -- this case; it means that the elaboration involves some other unit
16544 -- than the unit being compiled, and will be caught elsewhere.
16545 end Activate_Elaborate_All_Desirable
;
16551 procedure Check_A_Call
16554 Outer_Scope
: Entity_Id
;
16555 Inter_Unit_Only
: Boolean;
16556 Generate_Warnings
: Boolean := True;
16557 In_Init_Proc
: Boolean := False)
16559 Access_Case
: constant Boolean := Nkind
(N
) = N_Attribute_Reference
;
16560 -- Indicates if we have Access attribute case
16562 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean;
16563 -- True if we're calling an instance of a generic subprogram, or a
16564 -- subprogram in an instance of a generic package, and the call is
16565 -- outside that instance.
16567 procedure Elab_Warning
16570 Ent
: Node_Or_Entity_Id
);
16571 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
16572 -- dynamic or static elaboration model), N and Ent. Msg_D is a real
16573 -- warning (output if Msg_D is non-null and Elab_Warnings is set),
16574 -- Msg_S is an info message (output if Elab_Info_Messages is set).
16576 function Find_W_Scope
return Entity_Id
;
16577 -- Find top-level scope for called entity (not following renamings
16578 -- or derivations). This is where the Elaborate_All will go if it is
16579 -- needed. We start with the called entity, except in the case of an
16580 -- initialization procedure outside the current package, where the init
16581 -- proc is in the root package, and we start from the entity of the name
16584 -----------------------------------
16585 -- Call_To_Instance_From_Outside --
16586 -----------------------------------
16588 function Call_To_Instance_From_Outside
(Id
: Entity_Id
) return Boolean is
16589 Scop
: Entity_Id
:= Id
;
16593 if Scop
= Standard_Standard
then
16597 if Is_Generic_Instance
(Scop
) then
16598 return not In_Open_Scopes
(Scop
);
16601 Scop
:= Scope
(Scop
);
16603 end Call_To_Instance_From_Outside
;
16609 procedure Elab_Warning
16612 Ent
: Node_Or_Entity_Id
)
16615 -- Dynamic elaboration checks, real warning
16617 if Dynamic_Elaboration_Checks
then
16618 if not Access_Case
then
16619 if Msg_D
/= "" and then Elab_Warnings
then
16620 Error_Msg_NE
(Msg_D
, N
, Ent
);
16623 -- In the access case emit first warning message as well,
16624 -- otherwise list of calls will appear as errors.
16626 elsif Elab_Warnings
then
16627 Error_Msg_NE
(Msg_S
, N
, Ent
);
16630 -- Static elaboration checks, info message
16633 if Elab_Info_Messages
then
16634 Error_Msg_NE
(Msg_S
, N
, Ent
);
16643 function Find_W_Scope
return Entity_Id
is
16644 Refed_Ent
: constant Entity_Id
:= Get_Referenced_Ent
(N
);
16645 W_Scope
: Entity_Id
;
16648 if Is_Init_Proc
(Refed_Ent
)
16649 and then not In_Same_Extended_Unit
(N
, Refed_Ent
)
16651 W_Scope
:= Scope
(Refed_Ent
);
16656 -- Now loop through scopes to get to the enclosing compilation unit
16658 while not Is_Compilation_Unit
(W_Scope
) loop
16659 W_Scope
:= Scope
(W_Scope
);
16667 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
16668 -- Indicates if we have instantiation case
16670 Loc
: constant Source_Ptr
:= Sloc
(N
);
16672 Variable_Case
: constant Boolean :=
16673 Nkind
(N
) in N_Has_Entity
16674 and then Present
(Entity
(N
))
16675 and then Ekind
(Entity
(N
)) = E_Variable
;
16676 -- Indicates if we have variable reference case
16678 W_Scope
: constant Entity_Id
:= Find_W_Scope
;
16679 -- Top-level scope of directly called entity for subprogram. This
16680 -- differs from E_Scope in the case where renamings or derivations
16681 -- are involved, since it does not follow these links. W_Scope is
16682 -- generally in a visible unit, and it is this scope that may require
16683 -- an Elaborate_All. However, there are some cases (initialization
16684 -- calls and calls involving object notation) where W_Scope might not
16685 -- be in the context of the current unit, and there is an intermediate
16686 -- package that is, in which case the Elaborate_All has to be placed
16687 -- on this intermediate package. These special cases are handled in
16688 -- Set_Elaboration_Constraint.
16691 Callee_Unit_Internal
: Boolean;
16692 Caller_Unit_Internal
: Boolean;
16694 Inst_Callee
: Source_Ptr
;
16695 Inst_Caller
: Source_Ptr
;
16696 Unit_Callee
: Unit_Number_Type
;
16697 Unit_Caller
: Unit_Number_Type
;
16699 Body_Acts_As_Spec
: Boolean;
16700 -- Set to true if call is to body acting as spec (no separate spec)
16702 Cunit_SC
: Boolean := False;
16703 -- Set to suppress dynamic elaboration checks where one of the
16704 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
16705 -- if a pragma Elaborate[_All] applies to that scope, in which case
16706 -- warnings on the scope are also suppressed. For the internal case,
16707 -- we ignore this flag.
16709 E_Scope
: Entity_Id
;
16710 -- Top-level scope of entity for called subprogram. This value includes
16711 -- following renamings and derivations, so this scope can be in a
16712 -- non-visible unit. This is the scope that is to be investigated to
16713 -- see whether an elaboration check is required.
16716 -- Flag set when the subprogram being invoked is the procedure generated
16717 -- for pragma Default_Initial_Condition.
16719 SPARK_Elab_Errors
: Boolean;
16720 -- Flag set when an entity is called or a variable is read during SPARK
16721 -- dynamic elaboration.
16723 -- Start of processing for Check_A_Call
16726 -- If the call is known to be within a local Suppress Elaboration
16727 -- pragma, nothing to check. This can happen in task bodies. But
16728 -- we ignore this for a call to a generic formal.
16730 if Nkind
(N
) in N_Subprogram_Call
16731 and then No_Elaboration_Check
(N
)
16732 and then not Is_Call_Of_Generic_Formal
(N
)
16736 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to
16737 -- check, we don't mind in this case if the call occurs before the body
16738 -- since this is all generated code.
16740 elsif Nkind
(Original_Node
(N
)) = N_Attribute_Reference
16741 and then Attribute_Name
(Original_Node
(N
)) = Name_Valid_Scalars
16745 -- Intrinsics such as instances of Unchecked_Deallocation do not have
16746 -- any body, so elaboration checking is not needed, and would be wrong.
16748 elsif Is_Intrinsic_Subprogram
(E
) then
16751 -- Do not consider references to internal variables for SPARK semantics
16753 elsif Variable_Case
and then not Comes_From_Source
(E
) then
16757 -- Proceed with check
16761 -- For a variable reference, just set Body_Acts_As_Spec to False
16763 if Variable_Case
then
16764 Body_Acts_As_Spec
:= False;
16766 -- Additional checks for all other cases
16769 -- Go to parent for derived subprogram, or to original subprogram in
16770 -- the case of a renaming (Alias covers both these cases).
16773 if (Suppress_Elaboration_Warnings
(Ent
)
16774 or else Elaboration_Checks_Suppressed
(Ent
))
16775 and then (Inst_Case
or else No
(Alias
(Ent
)))
16780 -- Nothing to do for imported entities
16782 if Is_Imported
(Ent
) then
16786 exit when Inst_Case
or else No
(Alias
(Ent
));
16787 Ent
:= Alias
(Ent
);
16790 Decl
:= Unit_Declaration_Node
(Ent
);
16792 if Nkind
(Decl
) = N_Subprogram_Body
then
16793 Body_Acts_As_Spec
:= True;
16795 elsif Nkind
(Decl
) in
16796 N_Subprogram_Declaration | N_Subprogram_Body_Stub
16799 Body_Acts_As_Spec
:= False;
16801 -- If we have none of an instantiation, subprogram body or subprogram
16802 -- declaration, or in the SPARK case, a variable reference, then
16803 -- it is not a case that we want to check. (One case is a call to a
16804 -- generic formal subprogram, where we do not want the check in the
16814 if Elaboration_Checks_Suppressed
(E_Scope
)
16815 or else Suppress_Elaboration_Warnings
(E_Scope
)
16820 -- Exit when we get to compilation unit, not counting subunits
16822 exit when Is_Compilation_Unit
(E_Scope
)
16823 and then (Is_Child_Unit
(E_Scope
)
16824 or else Scope
(E_Scope
) = Standard_Standard
);
16826 pragma Assert
(E_Scope
/= Standard_Standard
);
16828 -- Move up a scope looking for compilation unit
16830 E_Scope
:= Scope
(E_Scope
);
16833 -- No checks needed for pure or preelaborated compilation units
16835 if Is_Pure
(E_Scope
) or else Is_Preelaborated
(E_Scope
) then
16839 -- If the generic entity is within a deeper instance than we are, then
16840 -- either the instantiation to which we refer itself caused an ABE, in
16841 -- which case that will be handled separately, or else we know that the
16842 -- body we need appears as needed at the point of the instantiation.
16843 -- However, this assumption is only valid if we are in static mode.
16845 if not Dynamic_Elaboration_Checks
16847 Instantiation_Depth
(Sloc
(Ent
)) > Instantiation_Depth
(Sloc
(N
))
16852 -- Do not give a warning for a package with no body
16854 if Ekind
(Ent
) = E_Generic_Package
and then not Has_Generic_Body
(N
) then
16858 -- Case of entity is in same unit as call or instantiation. In the
16859 -- instantiation case, W_Scope may be different from E_Scope; we want
16860 -- the unit in which the instantiation occurs, since we're analyzing
16861 -- based on the expansion.
16863 if W_Scope
= C_Scope
then
16864 if not Inter_Unit_Only
then
16865 Check_Internal_Call
(N
, Ent
, Outer_Scope
, E
);
16871 -- Case of entity is not in current unit (i.e. with'ed unit case)
16873 -- We are only interested in such calls if the outer call was from
16874 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
16876 if not From_Elab_Code
and then not Dynamic_Elaboration_Checks
then
16880 -- Nothing to do if some scope said that no checks were required
16886 -- Nothing to do for a generic instance, because a call to an instance
16887 -- cannot fail the elaboration check, because the body of the instance
16888 -- is always elaborated immediately after the spec.
16890 if Call_To_Instance_From_Outside
(Ent
) then
16894 -- Nothing to do if subprogram with no separate spec. However, a call
16895 -- to Deep_Initialize may result in a call to a user-defined Initialize
16896 -- procedure, which imposes a body dependency. This happens only if the
16897 -- type is controlled and the Initialize procedure is not inherited.
16899 if Body_Acts_As_Spec
then
16900 if Is_TSS
(Ent
, TSS_Deep_Initialize
) then
16902 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Ent
));
16906 if not Is_Controlled
(Typ
) then
16909 Init
:= Find_Controlled_Prim_Op
(Typ
, Name_Initialize
);
16911 if Comes_From_Source
(Init
) then
16924 -- Check cases of internal units
16926 Callee_Unit_Internal
:= In_Internal_Unit
(E_Scope
);
16928 -- Do not give a warning if the with'ed unit is internal and this is
16929 -- the generic instantiation case (this saves a lot of hassle dealing
16930 -- with the Text_IO special child units)
16932 if Callee_Unit_Internal
and Inst_Case
then
16936 if C_Scope
= Standard_Standard
then
16937 Caller_Unit_Internal
:= False;
16939 Caller_Unit_Internal
:= In_Internal_Unit
(C_Scope
);
16942 -- Do not give a warning if the with'ed unit is internal and the caller
16943 -- is not internal (since the binder always elaborates internal units
16946 if Callee_Unit_Internal
and not Caller_Unit_Internal
then
16950 -- For now, if debug flag -gnatdE is not set, do no checking for one
16951 -- internal unit withing another. This fixes the problem with the sgi
16952 -- build and storage errors. To be resolved later ???
16954 if (Callee_Unit_Internal
and Caller_Unit_Internal
)
16955 and not Debug_Flag_EE
16960 if Is_TSS
(E
, TSS_Deep_Initialize
) then
16964 -- If the call is in an instance, and the called entity is not
16965 -- defined in the same instance, then the elaboration issue focuses
16966 -- around the unit containing the template, it is this unit that
16967 -- requires an Elaborate_All.
16969 -- However, if we are doing dynamic elaboration, we need to chase the
16970 -- call in the usual manner.
16972 -- We also need to chase the call in the usual manner if it is a call
16973 -- to a generic formal parameter, since that case was not handled as
16974 -- part of the processing of the template.
16976 Inst_Caller
:= Instantiation
(Get_Source_File_Index
(Sloc
(N
)));
16977 Inst_Callee
:= Instantiation
(Get_Source_File_Index
(Sloc
(Ent
)));
16979 if Inst_Caller
= No_Location
then
16980 Unit_Caller
:= No_Unit
;
16982 Unit_Caller
:= Get_Source_Unit
(N
);
16985 if Inst_Callee
= No_Location
then
16986 Unit_Callee
:= No_Unit
;
16988 Unit_Callee
:= Get_Source_Unit
(Ent
);
16991 if Unit_Caller
/= No_Unit
16992 and then Unit_Callee
/= Unit_Caller
16993 and then not Dynamic_Elaboration_Checks
16994 and then not Is_Call_Of_Generic_Formal
(N
)
16996 E_Scope
:= Spec_Entity
(Cunit_Entity
(Unit_Caller
));
16998 -- If we don't get a spec entity, just ignore call. Not quite
16999 -- clear why this check is necessary. ???
17001 if No
(E_Scope
) then
17005 -- Otherwise step to enclosing compilation unit
17007 while not Is_Compilation_Unit
(E_Scope
) loop
17008 E_Scope
:= Scope
(E_Scope
);
17011 -- For the case where N is not an instance, and is not a call within
17012 -- instance to other than a generic formal, we recompute E_Scope
17013 -- for the error message, since we do NOT want to go to the unit
17014 -- that has the ultimate declaration in the case of renaming and
17015 -- derivation and we also want to go to the generic unit in the
17016 -- case of an instance, and no further.
17019 -- Loop to carefully follow renamings and derivations one step
17020 -- outside the current unit, but not further.
17022 if not (Inst_Case
or Variable_Case
)
17023 and then Present
(Alias
(Ent
))
17025 E_Scope
:= Alias
(Ent
);
17031 while not Is_Compilation_Unit
(E_Scope
) loop
17032 E_Scope
:= Scope
(E_Scope
);
17035 -- If E_Scope is the same as C_Scope, it means that there
17036 -- definitely was a local renaming or derivation, and we
17037 -- are not yet out of the current unit.
17039 exit when E_Scope
/= C_Scope
;
17040 Ent
:= Alias
(Ent
);
17043 -- If no alias, there could be a previous error, but not if we've
17044 -- already reached the outermost level (Standard).
17052 if Within_Elaborate_All
(Current_Sem_Unit
, E_Scope
) then
17056 -- Determine whether the Default_Initial_Condition procedure of some
17057 -- type is being invoked.
17059 Is_DIC
:= Ekind
(Ent
) = E_Procedure
and then Is_DIC_Procedure
(Ent
);
17061 -- Checks related to Default_Initial_Condition fall under the SPARK
17062 -- umbrella because this is a SPARK-specific annotation.
17064 SPARK_Elab_Errors
:=
17065 SPARK_Mode
= On
and (Is_DIC
or Dynamic_Elaboration_Checks
);
17067 -- Now check if an Elaborate_All (or dynamic check) is needed
17069 if (Elab_Info_Messages
or Elab_Warnings
or SPARK_Elab_Errors
)
17070 and then Generate_Warnings
17071 and then not Suppress_Elaboration_Warnings
(Ent
)
17072 and then not Elaboration_Checks_Suppressed
(Ent
)
17073 and then not Suppress_Elaboration_Warnings
(E_Scope
)
17074 and then not Elaboration_Checks_Suppressed
(E_Scope
)
17076 -- Instantiation case
17079 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
17081 ("instantiation of & during elaboration in SPARK", N
, Ent
);
17084 ("instantiation of & may raise Program_Error?l?",
17085 "info: instantiation of & during elaboration?$?", Ent
);
17088 -- Indirect call case, info message only in static elaboration
17089 -- case, because the attribute reference itself cannot raise an
17090 -- exception. Note that SPARK does not permit indirect calls.
17092 elsif Access_Case
then
17093 Elab_Warning
("", "info: access to & during elaboration?$?", Ent
);
17095 -- Variable reference in SPARK mode
17097 elsif Variable_Case
then
17098 if Comes_From_Source
(Ent
) and then SPARK_Elab_Errors
then
17100 ("reference to & during elaboration in SPARK", N
, Ent
);
17103 -- Subprogram call case
17106 if Nkind
(Name
(N
)) in N_Has_Entity
17107 and then Is_Init_Proc
(Entity
(Name
(N
)))
17108 and then Comes_From_Source
(Ent
)
17111 ("implicit call to & may raise Program_Error?l?",
17112 "info: implicit call to & during elaboration?$?",
17115 elsif SPARK_Elab_Errors
then
17117 -- Emit a specialized error message when the elaboration of an
17118 -- object of a private type evaluates the expression of pragma
17119 -- Default_Initial_Condition. This prevents the internal name
17120 -- of the procedure from appearing in the error message.
17124 ("call to Default_Initial_Condition during elaboration in "
17128 ("call to & during elaboration in SPARK", N
, Ent
);
17133 ("call to & may raise Program_Error?l?",
17134 "info: call to & during elaboration?$?",
17139 Error_Msg_Qual_Level
:= Nat
'Last;
17141 -- Case of Elaborate_All not present and required, for SPARK this
17142 -- is an error, so give an error message.
17144 if SPARK_Elab_Errors
then
17145 Error_Msg_NE
-- CODEFIX
17146 ("\Elaborate_All pragma required for&", N
, W_Scope
);
17148 -- Otherwise we generate an implicit pragma. For a subprogram
17149 -- instantiation, Elaborate is good enough, since no transitive
17150 -- call is possible at elaboration time in this case.
17152 elsif Nkind
(N
) in N_Subprogram_Instantiation
then
17154 ("\missing pragma Elaborate for&?l?",
17155 "\implicit pragma Elaborate for& generated?$?",
17158 -- For all other cases, we need an implicit Elaborate_All
17162 ("\missing pragma Elaborate_All for&?l?",
17163 "\implicit pragma Elaborate_All for & generated?$?",
17167 Error_Msg_Qual_Level
:= 0;
17169 -- Take into account the flags related to elaboration warning
17170 -- messages when enumerating the various calls involved. This
17171 -- ensures the proper pairing of the main warning and the
17172 -- clarification messages generated by Output_Calls.
17174 Output_Calls
(N
, Check_Elab_Flag
=> True);
17176 -- Set flag to prevent further warnings for same unit unless in
17177 -- All_Errors_Mode.
17179 if not All_Errors_Mode
and not Dynamic_Elaboration_Checks
then
17180 Set_Suppress_Elaboration_Warnings
(W_Scope
);
17184 -- Check for runtime elaboration check required
17186 if Dynamic_Elaboration_Checks
then
17187 if not Elaboration_Checks_Suppressed
(Ent
)
17188 and then not Elaboration_Checks_Suppressed
(W_Scope
)
17189 and then not Elaboration_Checks_Suppressed
(E_Scope
)
17190 and then not Cunit_SC
17192 -- Runtime elaboration check required. Generate check of the
17193 -- elaboration Boolean for the unit containing the entity.
17195 -- Note that for this case, we do check the real unit (the one
17196 -- from following renamings, since that is the issue).
17198 -- Could this possibly miss a useless but required PE???
17200 Insert_Elab_Check
(N
,
17201 Make_Attribute_Reference
(Loc
,
17202 Attribute_Name
=> Name_Elaborated
,
17204 New_Occurrence_Of
(Spec_Entity
(E_Scope
), Loc
)));
17206 -- Prevent duplicate elaboration checks on the same call, which
17207 -- can happen if the body enclosing the call appears itself in a
17208 -- call whose elaboration check is delayed.
17210 if Nkind
(N
) in N_Subprogram_Call
then
17211 Set_No_Elaboration_Check
(N
);
17215 -- Case of static elaboration model
17218 -- Do not do anything if elaboration checks suppressed. Note that
17219 -- we check Ent here, not E, since we want the real entity for the
17220 -- body to see if checks are suppressed for it, not the dummy
17221 -- entry for renamings or derivations.
17223 if Elaboration_Checks_Suppressed
(Ent
)
17224 or else Elaboration_Checks_Suppressed
(E_Scope
)
17225 or else Elaboration_Checks_Suppressed
(W_Scope
)
17229 -- Do not generate an Elaborate_All for finalization routines
17230 -- that perform partial clean up as part of initialization.
17232 elsif In_Init_Proc
and then Is_Finalization_Procedure
(Ent
) then
17235 -- Here we need to generate an implicit elaborate all
17238 -- Generate Elaborate_All warning unless suppressed
17240 if (Elab_Info_Messages
and Generate_Warnings
and not Inst_Case
)
17241 and then not Suppress_Elaboration_Warnings
(Ent
)
17242 and then not Suppress_Elaboration_Warnings
(E_Scope
)
17243 and then not Suppress_Elaboration_Warnings
(W_Scope
)
17245 Error_Msg_Node_2
:= W_Scope
;
17247 ("info: call to& in elaboration code requires pragma "
17248 & "Elaborate_All on&?$?", N
, E
);
17251 -- Set indication for binder to generate Elaborate_All
17253 Set_Elaboration_Constraint
(N
, E
, W_Scope
);
17258 -----------------------------
17259 -- Check_Bad_Instantiation --
17260 -----------------------------
17262 procedure Check_Bad_Instantiation
(N
: Node_Id
) is
17266 -- Nothing to do if we do not have an instantiation (happens in some
17267 -- error cases, and also in the formal package declaration case)
17269 if Nkind
(N
) not in N_Generic_Instantiation
then
17272 -- Nothing to do if serious errors detected (avoid cascaded errors)
17274 elsif Serious_Errors_Detected
/= 0 then
17277 -- Nothing to do if not in full analysis mode
17279 elsif not Full_Analysis
then
17282 -- Nothing to do if inside a generic template
17284 elsif Inside_A_Generic
then
17287 -- Nothing to do if a library level instantiation
17289 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
then
17292 -- Nothing to do if we are compiling a proper body for semantic
17293 -- purposes only. The generic body may be in another proper body.
17296 Nkind
(Parent
(Unit_Declaration_Node
(Main_Unit_Entity
))) = N_Subunit
17301 Ent
:= Get_Generic_Entity
(N
);
17303 -- The case we are interested in is when the generic spec is in the
17304 -- current declarative part
17306 if not Same_Elaboration_Scope
(Current_Scope
, Scope
(Ent
))
17307 or else not In_Same_Extended_Unit
(N
, Ent
)
17312 -- If the generic entity is within a deeper instance than we are, then
17313 -- either the instantiation to which we refer itself caused an ABE, in
17314 -- which case that will be handled separately. Otherwise, we know that
17315 -- the body we need appears as needed at the point of the instantiation.
17316 -- If they are both at the same level but not within the same instance
17317 -- then the body of the generic will be in the earlier instance.
17320 D1
: constant Nat
:= Instantiation_Depth
(Sloc
(Ent
));
17321 D2
: constant Nat
:= Instantiation_Depth
(Sloc
(N
));
17328 and then Is_Generic_Instance
(Scope
(Ent
))
17329 and then not In_Open_Scopes
(Scope
(Ent
))
17335 -- Now we can proceed, if the entity being called has a completion,
17336 -- then we are definitely OK, since we have already seen the body.
17338 if Has_Completion
(Ent
) then
17342 -- If there is no body, then nothing to do
17344 if not Has_Generic_Body
(N
) then
17348 -- Here we definitely have a bad instantiation
17350 Error_Msg_Warn
:= SPARK_Mode
/= On
;
17351 Error_Msg_NE
("cannot instantiate& before body seen<<", N
, Ent
);
17352 Error_Msg_N
("\Program_Error [<<", N
);
17354 Insert_Elab_Check
(N
);
17355 Set_Is_Known_Guaranteed_ABE
(N
);
17356 end Check_Bad_Instantiation
;
17358 ---------------------
17359 -- Check_Elab_Call --
17360 ---------------------
17362 procedure Check_Elab_Call
17364 Outer_Scope
: Entity_Id
:= Empty
;
17365 In_Init_Proc
: Boolean := False)
17371 pragma Assert
(Legacy_Elaboration_Checks
);
17373 -- If the reference is not in the main unit, there is nothing to check.
17374 -- Elaboration call from units in the context of the main unit will lead
17375 -- to semantic dependencies when those units are compiled.
17377 if not In_Extended_Main_Code_Unit
(N
) then
17381 -- For an entry call, check relevant restriction
17383 if Nkind
(N
) = N_Entry_Call_Statement
17384 and then not In_Subprogram_Or_Concurrent_Unit
17386 Check_Restriction
(No_Entry_Calls_In_Elaboration_Code
, N
);
17388 -- Nothing to do if this is not an expected type of reference (happens
17389 -- in some error conditions, and in some cases where rewriting occurs).
17391 elsif Nkind
(N
) not in N_Subprogram_Call
17392 and then Nkind
(N
) /= N_Attribute_Reference
17393 and then (SPARK_Mode
/= On
17394 or else Nkind
(N
) not in N_Has_Entity
17395 or else No
(Entity
(N
))
17396 or else Ekind
(Entity
(N
)) /= E_Variable
)
17400 -- Nothing to do if this is a call already rewritten for elab checking.
17401 -- Such calls appear as the targets of If_Expressions.
17403 -- This check MUST be wrong, it catches far too much
17405 elsif Nkind
(Parent
(N
)) = N_If_Expression
then
17408 -- Nothing to do if inside a generic template
17410 elsif Inside_A_Generic
17411 and then No
(Enclosing_Generic_Body
(N
))
17415 -- Nothing to do if call is being preanalyzed, as when within a
17416 -- pre/postcondition, a predicate, or an invariant.
17418 elsif In_Spec_Expression
then
17422 -- Nothing to do if this is a call to a postcondition, which is always
17423 -- within a subprogram body, even though the current scope may be the
17424 -- enclosing scope of the subprogram.
17426 if Nkind
(N
) = N_Procedure_Call_Statement
17427 and then Is_Entity_Name
(Name
(N
))
17428 and then Chars
(Entity
(Name
(N
))) = Name_uWrapped_Statements
17433 -- Here we have a reference at elaboration time that must be checked
17435 if Debug_Flag_Underscore_LL
then
17436 Write_Str
(" Check_Elab_Ref: ");
17438 if Nkind
(N
) = N_Attribute_Reference
then
17439 if not Is_Entity_Name
(Prefix
(N
)) then
17440 Write_Str
("<<not entity name>>");
17442 Write_Name
(Chars
(Entity
(Prefix
(N
))));
17445 Write_Str
("'Access");
17447 elsif No
(Name
(N
)) or else not Is_Entity_Name
(Name
(N
)) then
17448 Write_Str
("<<not entity name>> ");
17451 Write_Name
(Chars
(Entity
(Name
(N
))));
17454 Write_Str
(" reference at ");
17455 Write_Location
(Sloc
(N
));
17459 -- Climb up the tree to make sure we are not inside default expression
17460 -- of a parameter specification or a record component, since in both
17461 -- these cases, we will be doing the actual reference later, not now,
17462 -- and it is at the time of the actual reference (statically speaking)
17463 -- that we must do our static check, not at the time of its initial
17466 -- However, we have to check references within component definitions
17467 -- (e.g. a function call that determines an array component bound),
17468 -- so we terminate the loop in that case.
17471 while Present
(P
) loop
17472 if Nkind
(P
) in N_Parameter_Specification | N_Component_Declaration
17476 -- The reference occurs within the constraint of a component,
17477 -- so it must be checked.
17479 elsif Nkind
(P
) = N_Component_Definition
then
17487 -- Stuff that happens only at the outer level
17489 if No
(Outer_Scope
) then
17490 Elab_Visited
.Set_Last
(0);
17492 -- Nothing to do if current scope is Standard (this is a bit odd, but
17493 -- it happens in the case of generic instantiations).
17495 C_Scope
:= Current_Scope
;
17497 if C_Scope
= Standard_Standard
then
17501 -- First case, we are in elaboration code
17503 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
17505 if From_Elab_Code
then
17507 -- Complain if ref that comes from source in preelaborated unit
17508 -- and we are not inside a subprogram (i.e. we are in elab code).
17510 -- Ada 2022 (AI12-0175): Calls to certain functions that are
17511 -- essentially unchecked conversions are preelaborable.
17513 if Comes_From_Source
(N
)
17514 and then In_Preelaborated_Unit
17515 and then not In_Inlined_Body
17516 and then Nkind
(N
) /= N_Attribute_Reference
17517 and then not (Ada_Version
>= Ada_2022
17518 and then Is_Preelaborable_Construct
(N
))
17520 Error_Preelaborated_Call
(N
);
17524 -- Second case, we are inside a subprogram or concurrent unit, which
17525 -- means we are not in elaboration code.
17528 -- In this case, the issue is whether we are inside the
17529 -- declarative part of the unit in which we live, or inside its
17530 -- statements. In the latter case, there is no issue of ABE calls
17531 -- at this level (a call from outside to the unit in which we live
17532 -- might cause an ABE, but that will be detected when we analyze
17533 -- that outer level call, as it recurses into the called unit).
17535 -- Climb up the tree, doing this test, and also testing for being
17536 -- inside a default expression, which, as discussed above, is not
17537 -- checked at this stage.
17546 -- If we find a parentless subtree, it seems safe to assume
17547 -- that we are not in a declarative part and that no
17548 -- checking is required.
17554 if Is_List_Member
(P
) then
17555 L
:= List_Containing
(P
);
17562 exit when Nkind
(P
) = N_Subunit
;
17564 -- Filter out case of default expressions, where we do not
17565 -- do the check at this stage.
17568 N_Parameter_Specification | N_Component_Declaration
17573 -- A protected body has no elaboration code and contains
17574 -- only other bodies.
17576 if Nkind
(P
) = N_Protected_Body
then
17579 elsif Nkind
(P
) in N_Subprogram_Body
17581 | N_Block_Statement
17584 if L
= Declarations
(P
) then
17587 -- We are not in elaboration code, but we are doing
17588 -- dynamic elaboration checks, in this case, we still
17589 -- need to do the reference, since the subprogram we are
17590 -- in could be called from another unit, also in dynamic
17591 -- elaboration check mode, at elaboration time.
17593 elsif Dynamic_Elaboration_Checks
then
17595 -- We provide a debug flag to disable this check. That
17596 -- way we have an easy work around for regressions
17597 -- that are caused by this new check. This debug flag
17598 -- can be removed later.
17600 if Debug_Flag_DD
then
17604 -- Do the check in this case
17608 elsif Nkind
(P
) = N_Task_Body
then
17610 -- The check is deferred until Check_Task_Activation
17611 -- but we need to capture local suppress pragmas
17612 -- that may inhibit checks on this call.
17614 Ent
:= Get_Referenced_Ent
(N
);
17619 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
17620 or else Elaboration_Checks_Suppressed
(Ent
)
17621 or else Elaboration_Checks_Suppressed
(Scope
(Ent
))
17623 if Nkind
(N
) in N_Subprogram_Call
then
17624 Set_No_Elaboration_Check
(N
);
17630 -- Static model, call is not in elaboration code, we
17631 -- never need to worry, because in the static model the
17632 -- top-level caller always takes care of things.
17643 Ent
:= Get_Referenced_Ent
(N
);
17649 -- Determine whether a prior call to the same subprogram was already
17650 -- examined within the same context. If this is the case, then there is
17651 -- no need to proceed with the various warnings and checks because the
17652 -- work was already done for the previous call.
17655 Self
: constant Visited_Element
:=
17656 (Subp_Id
=> Ent
, Context
=> Parent
(N
));
17659 for Index
in 1 .. Elab_Visited
.Last
loop
17660 if Self
= Elab_Visited
.Table
(Index
) then
17666 -- See if we need to analyze this reference. We analyze it if either of
17667 -- the following conditions is met:
17669 -- It is an inner level call (since in this case it was triggered
17670 -- by an outer level call from elaboration code), but only if the
17671 -- call is within the scope of the original outer level call.
17673 -- It is an outer level reference from elaboration code, or a call to
17674 -- an entity is in the same elaboration scope.
17676 -- And in these cases, we will check both inter-unit calls and
17677 -- intra-unit (within a single unit) calls.
17679 C_Scope
:= Current_Scope
;
17681 -- If not outer level reference, then we follow it if it is within the
17682 -- original scope of the outer reference.
17684 if Present
(Outer_Scope
)
17685 and then Within
(Scope
(Ent
), Outer_Scope
)
17691 Outer_Scope
=> Outer_Scope
,
17692 Inter_Unit_Only
=> False,
17693 In_Init_Proc
=> In_Init_Proc
);
17695 -- Nothing to do if elaboration checks suppressed for this scope.
17696 -- However, an interesting exception, the fact that elaboration checks
17697 -- are suppressed within an instance (because we can trace the body when
17698 -- we process the template) does not extend to calls to generic formal
17701 elsif Elaboration_Checks_Suppressed
(Current_Scope
)
17702 and then not Is_Call_Of_Generic_Formal
(N
)
17706 elsif From_Elab_Code
then
17708 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
17710 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
17712 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
17714 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
17715 -- is set, then we will do the check, but only in the inter-unit case
17716 -- (this is to accommodate unguarded elaboration calls from other units
17717 -- in which this same mode is set). We don't want warnings in this case,
17718 -- it would generate warnings having nothing to do with elaboration.
17720 elsif Dynamic_Elaboration_Checks
then
17726 Inter_Unit_Only
=> True,
17727 Generate_Warnings
=> False);
17729 -- Otherwise nothing to do
17735 -- A call to an Init_Proc in elaboration code may bring additional
17736 -- dependencies, if some of the record components thereof have
17737 -- initializations that are function calls that come from source. We
17738 -- treat the current node as a call to each of these functions, to check
17739 -- their elaboration impact.
17741 if Is_Init_Proc
(Ent
) and then From_Elab_Code
then
17742 Process_Init_Proc
: declare
17743 Unit_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
17745 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
;
17746 -- Find subprogram calls within body of Init_Proc for Traverse
17747 -- instantiation below.
17749 procedure Traverse_Body
is new Traverse_Proc
(Check_Init_Call
);
17750 -- Traversal procedure to find all calls with body of Init_Proc
17752 ---------------------
17753 -- Check_Init_Call --
17754 ---------------------
17756 function Check_Init_Call
(Nod
: Node_Id
) return Traverse_Result
is
17760 if Nkind
(Nod
) in N_Subprogram_Call
17761 and then Is_Entity_Name
(Name
(Nod
))
17763 Func
:= Entity
(Name
(Nod
));
17765 if Comes_From_Source
(Func
) then
17767 (N
, Func
, Standard_Standard
, Inter_Unit_Only
=> True);
17775 end Check_Init_Call
;
17777 -- Start of processing for Process_Init_Proc
17780 if Nkind
(Unit_Decl
) = N_Subprogram_Body
then
17781 Traverse_Body
(Handled_Statement_Sequence
(Unit_Decl
));
17783 end Process_Init_Proc
;
17785 end Check_Elab_Call
;
17787 -----------------------
17788 -- Check_Elab_Assign --
17789 -----------------------
17791 procedure Check_Elab_Assign
(N
: Node_Id
) is
17795 Pkg_Spec
: Entity_Id
;
17796 Pkg_Body
: Entity_Id
;
17799 pragma Assert
(Legacy_Elaboration_Checks
);
17801 -- For record or array component, check prefix. If it is an access type,
17802 -- then there is nothing to do (we do not know what is being assigned),
17803 -- but otherwise this is an assignment to the prefix.
17805 if Nkind
(N
) in N_Indexed_Component | N_Selected_Component | N_Slice
then
17806 if not Is_Access_Type
(Etype
(Prefix
(N
))) then
17807 Check_Elab_Assign
(Prefix
(N
));
17813 -- For type conversion, check expression
17815 if Nkind
(N
) = N_Type_Conversion
then
17816 Check_Elab_Assign
(Expression
(N
));
17820 -- Nothing to do if this is not an entity reference otherwise get entity
17822 if Is_Entity_Name
(N
) then
17828 -- What we are looking for is a reference in the body of a package that
17829 -- modifies a variable declared in the visible part of the package spec.
17832 and then Comes_From_Source
(N
)
17833 and then not Suppress_Elaboration_Warnings
(Ent
)
17834 and then Ekind
(Ent
) = E_Variable
17835 and then not In_Private_Part
(Ent
)
17836 and then Is_Library_Level_Entity
(Ent
)
17838 Scop
:= Current_Scope
;
17840 if No
(Scop
) or else Scop
= Standard_Standard
then
17842 elsif Ekind
(Scop
) = E_Package
17843 and then Is_Compilation_Unit
(Scop
)
17847 Scop
:= Scope
(Scop
);
17851 -- Here Scop points to the containing library package
17854 Pkg_Body
:= Body_Entity
(Pkg_Spec
);
17856 -- All OK if the package has an Elaborate_Body pragma
17858 if Has_Pragma_Elaborate_Body
(Scop
) then
17862 -- OK if entity being modified is not in containing package spec
17864 if not In_Same_Source_Unit
(Scop
, Ent
) then
17868 -- All OK if entity appears in generic package or generic instance.
17869 -- We just get too messed up trying to give proper warnings in the
17870 -- presence of generics. Better no message than a junk one.
17872 Scop
:= Scope
(Ent
);
17873 while Present
(Scop
) and then Scop
/= Pkg_Spec
loop
17874 if Ekind
(Scop
) = E_Generic_Package
then
17876 elsif Ekind
(Scop
) = E_Package
17877 and then Is_Generic_Instance
(Scop
)
17882 Scop
:= Scope
(Scop
);
17885 -- All OK if in task, don't issue warnings there
17887 if In_Task_Activation
then
17891 -- OK if no package body
17893 if No
(Pkg_Body
) then
17897 -- OK if reference is not in package body
17899 if not In_Same_Source_Unit
(Pkg_Body
, N
) then
17903 -- OK if package body has no handled statement sequence
17906 HSS
: constant Node_Id
:=
17907 Handled_Statement_Sequence
(Declaration_Node
(Pkg_Body
));
17909 if No
(HSS
) or else not Comes_From_Source
(HSS
) then
17914 -- We definitely have a case of a modification of an entity in
17915 -- the package spec from the elaboration code of the package body.
17916 -- We may not give the warning (because there are some additional
17917 -- checks to avoid too many false positives), but it would be a good
17918 -- idea for the binder to try to keep the body elaboration close to
17919 -- the spec elaboration.
17921 Set_Elaborate_Body_Desirable
(Pkg_Spec
);
17923 -- All OK in gnat mode (we know what we are doing)
17929 -- All OK if all warnings suppressed
17931 if Warning_Mode
= Suppress
then
17935 -- All OK if elaboration checks suppressed for entity
17937 if Checks_May_Be_Suppressed
(Ent
)
17938 and then Is_Check_Suppressed
(Ent
, Elaboration_Check
)
17943 -- OK if the entity is initialized. Note that the No_Initialization
17944 -- flag usually means that the initialization has been rewritten into
17945 -- assignments, but that still counts for us.
17948 Decl
: constant Node_Id
:= Declaration_Node
(Ent
);
17950 if Nkind
(Decl
) = N_Object_Declaration
17951 and then (Present
(Expression
(Decl
))
17952 or else No_Initialization
(Decl
))
17958 -- Here is where we give the warning
17960 -- All OK if warnings suppressed on the entity
17962 if not Has_Warnings_Off
(Ent
) then
17963 Error_Msg_Sloc
:= Sloc
(Ent
);
17966 ("??& can be accessed by clients before this initialization",
17969 ("\??add Elaborate_Body to spec to ensure & is initialized",
17973 if not All_Errors_Mode
then
17974 Set_Suppress_Elaboration_Warnings
(Ent
);
17977 end Check_Elab_Assign
;
17979 ----------------------
17980 -- Check_Elab_Calls --
17981 ----------------------
17983 -- WARNING: This routine manages SPARK regions
17985 procedure Check_Elab_Calls
is
17986 Saved_SM
: SPARK_Mode_Type
;
17987 Saved_SMP
: Node_Id
;
17990 pragma Assert
(Legacy_Elaboration_Checks
);
17992 -- If expansion is disabled, do not generate any checks, unless we
17993 -- are in GNATprove mode, so that errors are issued in GNATprove for
17994 -- violations of static elaboration rules in SPARK code. Also skip
17995 -- checks if any subunits are missing because in either case we lack the
17996 -- full information that we need, and no object file will be created in
17999 if (not Expander_Active
and not GNATprove_Mode
)
18000 or else Is_Generic_Unit
(Cunit_Entity
(Main_Unit
))
18001 or else Subunits_Missing
18006 -- Skip delayed calls if we had any errors
18008 if Serious_Errors_Detected
= 0 then
18009 Delaying_Elab_Checks
:= False;
18010 Expander_Mode_Save_And_Set
(True);
18012 for J
in Delay_Check
.First
.. Delay_Check
.Last
loop
18013 Push_Scope
(Delay_Check
.Table
(J
).Curscop
);
18014 From_Elab_Code
:= Delay_Check
.Table
(J
).From_Elab_Code
;
18015 In_Task_Activation
:= Delay_Check
.Table
(J
).In_Task_Activation
;
18017 Saved_SM
:= SPARK_Mode
;
18018 Saved_SMP
:= SPARK_Mode_Pragma
;
18020 -- Set appropriate value of SPARK_Mode
18022 if Delay_Check
.Table
(J
).From_SPARK_Code
then
18026 Check_Internal_Call_Continue
18027 (N
=> Delay_Check
.Table
(J
).N
,
18028 E
=> Delay_Check
.Table
(J
).E
,
18029 Outer_Scope
=> Delay_Check
.Table
(J
).Outer_Scope
,
18030 Orig_Ent
=> Delay_Check
.Table
(J
).Orig_Ent
);
18032 Restore_SPARK_Mode
(Saved_SM
, Saved_SMP
);
18036 -- Set Delaying_Elab_Checks back on for next main compilation
18038 Expander_Mode_Restore
;
18039 Delaying_Elab_Checks
:= True;
18041 end Check_Elab_Calls
;
18043 ------------------------------
18044 -- Check_Elab_Instantiation --
18045 ------------------------------
18047 procedure Check_Elab_Instantiation
18049 Outer_Scope
: Entity_Id
:= Empty
)
18054 pragma Assert
(Legacy_Elaboration_Checks
);
18056 -- Check for and deal with bad instantiation case. There is some
18057 -- duplicated code here, but we will worry about this later ???
18059 Check_Bad_Instantiation
(N
);
18061 if Is_Known_Guaranteed_ABE
(N
) then
18065 -- Nothing to do if we do not have an instantiation (happens in some
18066 -- error cases, and also in the formal package declaration case)
18068 if Nkind
(N
) not in N_Generic_Instantiation
then
18072 -- Nothing to do if inside a generic template
18074 if Inside_A_Generic
then
18078 -- Nothing to do if the instantiation is not in the main unit
18080 if not In_Extended_Main_Code_Unit
(N
) then
18084 Ent
:= Get_Generic_Entity
(N
);
18085 From_Elab_Code
:= not In_Subprogram_Or_Concurrent_Unit
;
18087 -- See if we need to analyze this instantiation. We analyze it if
18088 -- either of the following conditions is met:
18090 -- It is an inner level instantiation (since in this case it was
18091 -- triggered by an outer level call from elaboration code), but
18092 -- only if the instantiation is within the scope of the original
18093 -- outer level call.
18095 -- It is an outer level instantiation from elaboration code, or the
18096 -- instantiated entity is in the same elaboration scope.
18098 -- And in these cases, we will check both the inter-unit case and
18099 -- the intra-unit (within a single unit) case.
18101 C_Scope
:= Current_Scope
;
18103 if Present
(Outer_Scope
) and then Within
(Scope
(Ent
), Outer_Scope
) then
18105 Check_A_Call
(N
, Ent
, Outer_Scope
, Inter_Unit_Only
=> False);
18107 elsif From_Elab_Code
then
18109 Check_A_Call
(N
, Ent
, Standard_Standard
, Inter_Unit_Only
=> False);
18111 elsif Same_Elaboration_Scope
(C_Scope
, Scope
(Ent
)) then
18113 Check_A_Call
(N
, Ent
, Scope
(Ent
), Inter_Unit_Only
=> False);
18115 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is
18116 -- set, then we will do the check, but only in the inter-unit case (this
18117 -- is to accommodate unguarded elaboration calls from other units in
18118 -- which this same mode is set). We inhibit warnings in this case, since
18119 -- this instantiation is not occurring in elaboration code.
18121 elsif Dynamic_Elaboration_Checks
then
18127 Inter_Unit_Only
=> True,
18128 Generate_Warnings
=> False);
18133 end Check_Elab_Instantiation
;
18135 -------------------------
18136 -- Check_Internal_Call --
18137 -------------------------
18139 procedure Check_Internal_Call
18142 Outer_Scope
: Entity_Id
;
18143 Orig_Ent
: Entity_Id
)
18145 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean;
18146 -- Determine whether call Call occurs within pragma Initial_Condition or
18147 -- pragma Check with check_kind set to Initial_Condition.
18149 ------------------------------
18150 -- Within_Initial_Condition --
18151 ------------------------------
18153 function Within_Initial_Condition
(Call
: Node_Id
) return Boolean is
18159 -- Traverse the parent chain looking for an enclosing pragma
18162 while Present
(Par
) loop
18163 if Nkind
(Par
) = N_Pragma
then
18164 Nam
:= Pragma_Name
(Par
);
18166 -- Pragma Initial_Condition appears in its alternative from as
18167 -- Check (Initial_Condition, ...).
18169 if Nam
= Name_Check
then
18170 Args
:= Pragma_Argument_Associations
(Par
);
18172 -- Pragma Check should have at least two arguments
18174 pragma Assert
(Present
(Args
));
18177 Chars
(Expression
(First
(Args
))) = Name_Initial_Condition
;
18181 elsif Nam
= Name_Initial_Condition
then
18184 -- Since pragmas are never nested within other pragmas, stop
18191 -- Prevent the search from going too far
18193 elsif Is_Body_Or_Package_Declaration
(Par
) then
18197 Par
:= Parent
(Par
);
18199 -- If assertions are not enabled, the check pragma is rewritten
18200 -- as an if_statement in sem_prag, to generate various warnings
18201 -- on boolean expressions. Retrieve the original pragma.
18203 if Nkind
(Original_Node
(Par
)) = N_Pragma
then
18204 Par
:= Original_Node
(Par
);
18209 end Within_Initial_Condition
;
18213 Inst_Case
: constant Boolean := Nkind
(N
) in N_Generic_Instantiation
;
18215 -- Start of processing for Check_Internal_Call
18218 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the
18219 -- node comes from source.
18221 if Nkind
(N
) = N_Attribute_Reference
18222 and then ((not Warn_On_Elab_Access
and then not Debug_Flag_Dot_O
)
18223 or else not Comes_From_Source
(N
))
18227 -- If not function or procedure call, instantiation, or 'Access, then
18228 -- ignore call (this happens in some error cases and rewriting cases).
18230 elsif Nkind
(N
) not in N_Attribute_Reference
18232 | N_Procedure_Call_Statement
18233 and then not Inst_Case
18237 -- Nothing to do if this is a call or instantiation that has already
18238 -- been found to be a sure ABE.
18240 elsif Nkind
(N
) /= N_Attribute_Reference
18241 and then Is_Known_Guaranteed_ABE
(N
)
18245 -- Nothing to do if errors already detected (avoid cascaded errors)
18247 elsif Serious_Errors_Detected
/= 0 then
18250 -- Nothing to do if not in full analysis mode
18252 elsif not Full_Analysis
then
18255 -- Nothing to do if analyzing in special spec-expression mode, since the
18256 -- call is not actually being made at this time.
18258 elsif In_Spec_Expression
then
18261 -- Nothing to do for call to intrinsic subprogram
18263 elsif Is_Intrinsic_Subprogram
(E
) then
18266 -- Nothing to do if call is within a generic unit
18268 elsif Inside_A_Generic
then
18271 -- Nothing to do when the call appears within pragma Initial_Condition.
18272 -- The pragma is part of the elaboration statements of a package body
18273 -- and may only call external subprograms or subprograms whose body is
18274 -- already available.
18276 elsif Within_Initial_Condition
(N
) then
18280 -- Delay this call if we are still delaying calls
18282 if Delaying_Elab_Checks
then
18286 Orig_Ent
=> Orig_Ent
,
18287 Curscop
=> Current_Scope
,
18288 Outer_Scope
=> Outer_Scope
,
18289 From_Elab_Code
=> From_Elab_Code
,
18290 In_Task_Activation
=> In_Task_Activation
,
18291 From_SPARK_Code
=> SPARK_Mode
= On
));
18294 -- Otherwise, call phase 2 continuation right now
18297 Check_Internal_Call_Continue
(N
, E
, Outer_Scope
, Orig_Ent
);
18299 end Check_Internal_Call
;
18301 ----------------------------------
18302 -- Check_Internal_Call_Continue --
18303 ----------------------------------
18305 procedure Check_Internal_Call_Continue
18308 Outer_Scope
: Entity_Id
;
18309 Orig_Ent
: Entity_Id
)
18311 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
;
18312 -- Function applied to each node as we traverse the body. Checks for
18313 -- call or entity reference that needs checking, and if so checks it.
18314 -- Always returns OK, so entire tree is traversed, except that as
18315 -- described below subprogram bodies are skipped for now.
18317 procedure Traverse
is new Atree
.Traverse_Proc
(Find_Elab_Reference
);
18318 -- Traverse procedure using above Find_Elab_Reference function
18320 -------------------------
18321 -- Find_Elab_Reference --
18322 -------------------------
18324 function Find_Elab_Reference
(N
: Node_Id
) return Traverse_Result
is
18328 -- If user has specified that there are no entry calls in elaboration
18329 -- code, do not trace past an accept statement, because the rendez-
18330 -- vous will happen after elaboration.
18332 if Nkind
(Original_Node
(N
)) in
18333 N_Accept_Statement | N_Selective_Accept
18334 and then Restriction_Active
(No_Entry_Calls_In_Elaboration_Code
)
18338 -- If we have a function call, check it
18340 elsif Nkind
(N
) = N_Function_Call
then
18341 Check_Elab_Call
(N
, Outer_Scope
);
18344 -- If we have a procedure call, check the call, and also check
18345 -- arguments that are assignments (OUT or IN OUT mode formals).
18347 elsif Nkind
(N
) = N_Procedure_Call_Statement
then
18348 Check_Elab_Call
(N
, Outer_Scope
, In_Init_Proc
=> Is_Init_Proc
(E
));
18350 Actual
:= First_Actual
(N
);
18351 while Present
(Actual
) loop
18352 if Known_To_Be_Assigned
(Actual
) then
18353 Check_Elab_Assign
(Actual
);
18356 Next_Actual
(Actual
);
18361 -- If we have an access attribute for a subprogram, check it.
18362 -- Suppress this behavior under debug flag.
18364 elsif not Debug_Flag_Dot_UU
18365 and then Nkind
(N
) = N_Attribute_Reference
18367 Attribute_Name
(N
) in Name_Access | Name_Unrestricted_Access
18368 and then Is_Entity_Name
(Prefix
(N
))
18369 and then Is_Subprogram
(Entity
(Prefix
(N
)))
18371 Check_Elab_Call
(N
, Outer_Scope
);
18374 -- In SPARK mode, if we have an entity reference to a variable, then
18375 -- check it. For now we consider any reference.
18377 elsif SPARK_Mode
= On
18378 and then Nkind
(N
) in N_Has_Entity
18379 and then Present
(Entity
(N
))
18380 and then Ekind
(Entity
(N
)) = E_Variable
18382 Check_Elab_Call
(N
, Outer_Scope
);
18385 -- If we have a generic instantiation, check it
18387 elsif Nkind
(N
) in N_Generic_Instantiation
then
18388 Check_Elab_Instantiation
(N
, Outer_Scope
);
18391 -- Skip subprogram bodies that come from source (wait for call to
18392 -- analyze these). The reason for the come from source test is to
18393 -- avoid catching task bodies.
18395 -- For task bodies, we should really avoid these too, waiting for the
18396 -- task activation, but that's too much trouble to catch for now, so
18397 -- we go in unconditionally. This is not so terrible, it means the
18398 -- error backtrace is not quite complete, and we are too eager to
18399 -- scan bodies of tasks that are unused, but this is hardly very
18402 elsif Nkind
(N
) = N_Subprogram_Body
18403 and then Comes_From_Source
(N
)
18407 elsif Nkind
(N
) = N_Assignment_Statement
18408 and then Comes_From_Source
(N
)
18410 Check_Elab_Assign
(Name
(N
));
18416 end Find_Elab_Reference
;
18418 Inst_Case
: constant Boolean := Is_Generic_Unit
(E
);
18419 Loc
: constant Source_Ptr
:= Sloc
(N
);
18424 -- Start of processing for Check_Internal_Call_Continue
18427 -- Save outer level call if at outer level
18429 if Elab_Call
.Last
= 0 then
18430 Outer_Level_Sloc
:= Loc
;
18433 -- If the call is to a function that renames a literal, no check needed
18435 if Ekind
(E
) = E_Enumeration_Literal
then
18439 -- Register the subprogram as examined within this particular context.
18440 -- This ensures that calls to the same subprogram but in different
18441 -- contexts receive warnings and checks of their own since the calls
18442 -- may be reached through different flow paths.
18444 Elab_Visited
.Append
((Subp_Id
=> E
, Context
=> Parent
(N
)));
18446 Sbody
:= Unit_Declaration_Node
(E
);
18448 if Nkind
(Sbody
) not in N_Subprogram_Body | N_Package_Body
then
18449 Ebody
:= Corresponding_Body
(Sbody
);
18454 Sbody
:= Unit_Declaration_Node
(Ebody
);
18458 -- If the body appears after the outer level call or instantiation then
18459 -- we have an error case handled below.
18461 if Earlier_In_Extended_Unit
(Outer_Level_Sloc
, Sloc
(Sbody
))
18462 and then not In_Task_Activation
18466 -- If we have the instantiation case we are done, since we now know that
18467 -- the body of the generic appeared earlier.
18469 elsif Inst_Case
then
18472 -- Otherwise we have a call, so we trace through the called body to see
18473 -- if it has any problems.
18476 pragma Assert
(Nkind
(Sbody
) = N_Subprogram_Body
);
18478 Elab_Call
.Append
((Cloc
=> Loc
, Ent
=> E
));
18480 if Debug_Flag_Underscore_LL
then
18481 Write_Str
("Elab_Call.Last = ");
18482 Write_Int
(Int
(Elab_Call
.Last
));
18483 Write_Str
(" Ent = ");
18484 Write_Name
(Chars
(E
));
18485 Write_Str
(" at ");
18486 Write_Location
(Sloc
(N
));
18490 -- Now traverse declarations and statements of subprogram body. Note
18491 -- that we cannot simply Traverse (Sbody), since traverse does not
18492 -- normally visit subprogram bodies.
18497 Decl
:= First
(Declarations
(Sbody
));
18498 while Present
(Decl
) loop
18504 Traverse
(Handled_Statement_Sequence
(Sbody
));
18506 Elab_Call
.Decrement_Last
;
18510 -- Here is the case of calling a subprogram where the body has not yet
18511 -- been encountered. A warning message is needed, except if this is the
18512 -- case of appearing within an aspect specification that results in
18513 -- a check call, we do not really have such a situation, so no warning
18514 -- is needed (e.g. the case of a precondition, where the call appears
18515 -- textually before the body, but in actual fact is moved to the
18516 -- appropriate subprogram body and so does not need a check).
18525 -- Keep looking at parents if we are still in the subexpression
18527 if Nkind
(P
) in N_Subexpr
then
18530 -- Here P is the parent of the expression, check for special case
18533 O
:= Original_Node
(P
);
18535 -- Definitely not the special case if orig node is not a pragma
18537 exit when Nkind
(O
) /= N_Pragma
;
18539 -- Check we have an If statement or a null statement (happens
18540 -- when the If has been expanded to be True).
18542 exit when Nkind
(P
) not in N_If_Statement | N_Null_Statement
;
18544 -- Our special case will be indicated either by the pragma
18545 -- coming from an aspect ...
18547 if Present
(Corresponding_Aspect
(O
)) then
18550 -- Or, in the case of an initial condition, specifically by a
18551 -- Check pragma specifying an Initial_Condition check.
18553 elsif Pragma_Name
(O
) = Name_Check
18556 (Expression
(First
(Pragma_Argument_Associations
(O
)))) =
18557 Name_Initial_Condition
18561 -- For anything else, we have an error
18570 -- Not that special case, warning and dynamic check is required
18572 -- If we have nothing in the call stack, then this is at the outer
18573 -- level, and the ABE is bound to occur, unless it's a 'Access, or
18574 -- it's a renaming.
18576 if Elab_Call
.Last
= 0 then
18577 Error_Msg_Warn
:= SPARK_Mode
/= On
;
18580 Insert_Check
: Boolean := True;
18581 -- This flag is set to True if an elaboration check should be
18585 if In_Task_Activation
then
18586 Insert_Check
:= False;
18588 elsif Inst_Case
then
18590 ("cannot instantiate& before body seen<<", N
, Orig_Ent
);
18592 elsif Nkind
(N
) = N_Attribute_Reference
then
18594 ("Access attribute of & before body seen<<", N
, Orig_Ent
);
18596 ("\possible Program_Error on later references<<", N
);
18597 Insert_Check
:= False;
18599 elsif Nkind
(Unit_Declaration_Node
(Orig_Ent
)) /=
18600 N_Subprogram_Renaming_Declaration
18601 or else Is_Generic_Actual_Subprogram
(Orig_Ent
)
18604 ("cannot call& before body seen<<", N
, Orig_Ent
);
18606 Insert_Check
:= False;
18609 if Insert_Check
then
18610 Error_Msg_N
("\Program_Error [<<", N
);
18611 Insert_Elab_Check
(N
);
18615 -- Call is not at outer level
18618 -- Do not generate elaboration checks in GNATprove mode because the
18619 -- elaboration counter and the check are both forms of expansion.
18621 if GNATprove_Mode
then
18624 -- Generate an elaboration check
18626 elsif not Elaboration_Checks_Suppressed
(E
) then
18627 Set_Elaboration_Entity_Required
(E
);
18629 -- Create a declaration of the elaboration entity, and insert it
18630 -- prior to the subprogram or the generic unit, within the same
18631 -- scope. Since the subprogram may be overloaded, create a unique
18634 if No
(Elaboration_Entity
(E
)) then
18636 Loce
: constant Source_Ptr
:= Sloc
(E
);
18637 Ent
: constant Entity_Id
:=
18638 Make_Defining_Identifier
(Loc
,
18639 New_External_Name
(Chars
(E
), 'E', -1));
18642 Set_Elaboration_Entity
(E
, Ent
);
18643 Push_Scope
(Scope
(E
));
18645 Insert_Action
(Declaration_Node
(E
),
18646 Make_Object_Declaration
(Loce
,
18647 Defining_Identifier
=> Ent
,
18648 Object_Definition
=>
18649 New_Occurrence_Of
(Standard_Short_Integer
, Loce
),
18651 Make_Integer_Literal
(Loc
, Uint_0
)));
18653 -- Set elaboration flag at the point of the body
18655 Set_Elaboration_Flag
(Sbody
, E
);
18657 -- Kill current value indication. This is necessary because
18658 -- the tests of this flag are inserted out of sequence and
18659 -- must not pick up bogus indications of the wrong constant
18660 -- value. Also, this is never a true constant, since one way
18661 -- or another, it gets reset.
18663 Set_Current_Value
(Ent
, Empty
);
18664 Set_Last_Assignment
(Ent
, Empty
);
18665 Set_Is_True_Constant
(Ent
, False);
18672 -- raise Program_Error with "access before elaboration";
18675 Insert_Elab_Check
(N
,
18676 Make_Attribute_Reference
(Loc
,
18677 Attribute_Name
=> Name_Elaborated
,
18678 Prefix
=> New_Occurrence_Of
(E
, Loc
)));
18681 -- Generate the warning
18683 if not Suppress_Elaboration_Warnings
(E
)
18684 and then not Elaboration_Checks_Suppressed
(E
)
18686 -- Suppress this warning if we have a function call that occurred
18687 -- within an assertion expression, since we can get false warnings
18688 -- in this case, due to the out of order handling in this case.
18691 (Nkind
(Original_Node
(N
)) /= N_Function_Call
18692 or else not In_Assertion_Expression_Pragma
(Original_Node
(N
)))
18694 Error_Msg_Warn
:= SPARK_Mode
/= On
;
18698 ("instantiation of& may occur before body is seen<l<",
18701 -- A rather specific check: for Adjust/Finalize/Initialize, if
18702 -- the type has Warnings_Off set, suppress the warning.
18704 if Is_Controlled_Procedure
(E
, Name_Adjust
)
18705 or else Is_Controlled_Procedure
(E
, Name_Finalize
)
18706 or else Is_Controlled_Procedure
(E
, Name_Initialize
)
18709 T
: constant Entity_Id
:= Etype
(First_Formal
(E
));
18712 if Has_Warnings_Off
(T
)
18713 or else (Ekind
(T
) = E_Private_Type
18714 and then Has_Warnings_Off
(Full_View
(T
)))
18721 -- Go ahead and give warning if not this special case
18724 ("call to& may occur before body is seen<l<", N
, Orig_Ent
);
18727 Error_Msg_N
("\Program_Error ]<l<", N
);
18729 -- There is no need to query the elaboration warning message flags
18730 -- because the main message is an error, not a warning, therefore
18731 -- all the clarification messages produces by Output_Calls must be
18732 -- emitted unconditionally.
18736 Output_Calls
(N
, Check_Elab_Flag
=> False);
18739 end Check_Internal_Call_Continue
;
18741 ---------------------------
18742 -- Check_Task_Activation --
18743 ---------------------------
18745 procedure Check_Task_Activation
(N
: Node_Id
) is
18746 Loc
: constant Source_Ptr
:= Sloc
(N
);
18747 Inter_Procs
: constant Elist_Id
:= New_Elmt_List
;
18748 Intra_Procs
: constant Elist_Id
:= New_Elmt_List
;
18751 Task_Scope
: Entity_Id
;
18752 Cunit_SC
: Boolean := False;
18755 Enclosing
: Entity_Id
;
18757 procedure Add_Task_Proc
(Typ
: Entity_Id
);
18758 -- Add to Task_Procs the task body procedure(s) of task types in Typ.
18759 -- For record types, this procedure recurses over component types.
18761 procedure Collect_Tasks
(Decls
: List_Id
);
18762 -- Collect the types of the tasks that are to be activated in the given
18763 -- list of declarations, in order to perform elaboration checks on the
18764 -- corresponding task procedures that are called implicitly here.
18766 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
;
18767 -- find enclosing compilation unit of Entity, ignoring subunits, or
18768 -- else enclosing subprogram. If E is not a package, there is no need
18769 -- for inter-unit elaboration checks.
18771 -------------------
18772 -- Add_Task_Proc --
18773 -------------------
18775 procedure Add_Task_Proc
(Typ
: Entity_Id
) is
18777 Proc
: Entity_Id
:= Empty
;
18780 if Is_Task_Type
(Typ
) then
18781 Proc
:= Get_Task_Body_Procedure
(Typ
);
18783 elsif Is_Array_Type
(Typ
)
18784 and then Has_Task
(Base_Type
(Typ
))
18786 Add_Task_Proc
(Component_Type
(Typ
));
18788 elsif Is_Record_Type
(Typ
)
18789 and then Has_Task
(Base_Type
(Typ
))
18791 Comp
:= First_Component
(Typ
);
18792 while Present
(Comp
) loop
18793 Add_Task_Proc
(Etype
(Comp
));
18794 Next_Component
(Comp
);
18798 -- If the task type is another unit, we will perform the usual
18799 -- elaboration check on its enclosing unit. If the type is in the
18800 -- same unit, we can trace the task body as for an internal call,
18801 -- but we only need to examine other external calls, because at
18802 -- the point the task is activated, internal subprogram bodies
18803 -- will have been elaborated already. We keep separate lists for
18804 -- each kind of task.
18806 -- Skip this test if errors have occurred, since in this case
18807 -- we can get false indications.
18809 if Serious_Errors_Detected
/= 0 then
18813 if Present
(Proc
) then
18814 if Outer_Unit
(Scope
(Proc
)) = Enclosing
then
18816 if No
(Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
18818 (not Is_Generic_Instance
(Scope
(Proc
))
18819 or else Scope
(Proc
) = Scope
(Defining_Identifier
(Decl
)))
18821 Error_Msg_Warn
:= SPARK_Mode
/= On
;
18823 ("task will be activated before elaboration of its body<<",
18825 Error_Msg_N
("\Program_Error [<<", Decl
);
18828 (Corresponding_Body
(Unit_Declaration_Node
(Proc
)))
18830 Append_Elmt
(Proc
, Intra_Procs
);
18834 -- No need for multiple entries of the same type
18836 Elmt
:= First_Elmt
(Inter_Procs
);
18837 while Present
(Elmt
) loop
18838 if Node
(Elmt
) = Proc
then
18845 Append_Elmt
(Proc
, Inter_Procs
);
18850 -------------------
18851 -- Collect_Tasks --
18852 -------------------
18854 procedure Collect_Tasks
(Decls
: List_Id
) is
18856 Decl
:= First
(Decls
);
18857 while Present
(Decl
) loop
18858 if Nkind
(Decl
) = N_Object_Declaration
18859 and then Has_Task
(Etype
(Defining_Identifier
(Decl
)))
18861 Add_Task_Proc
(Etype
(Defining_Identifier
(Decl
)));
18872 function Outer_Unit
(E
: Entity_Id
) return Entity_Id
is
18877 while Present
(Outer
) loop
18878 if Elaboration_Checks_Suppressed
(Outer
) then
18882 exit when Is_Child_Unit
(Outer
)
18883 or else Scope
(Outer
) = Standard_Standard
18884 or else Ekind
(Outer
) /= E_Package
;
18885 Outer
:= Scope
(Outer
);
18891 -- Start of processing for Check_Task_Activation
18894 pragma Assert
(Legacy_Elaboration_Checks
);
18896 Enclosing
:= Outer_Unit
(Current_Scope
);
18898 -- Find all tasks declared in the current unit
18900 if Nkind
(N
) = N_Package_Body
then
18901 P
:= Unit_Declaration_Node
(Corresponding_Spec
(N
));
18903 Collect_Tasks
(Declarations
(N
));
18904 Collect_Tasks
(Visible_Declarations
(Specification
(P
)));
18905 Collect_Tasks
(Private_Declarations
(Specification
(P
)));
18907 elsif Nkind
(N
) = N_Package_Declaration
then
18908 Collect_Tasks
(Visible_Declarations
(Specification
(N
)));
18909 Collect_Tasks
(Private_Declarations
(Specification
(N
)));
18912 Collect_Tasks
(Declarations
(N
));
18915 -- We only perform detailed checks in all tasks that are library level
18916 -- entities. If the master is a subprogram or task, activation will
18917 -- depend on the activation of the master itself.
18919 -- Should dynamic checks be added in the more general case???
18921 if Ekind
(Enclosing
) /= E_Package
then
18925 -- For task types defined in other units, we want the unit containing
18926 -- the task body to be elaborated before the current one.
18928 Elmt
:= First_Elmt
(Inter_Procs
);
18929 while Present
(Elmt
) loop
18930 Ent
:= Node
(Elmt
);
18931 Task_Scope
:= Outer_Unit
(Scope
(Ent
));
18933 if not Is_Compilation_Unit
(Task_Scope
) then
18936 elsif Suppress_Elaboration_Warnings
(Task_Scope
)
18937 or else Elaboration_Checks_Suppressed
(Task_Scope
)
18941 elsif Dynamic_Elaboration_Checks
then
18942 if not Elaboration_Checks_Suppressed
(Ent
)
18943 and then not Cunit_SC
18944 and then not Restriction_Active
18945 (No_Entry_Calls_In_Elaboration_Code
)
18947 -- Runtime elaboration check required. Generate check of the
18948 -- elaboration counter for the unit containing the entity.
18950 Insert_Elab_Check
(N
,
18951 Make_Attribute_Reference
(Loc
,
18953 New_Occurrence_Of
(Spec_Entity
(Task_Scope
), Loc
),
18954 Attribute_Name
=> Name_Elaborated
));
18958 -- Force the binder to elaborate other unit first
18960 if Elab_Info_Messages
18961 and then not Suppress_Elaboration_Warnings
(Ent
)
18962 and then not Elaboration_Checks_Suppressed
(Ent
)
18963 and then not Suppress_Elaboration_Warnings
(Task_Scope
)
18964 and then not Elaboration_Checks_Suppressed
(Task_Scope
)
18966 Error_Msg_Node_2
:= Task_Scope
;
18968 ("info: activation of an instance of task type & requires "
18969 & "pragma Elaborate_All on &?$?", N
, Ent
);
18972 Activate_Elaborate_All_Desirable
(N
, Task_Scope
);
18973 Set_Suppress_Elaboration_Warnings
(Task_Scope
);
18979 -- For tasks declared in the current unit, trace other calls within the
18980 -- task procedure bodies, which are available.
18982 if not Debug_Flag_Dot_Y
then
18983 In_Task_Activation
:= True;
18985 Elmt
:= First_Elmt
(Intra_Procs
);
18986 while Present
(Elmt
) loop
18987 Ent
:= Node
(Elmt
);
18988 Check_Internal_Call_Continue
(N
, Ent
, Enclosing
, Ent
);
18992 In_Task_Activation
:= False;
18994 end Check_Task_Activation
;
18996 ------------------------
18997 -- Get_Referenced_Ent --
18998 ------------------------
19000 function Get_Referenced_Ent
(N
: Node_Id
) return Entity_Id
is
19004 if Nkind
(N
) in N_Has_Entity
19005 and then Present
(Entity
(N
))
19006 and then Ekind
(Entity
(N
)) = E_Variable
19011 if Nkind
(N
) = N_Attribute_Reference
then
19019 elsif Nkind
(Nam
) = N_Selected_Component
then
19020 return Entity
(Selector_Name
(Nam
));
19021 elsif not Is_Entity_Name
(Nam
) then
19024 return Entity
(Nam
);
19026 end Get_Referenced_Ent
;
19028 ----------------------
19029 -- Has_Generic_Body --
19030 ----------------------
19032 function Has_Generic_Body
(N
: Node_Id
) return Boolean is
19033 Ent
: constant Entity_Id
:= Get_Generic_Entity
(N
);
19034 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
19037 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
;
19038 -- Determine if the list of nodes headed by N and linked by Next
19039 -- contains a package body for the package spec entity E, and if so
19040 -- return the package body. If not, then returns Empty.
19042 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
;
19043 -- This procedure is called load the unit whose name is given by Nam.
19044 -- This unit is being loaded to see whether it contains an optional
19045 -- generic body. The returned value is the loaded unit, which is always
19046 -- a package body (only package bodies can contain other entities in the
19047 -- sense in which Has_Generic_Body is interested). We only attempt to
19048 -- load bodies if we are generating code. If we are in semantics check
19049 -- only mode, then it would be wrong to load bodies that are not
19050 -- required from a semantic point of view, so in this case we return
19051 -- Empty. The result is that the caller may incorrectly decide that a
19052 -- generic spec does not have a body when in fact it does, but the only
19053 -- harm in this is that some warnings on elaboration problems may be
19054 -- lost in semantic checks only mode, which is not big loss. We also
19055 -- return Empty if we go for a body and it is not there.
19057 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
;
19058 -- PE is the entity for a package spec. This function locates the
19059 -- corresponding package body, returning Empty if none is found. The
19060 -- package body returned is fully parsed but may not yet be analyzed,
19061 -- so only syntactic fields should be referenced.
19067 function Find_Body_In
(E
: Entity_Id
; N
: Node_Id
) return Node_Id
is
19072 while Present
(Nod
) loop
19074 -- If we found the package body we are looking for, return it
19076 if Nkind
(Nod
) = N_Package_Body
19077 and then Chars
(Defining_Unit_Name
(Nod
)) = Chars
(E
)
19081 -- If we found the stub for the body, go after the subunit,
19082 -- loading it if necessary.
19084 elsif Nkind
(Nod
) = N_Package_Body_Stub
19085 and then Chars
(Defining_Identifier
(Nod
)) = Chars
(E
)
19087 if Present
(Library_Unit
(Nod
)) then
19088 return Unit
(Library_Unit
(Nod
));
19091 return Load_Package_Body
(Get_Unit_Name
(Nod
));
19094 -- If neither package body nor stub, keep looking on chain
19104 -----------------------
19105 -- Load_Package_Body --
19106 -----------------------
19108 function Load_Package_Body
(Nam
: Unit_Name_Type
) return Node_Id
is
19109 U
: Unit_Number_Type
;
19112 if Operating_Mode
/= Generate_Code
then
19122 if U
= No_Unit
then
19125 return Unit
(Cunit
(U
));
19128 end Load_Package_Body
;
19130 -------------------------------
19131 -- Locate_Corresponding_Body --
19132 -------------------------------
19134 function Locate_Corresponding_Body
(PE
: Entity_Id
) return Node_Id
is
19135 Spec
: constant Node_Id
:= Declaration_Node
(PE
);
19136 Decl
: constant Node_Id
:= Parent
(Spec
);
19137 Scop
: constant Entity_Id
:= Scope
(PE
);
19141 if Is_Library_Level_Entity
(PE
) then
19143 -- If package is a library unit that requires a body, we have no
19144 -- choice but to go after that body because it might contain an
19145 -- optional body for the original generic package.
19147 if Unit_Requires_Body
(PE
) then
19149 -- Load the body. Note that we are a little careful here to use
19150 -- Spec to get the unit number, rather than PE or Decl, since
19151 -- in the case where the package is itself a library level
19152 -- instantiation, Spec will properly reference the generic
19153 -- template, which is what we really want.
19157 (Get_Body_Name
(Unit_Name
(Get_Source_Unit
(Spec
))));
19159 -- But if the package is a library unit that does NOT require
19160 -- a body, then no body is permitted, so we are sure that there
19161 -- is no body for the original generic package.
19167 -- Otherwise look and see if we are embedded in a further package
19169 elsif Is_Package_Or_Generic_Package
(Scop
) then
19171 -- If so, get the body of the enclosing package, and look in
19172 -- its package body for the package body we are looking for.
19174 PBody
:= Locate_Corresponding_Body
(Scop
);
19179 return Find_Body_In
(PE
, First
(Declarations
(PBody
)));
19182 -- If we are not embedded in a further package, then the body
19183 -- must be in the same declarative part as we are.
19186 return Find_Body_In
(PE
, Next
(Decl
));
19188 end Locate_Corresponding_Body
;
19190 -- Start of processing for Has_Generic_Body
19193 if Present
(Corresponding_Body
(Decl
)) then
19196 elsif Unit_Requires_Body
(Ent
) then
19199 -- Compilation units cannot have optional bodies
19201 elsif Is_Compilation_Unit
(Ent
) then
19204 -- Otherwise look at what scope we are in
19207 Scop
:= Scope
(Ent
);
19209 -- Case of entity is in other than a package spec, in this case
19210 -- the body, if present, must be in the same declarative part.
19212 if not Is_Package_Or_Generic_Package
(Scop
) then
19217 -- Declaration node may get us a spec, so if so, go to
19218 -- the parent declaration.
19220 P
:= Declaration_Node
(Ent
);
19221 while not Is_List_Member
(P
) loop
19225 return Present
(Find_Body_In
(Ent
, Next
(P
)));
19228 -- If the entity is in a package spec, then we have to locate
19229 -- the corresponding package body, and look there.
19233 PBody
: constant Node_Id
:= Locate_Corresponding_Body
(Scop
);
19241 (Find_Body_In
(Ent
, (First
(Declarations
(PBody
)))));
19246 end Has_Generic_Body
;
19248 -----------------------
19249 -- Insert_Elab_Check --
19250 -----------------------
19252 procedure Insert_Elab_Check
(N
: Node_Id
; C
: Node_Id
:= Empty
) is
19254 Loc
: constant Source_Ptr
:= Sloc
(N
);
19257 -- The check (N_Raise_Program_Error) node to be inserted
19260 -- If expansion is disabled, do not generate any checks. Also
19261 -- skip checks if any subunits are missing because in either
19262 -- case we lack the full information that we need, and no object
19263 -- file will be created in any case.
19265 if not Expander_Active
or else Subunits_Missing
then
19269 -- If we have a generic instantiation, where Instance_Spec is set,
19270 -- then this field points to a generic instance spec that has
19271 -- been inserted before the instantiation node itself, so that
19272 -- is where we want to insert a check.
19274 if Nkind
(N
) in N_Generic_Instantiation
19275 and then Present
(Instance_Spec
(N
))
19277 Nod
:= Instance_Spec
(N
);
19282 -- Build check node, possibly with condition
19285 Make_Raise_Program_Error
(Loc
, Reason
=> PE_Access_Before_Elaboration
);
19287 if Present
(C
) then
19288 Set_Condition
(Chk
, Make_Op_Not
(Loc
, Right_Opnd
=> C
));
19291 -- If we are inserting at the top level, insert in Aux_Decls
19293 if Nkind
(Parent
(Nod
)) = N_Compilation_Unit
then
19295 ADN
: constant Node_Id
:= Aux_Decls_Node
(Parent
(Nod
));
19298 if No
(Declarations
(ADN
)) then
19299 Set_Declarations
(ADN
, New_List
(Chk
));
19301 Append_To
(Declarations
(ADN
), Chk
);
19307 -- Otherwise just insert as an action on the node in question
19310 Insert_Action
(Nod
, Chk
);
19312 end Insert_Elab_Check
;
19314 -------------------------------
19315 -- Is_Call_Of_Generic_Formal --
19316 -------------------------------
19318 function Is_Call_Of_Generic_Formal
(N
: Node_Id
) return Boolean is
19320 return Nkind
(N
) in N_Subprogram_Call
19322 -- Always return False if debug flag -gnatd.G is set
19324 and then not Debug_Flag_Dot_GG
19326 -- For now, we detect this by looking for the strange identifier
19327 -- node, whose Chars reflect the name of the generic formal, but
19328 -- the Chars of the Entity references the generic actual.
19330 and then Nkind
(Name
(N
)) = N_Identifier
19331 and then Chars
(Name
(N
)) /= Chars
(Entity
(Name
(N
)));
19332 end Is_Call_Of_Generic_Formal
;
19334 -----------------------------
19335 -- Is_Controlled_Procedure --
19336 -----------------------------
19338 function Is_Controlled_Procedure
19340 Nam
: Name_Id
) return Boolean
19343 -- To qualify, the subprogram must denote a source procedure with
19344 -- name Adjust, Finalize, or Initialize where the sole formal is
19345 -- in out and controlled.
19347 if Comes_From_Source
(Id
) and then Ekind
(Id
) = E_Procedure
then
19349 Formal_Id
: constant Entity_Id
:= First_Formal
(Id
);
19353 Present
(Formal_Id
)
19354 and then Ekind
(Formal_Id
) = E_In_Out_Parameter
19355 and then Is_Controlled
(Etype
(Formal_Id
))
19356 and then No
(Next_Formal
(Formal_Id
))
19357 and then Chars
(Id
) =
19358 Name_Of_Controlled_Prim_Op
(Etype
(Formal_Id
), Nam
);
19363 end Is_Controlled_Procedure
;
19365 -------------------------------
19366 -- Is_Finalization_Procedure --
19367 -------------------------------
19369 function Is_Finalization_Procedure
(Id
: Entity_Id
) return Boolean is
19371 -- Check whether Id is a procedure with at least one parameter
19373 if Ekind
(Id
) = E_Procedure
and then Present
(First_Formal
(Id
)) then
19375 Typ
: constant Entity_Id
:= Etype
(First_Formal
(Id
));
19376 Deep_Fin
: Entity_Id
:= Empty
;
19377 Fin
: Entity_Id
:= Empty
;
19380 -- If the type of the first formal does not require finalization
19381 -- actions, then this is definitely not [Deep_]Finalize.
19383 if not Needs_Finalization
(Typ
) then
19387 -- At this point we have the following scenario:
19389 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
19391 -- Recover the two possible versions of [Deep_]Finalize using the
19392 -- type of the first parameter and compare with the input.
19394 Deep_Fin
:= TSS
(Typ
, TSS_Deep_Finalize
);
19396 if Is_Controlled
(Typ
) then
19397 Fin
:= Find_Controlled_Prim_Op
(Typ
, Name_Finalize
);
19400 return (Present
(Deep_Fin
) and then Id
= Deep_Fin
)
19401 or else (Present
(Fin
) and then Id
= Fin
);
19406 end Is_Finalization_Procedure
;
19412 procedure Output_Calls
19414 Check_Elab_Flag
: Boolean)
19416 function Emit
(Flag
: Boolean) return Boolean;
19417 -- Determine whether to emit an error message based on the combination
19418 -- of flags Check_Elab_Flag and Flag.
19420 function Is_Printable_Error_Name
return Boolean;
19421 -- An internal function, used to determine if a name, stored in the
19422 -- Name_Buffer, is either a non-internal name, or is an internal name
19423 -- that is printable by the error message circuits (i.e. it has a single
19424 -- upper case letter at the end).
19430 function Emit
(Flag
: Boolean) return Boolean is
19432 if Check_Elab_Flag
then
19439 -----------------------------
19440 -- Is_Printable_Error_Name --
19441 -----------------------------
19443 function Is_Printable_Error_Name
return Boolean is
19445 if not Is_Internal_Name
then
19448 elsif Name_Len
= 1 then
19452 Name_Len
:= Name_Len
- 1;
19453 return not Is_Internal_Name
;
19455 end Is_Printable_Error_Name
;
19461 -- Start of processing for Output_Calls
19464 for J
in reverse 1 .. Elab_Call
.Last
loop
19465 Error_Msg_Sloc
:= Elab_Call
.Table
(J
).Cloc
;
19467 Ent
:= Elab_Call
.Table
(J
).Ent
;
19468 Get_Name_String
(Chars
(Ent
));
19470 -- Dynamic elaboration model, warnings controlled by -gnatwl
19472 if Dynamic_Elaboration_Checks
then
19473 if Emit
(Elab_Warnings
) then
19474 if Is_Generic_Unit
(Ent
) then
19475 Error_Msg_NE
("\\?l?& instantiated #", N
, Ent
);
19476 elsif Is_Init_Proc
(Ent
) then
19477 Error_Msg_N
("\\?l?initialization procedure called #", N
);
19478 elsif Is_Printable_Error_Name
then
19479 Error_Msg_NE
("\\?l?& called #", N
, Ent
);
19481 Error_Msg_N
("\\?l?called #", N
);
19485 -- Static elaboration model, info messages controlled by -gnatel
19488 if Emit
(Elab_Info_Messages
) then
19489 if Is_Generic_Unit
(Ent
) then
19490 Error_Msg_NE
("\\?$?& instantiated #", N
, Ent
);
19491 elsif Is_Init_Proc
(Ent
) then
19492 Error_Msg_N
("\\?$?initialization procedure called #", N
);
19493 elsif Is_Printable_Error_Name
then
19494 Error_Msg_NE
("\\?$?& called #", N
, Ent
);
19496 Error_Msg_N
("\\?$?called #", N
);
19503 ----------------------------
19504 -- Same_Elaboration_Scope --
19505 ----------------------------
19507 function Same_Elaboration_Scope
(Scop1
, Scop2
: Entity_Id
) return Boolean is
19512 -- Find elaboration scope for Scop1
19513 -- This is either a subprogram or a compilation unit.
19516 while S1
/= Standard_Standard
19517 and then not Is_Compilation_Unit
(S1
)
19518 and then Ekind
(S1
) in E_Package | E_Protected_Type | E_Block
19523 -- Find elaboration scope for Scop2
19526 while S2
/= Standard_Standard
19527 and then not Is_Compilation_Unit
(S2
)
19528 and then Ekind
(S2
) in E_Package | E_Protected_Type | E_Block
19534 end Same_Elaboration_Scope
;
19540 procedure Set_C_Scope
is
19542 while not Is_Compilation_Unit
(C_Scope
) loop
19543 C_Scope
:= Scope
(C_Scope
);
19547 --------------------------------
19548 -- Set_Elaboration_Constraint --
19549 --------------------------------
19551 procedure Set_Elaboration_Constraint
19556 Elab_Unit
: Entity_Id
;
19558 -- Check whether this is a call to an Initialize subprogram for a
19559 -- controlled type. Note that Call can also be a 'Access attribute
19560 -- reference, which now generates an elaboration check.
19562 Init_Call
: constant Boolean :=
19563 Nkind
(Call
) = N_Procedure_Call_Statement
19564 and then Is_Controlled_Procedure
(Subp
, Name_Initialize
);
19567 -- If the unit is mentioned in a with_clause of the current unit, it is
19568 -- visible, and we can set the elaboration flag.
19570 if Is_Immediately_Visible
(Scop
)
19571 or else (Is_Child_Unit
(Scop
) and then Is_Visible_Lib_Unit
(Scop
))
19573 Activate_Elaborate_All_Desirable
(Call
, Scop
);
19574 Set_Suppress_Elaboration_Warnings
(Scop
);
19578 -- If this is not an initialization call or a call using object notation
19579 -- we know that the unit of the called entity is in the context, and we
19580 -- can set the flag as well. The unit need not be visible if the call
19581 -- occurs within an instantiation.
19583 if Is_Init_Proc
(Subp
)
19585 or else Nkind
(Original_Node
(Call
)) = N_Selected_Component
19587 null; -- detailed processing follows.
19590 Activate_Elaborate_All_Desirable
(Call
, Scop
);
19591 Set_Suppress_Elaboration_Warnings
(Scop
);
19595 -- If the unit is not in the context, there must be an intermediate unit
19596 -- that is, on which we need to place to elaboration flag. This happens
19597 -- with init proc calls.
19599 if Is_Init_Proc
(Subp
) or else Init_Call
then
19601 -- The initialization call is on an object whose type is not declared
19602 -- in the same scope as the subprogram. The type of the object must
19603 -- be a subtype of the type of operation. This object is the first
19604 -- actual in the call.
19607 Typ
: constant Entity_Id
:=
19608 Etype
(First
(Parameter_Associations
(Call
)));
19610 Elab_Unit
:= Scope
(Typ
);
19611 while Present
(Elab_Unit
)
19612 and then not Is_Compilation_Unit
(Elab_Unit
)
19614 Elab_Unit
:= Scope
(Elab_Unit
);
19618 -- If original node uses selected component notation, the prefix is
19619 -- visible and determines the scope that must be elaborated. After
19620 -- rewriting, the prefix is the first actual in the call.
19622 elsif Nkind
(Original_Node
(Call
)) = N_Selected_Component
then
19623 Elab_Unit
:= Scope
(Etype
(First
(Parameter_Associations
(Call
))));
19625 -- Not one of special cases above
19628 -- Using previously computed scope. If the elaboration check is
19629 -- done after analysis, the scope is not visible any longer, but
19630 -- must still be in the context.
19635 Activate_Elaborate_All_Desirable
(Call
, Elab_Unit
);
19636 Set_Suppress_Elaboration_Warnings
(Elab_Unit
);
19637 end Set_Elaboration_Constraint
;
19643 function Spec_Entity
(E
: Entity_Id
) return Entity_Id
is
19647 -- Check for case of body entity
19648 -- Why is the check for E_Void needed???
19650 if Ekind
(E
) in E_Void | E_Subprogram_Body | E_Package_Body
then
19654 Decl
:= Parent
(Decl
);
19655 exit when Nkind
(Decl
) in N_Proper_Body
;
19658 return Corresponding_Spec
(Decl
);
19669 function Within
(E1
, E2
: Entity_Id
) return Boolean is
19676 elsif Scop
= Standard_Standard
then
19679 Scop
:= Scope
(Scop
);
19684 --------------------------
19685 -- Within_Elaborate_All --
19686 --------------------------
19688 function Within_Elaborate_All
19689 (Unit
: Unit_Number_Type
;
19690 E
: Entity_Id
) return Boolean
19692 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
19693 pragma Pack
(Unit_Number_Set
);
19695 Seen
: Unit_Number_Set
:= (others => False);
19696 -- Seen (X) is True after we have seen unit X in the walk. This is used
19697 -- to prevent processing the same unit more than once.
19699 Result
: Boolean := False;
19701 procedure Helper
(Unit
: Unit_Number_Type
);
19702 -- This helper procedure does all the work for Within_Elaborate_All. It
19703 -- walks the dependency graph, and sets Result to True if it finds an
19704 -- appropriate Elaborate_All.
19710 procedure Helper
(Unit
: Unit_Number_Type
) is
19711 CU
: constant Node_Id
:= Cunit
(Unit
);
19715 Elab_Id
: Entity_Id
;
19719 if Seen
(Unit
) then
19722 Seen
(Unit
) := True;
19725 -- First, check for Elaborate_Alls on this unit
19727 Item
:= First
(Context_Items
(CU
));
19728 while Present
(Item
) loop
19729 if Nkind
(Item
) = N_Pragma
19730 and then Pragma_Name
(Item
) = Name_Elaborate_All
19732 -- Return if some previous error on the pragma itself. The
19733 -- pragma may be unanalyzed, because of a previous error, or
19734 -- if it is the context of a subunit, inherited by its parent.
19736 if Error_Posted
(Item
) or else not Analyzed
(Item
) then
19742 (Expression
(First
(Pragma_Argument_Associations
(Item
))));
19744 if E
= Elab_Id
then
19749 Par
:= Parent
(Unit_Declaration_Node
(Elab_Id
));
19751 Item2
:= First
(Context_Items
(Par
));
19752 while Present
(Item2
) loop
19753 if Nkind
(Item2
) = N_With_Clause
19754 and then Entity
(Name
(Item2
)) = E
19755 and then not Limited_Present
(Item2
)
19768 -- Second, recurse on with's. We could do this as part of the above
19769 -- loop, but it's probably more efficient to have two loops, because
19770 -- the relevant Elaborate_All is likely to be on the initial unit. In
19771 -- other words, we're walking the with's breadth-first. This part is
19772 -- only necessary in the dynamic elaboration model.
19774 if Dynamic_Elaboration_Checks
then
19775 Item
:= First
(Context_Items
(CU
));
19776 while Present
(Item
) loop
19777 if Nkind
(Item
) = N_With_Clause
19778 and then not Limited_Present
(Item
)
19780 -- Note: the following call to Get_Cunit_Unit_Number does a
19781 -- linear search, which could be slow, but it's OK because
19782 -- we're about to give a warning anyway. Also, there might
19783 -- be hundreds of units, but not millions. If it turns out
19784 -- to be a problem, we could store the Get_Cunit_Unit_Number
19785 -- in each N_Compilation_Unit node, but that would involve
19786 -- rearranging N_Compilation_Unit_Aux to make room.
19788 Helper
(Get_Cunit_Unit_Number
(Library_Unit
(Item
)));
19800 -- Start of processing for Within_Elaborate_All
19805 end Within_Elaborate_All
;