1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2019, 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 Elists; use Elists;
32 with Errout; use Errout;
33 with Exp_Ch11; use Exp_Ch11;
34 with Exp_Tss; use Exp_Tss;
35 with Exp_Util; use Exp_Util;
36 with Expander; use Expander;
38 with Lib.Load; use Lib.Load;
39 with Namet; use Namet;
40 with Nlists; use Nlists;
41 with Nmake; use Nmake;
43 with Output; use Output;
44 with Restrict; use Restrict;
45 with Rident; use Rident;
46 with Rtsfind; use Rtsfind;
48 with Sem_Aux; use Sem_Aux;
49 with Sem_Cat; use Sem_Cat;
50 with Sem_Ch7; use Sem_Ch7;
51 with Sem_Ch8; use Sem_Ch8;
52 with Sem_Disp; use Sem_Disp;
53 with Sem_Prag; use Sem_Prag;
54 with Sem_Util; use Sem_Util;
55 with Sinfo; use Sinfo;
56 with Sinput; use Sinput;
57 with Snames; use Snames;
58 with Stand; use Stand;
60 with Tbuild; use Tbuild;
61 with Uintp; use Uintp;
62 with Uname; use Uname;
65 with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
66 with GNAT.Lists; use GNAT.Lists;
67 with GNAT.Sets; use GNAT.Sets;
69 package body Sem_Elab is
71 -----------------------------------------
72 -- Access-before-elaboration mechanism --
73 -----------------------------------------
75 -- The access-before-elaboration (ABE) mechanism implemented in this unit
76 -- has the following objectives:
78 -- * Diagnose at compile-time or install run-time checks to prevent ABE
79 -- access to data and behaviour.
81 -- The high-level idea is to accurately diagnose ABE issues within a
82 -- single unit because the ABE mechanism can inspect the whole unit.
83 -- As soon as the elaboration graph extends to an external unit, the
84 -- diagnostics stop because the body of the unit may not be available.
85 -- Due to control and data flow, the ABE mechanism cannot accurately
86 -- determine whether a particular scenario will be elaborated or not.
87 -- Conditional ABE checks are therefore used to verify the elaboration
88 -- status of local and external targets at run time.
90 -- * Supply implicit elaboration dependencies for a unit to binde
92 -- The ABE mechanism creates implicit dependencies in the form of with
93 -- clauses subject to pragma Elaborate[_All] when the elaboration graph
94 -- reaches into an external unit. The implicit dependencies are encoded
95 -- in the ALI file of the main unit. GNATbind and binde then use these
96 -- dependencies to augment the library item graph and determine the
97 -- elaboration order of all units in the compilation.
99 -- * Supply pieces of the invocation graph for a unit to bindo
101 -- The ABE mechanism captures paths starting from elaboration code or
102 -- top level constructs that reach into an external unit. The paths are
103 -- encoded in the ALI file of the main unit in the form of declarations
104 -- which represent nodes, and relations which represent edges. GNATbind
105 -- and bindo then build the full invocation graph in order to augment
106 -- the library item graph and determine the elaboration order of all
107 -- units in the compilation.
109 -- The ABE mechanism supports three models of elaboration:
111 -- * Dynamic model - This is the most permissive of the three models.
112 -- When the dynamic model is in effect, the mechanism diagnoses and
113 -- installs run-time checks to detect ABE issues in the main unit.
114 -- The behaviour of this model is identical to that specified by the
115 -- Ada RM. This model is enabled with switch -gnatE.
117 -- Static model - This is the middle ground of the three models. When
118 -- the static model is in effect, the mechanism diagnoses and installs
119 -- run-time checks to detect ABE issues in the main unit. In addition,
120 -- the mechanism generates implicit dependencies between units in the
121 -- form of with clauses subject to pragma Elaborate[_All] to ensure
122 -- the prior elaboration of withed units. This is the default model.
124 -- * SPARK model - This is the most conservative of the three models and
125 -- impelements the semantics defined in SPARK RM 7.7. The SPARK model
126 -- is in effect only when a context resides in a SPARK_Mode On region,
127 -- otherwise the mechanism falls back to one of the previous models.
129 -- The ABE mechanism consists of a "recording" phase and a "processing"
136 -- * ABE - An attempt to invoke a scenario which has not been elaborated
139 -- * Bridge target - A type of target. A bridge target is a link between
140 -- scenarios. It is usually a byproduct of expansion and does not have
141 -- any direct ABE ramifications.
143 -- * Call marker - A special node used to indicate the presence of a call
144 -- in the tree in case expansion transforms or eliminates the original
145 -- call. N_Call_Marker nodes do not have static and run-time semantics.
147 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the
148 -- invocation of a target by a scenario within the main unit causes an
149 -- ABE, but does not cause an ABE for another scenarios within the main
152 -- * Declaration level - A type of enclosing level. A scenario or target is
153 -- at the declaration level when it appears within the declarations of a
154 -- block statement, entry body, subprogram body, or task body, ignoring
155 -- enclosing packages.
157 -- * Early call region - A section of code which ends at a subprogram body
158 -- and starts from the nearest non-preelaborable construct which precedes
159 -- the subprogram body. The early call region extends from a package body
160 -- to a package spec when the spec carries pragma Elaborate_Body.
162 -- * Generic library level - A type of enclosing level. A scenario or
163 -- target is at the generic library level if it appears in a generic
164 -- package library unit, ignoring enclosing packages.
166 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the
167 -- invocation of a target by all scenarios within the main unit causes
170 -- * Instantiation library level - A type of enclosing level. A scenario
171 -- or target is at the instantiation library level if it appears in an
172 -- instantiation library unit, ignoring enclosing packages.
174 -- * Invocation - The act of activating a task, calling a subprogram, or
175 -- instantiating a generic.
177 -- * Invocation construct - An entry declaration, [single] protected type,
178 -- subprogram declaration, subprogram instantiation, or a [single] task
179 -- type declared in the visible, private, or body declarations of the
182 -- * Invocation relation - A flow link between two invocation constructs
184 -- * Invocation signature - A set of attributes that uniquely identify an
185 -- invocation construct within the namespace of all ALI files.
187 -- * Library level - A type of enclosing level. A scenario or target is at
188 -- the library level if it appears in a package library unit, ignoring
189 -- enclosng packages.
191 -- * Non-library-level encapsulator - A construct that cannot be elaborated
192 -- on its own and requires elaboration by a top-level scenario.
194 -- * Scenario - A construct or context which is invoked by elaboration code
195 -- or invocation construct. The scenarios recognized by the ABE mechanism
198 -- - '[Unrestricted_]Access of entries, operators, and subprograms
200 -- - Assignments to variables
202 -- - Calls to entries, operators, and subprograms
204 -- - Derived type declarations
208 -- - Pragma Refined_State
210 -- - Reads of variables
214 -- * Target - A construct invoked by a scenario. The targets recognized by
215 -- the ABE mechanism are as follows:
217 -- - For '[Unrestricted_]Access of entries, operators, and subprograms,
218 -- the target is the entry, operator, or subprogram.
220 -- - For assignments to variables, the target is the variable
222 -- - For calls, the target is the entry, operator, or subprogram
224 -- - For derived type declarations, the target is the derived type
226 -- - For instantiations, the target is the generic template
228 -- - For pragma Refined_State, the targets are the constituents
230 -- - For reads of variables, the target is the variable
232 -- - For task activation, the target is the task body
238 -- Analysis/Resolution
240 -- +- Build_Call_Marker
242 -- +- Build_Variable_Reference_Marker
244 -- +- | -------------------- Recording phase ---------------------------+
246 -- | Record_Elaboration_Scenario |
248 -- | +--> Check_Preelaborated_Call |
250 -- | +--> Process_Guaranteed_ABE |
252 -- | | +--> Process_Guaranteed_ABE_Activation |
253 -- | | +--> Process_Guaranteed_ABE_Call |
254 -- | | +--> Process_Guaranteed_ABE_Instantiation |
256 -- +- | ----------------------------------------------------------------+
259 -- +--> Internal_Representation
261 -- +--> Scenario_Storage
263 -- End of Compilation
265 -- +- | --------------------- Processing phase -------------------------+
267 -- | Check_Elaboration_Scenarios |
269 -- | +--> Check_Conditional_ABE_Scenarios |
271 -- | | +--> Process_Conditional_ABE <----------------------+ |
273 -- | | +--> Process_Conditional_ABE_Activation | |
275 -- | | | +-----------------------------+ | |
277 -- | | +--> Process_Conditional_ABE_Call +---> Traverse_Body |
279 -- | | | +-----------------------------+ |
281 -- | | +--> Process_Conditional_ABE_Access_Taken |
282 -- | | +--> Process_Conditional_ABE_Instantiation |
283 -- | | +--> Process_Conditional_ABE_Variable_Assignment |
284 -- | | +--> Process_Conditional_ABE_Variable_Reference |
286 -- | +--> Check_SPARK_Scenario |
288 -- | | +--> Process_SPARK_Scenario |
290 -- | | +--> Process_SPARK_Derived_Type |
291 -- | | +--> Process_SPARK_Instantiation |
292 -- | | +--> Process_SPARK_Refined_State_Pragma |
294 -- | +--> Record_Invocation_Graph |
296 -- | +--> Process_Invocation_Body_Scenarios |
297 -- | +--> Process_Invocation_Spec_Scenarios |
298 -- | +--> Process_Main_Unit |
300 -- | +--> Process_Invocation_Scenario <-------------+ |
302 -- | +--> Process_Invocation_Activation | |
304 -- | | +------------------------+ | |
306 -- | +--> Process_Invocation_Call +---> Traverse_Body |
308 -- | +------------------------+ |
310 -- +--------------------------------------------------------------------+
312 ---------------------
313 -- Recording phase --
314 ---------------------
316 -- The Recording phase coincides with the analysis/resolution phase of the
317 -- compiler. It has the following objectives:
319 -- * Record all suitable scenarios for examination by the Processing
322 -- Saving only a certain number of nodes improves the performance of
323 -- the ABE mechanism. This eliminates the need to examine the whole
324 -- tree in a separate pass.
326 -- * Record certain SPARK scenarios which are not necessarily invoked
327 -- during elaboration, but still require elaboration-related checks.
329 -- Saving only a certain number of nodes improves the performance of
330 -- the ABE mechanism. This eliminates the need to examine the whole
331 -- tree in a separate pass.
333 -- * Detect and diagnose calls in preelaborable or pure units, including
336 -- This diagnostic is carried out during the Recording phase because it
337 -- does not need the heavy recursive traversal done by the Processing
340 -- * Detect and diagnose guaranteed ABEs caused by instantiations, calls,
341 -- and task activation.
343 -- The issues detected by the ABE mechanism are reported as warnings
344 -- because they do not violate Ada semantics. Forward instantiations
345 -- may thus reach gigi, however gigi cannot handle certain kinds of
346 -- premature instantiations and may crash. To avoid this limitation,
347 -- the ABE mechanism must identify forward instantiations as early as
348 -- possible and suppress their bodies. Calls and task activations are
349 -- included in this category for completeness.
351 ----------------------
352 -- Processing phase --
353 ----------------------
355 -- The Processing phase is a separate pass which starts after instantiating
356 -- and/or inlining of bodies, but before the removal of Ghost code. It has
357 -- the following objectives:
359 -- * Examine all scenarios saved during the Recording phase, and perform
360 -- the following actions:
364 -- Diagnose conditional ABEs, and install run-time conditional ABE
365 -- checks for all scenarios.
369 -- Enforce the SPARK elaboration rules
373 -- Diagnose conditional ABEs, install run-time conditional ABE
374 -- checks only for scenarios are reachable from elaboration code,
375 -- and guarantee the elaboration of external units by creating
376 -- implicit with clauses subject to pragma Elaborate[_All].
378 -- * Examine library-level scenarios and invocation constructs, and
379 -- perform the following actions:
381 -- - Determine whether the flow of execution reaches into an external
382 -- unit. If this is the case, encode the path in the ALI file of
385 -- - Create declarations for invocation constructs in the ALI file of
388 ----------------------
389 -- Important points --
390 ----------------------
392 -- The Processing phase starts after the analysis, resolution, expansion
393 -- phase has completed. As a result, no current semantic information is
394 -- available. The scope stack is empty, global flags such as In_Instance
395 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism
396 -- must either save or recompute semantic information.
398 -- Expansion heavily transforms calls and to some extent instantiations. To
399 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to
400 -- capture the target and relevant attributes of the original call.
402 -- The diagnostics of the ABE mechanism depend on accurate source locations
403 -- to determine the spacial relation of nodes.
405 -----------------------------------------
406 -- Suppression of elaboration warnings --
407 -----------------------------------------
409 -- Elaboration warnings along multiple traversal paths rooted at a scenario
410 -- are suppressed when the scenario has elaboration warnings suppressed.
414 -- +-- Child scenario 1
416 -- | +-- Grandchild scenario 1
418 -- | +-- Grandchild scenario N
420 -- +-- Child scenario N
422 -- If the root scenario has elaboration warnings suppressed, then all its
423 -- child, grandchild, etc. scenarios will have their elaboration warnings
426 -- In addition to switch -gnatwL, pragma Warnings may be used to suppress
427 -- elaboration-related warnings when used in the following manner:
429 -- pragma Warnings ("L");
430 -- <scenario-or-target>
433 -- pragma Warnings (Off, target);
435 -- pragma Warnings (Off);
436 -- <scenario-or-target>
438 -- * To suppress elaboration warnings for '[Unrestricted_]Access of
439 -- entries, operators, and subprograms, either:
441 -- - Suppress the entry, operator, or subprogram, or
442 -- - Suppress the attribute, or
443 -- - Use switch -gnatw.f
445 -- * To suppress elaboration warnings for calls to entries, operators,
446 -- and subprograms, either:
448 -- - Suppress the entry, operator, or subprogram, or
449 -- - Suppress the call
451 -- * To suppress elaboration warnings for instantiations, suppress the
454 -- * To suppress elaboration warnings for task activations, either:
456 -- - Suppress the task object, or
457 -- - Suppress the task type, or
458 -- - Suppress the activation call
464 -- The following switches may be used to control the behavior of the ABE
467 -- -gnatd_a stop elaboration checks on accept or select statement
469 -- The ABE mechanism stops the traversal of a task body when it
470 -- encounters an accept or a select statement. This behavior is
471 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code,
472 -- but without penalizing actual entry calls during elaboration.
474 -- -gnatd_e ignore entry calls and requeue statements for elaboration
476 -- The ABE mechanism does not generate N_Call_Marker nodes for
477 -- protected or task entry calls as well as requeue statements.
478 -- As a result, the calls and requeues are not recorded or
481 -- -gnatdE elaboration checks on predefined units
483 -- The ABE mechanism considers scenarios which appear in internal
484 -- units (Ada, GNAT, Interfaces, System).
486 -- -gnatd_F encode full invocation paths in ALI files
488 -- The ABE mechanism encodes the full path from an elaboration
489 -- procedure or invocable construct to an external target. The
490 -- path contains all intermediate activations, instantiations,
493 -- -gnatd.G ignore calls through generic formal parameters for elaboration
495 -- The ABE mechanism does not generate N_Call_Marker nodes for
496 -- calls which occur in expanded instances, and invoke generic
497 -- actual subprograms through generic formal subprograms. As a
498 -- result, the calls are not recorded or processed.
500 -- -gnatd_i ignore activations and calls to instances for elaboration
502 -- The ABE mechanism ignores calls and task activations when they
503 -- target a subprogram or task type defined an external instance.
504 -- As a result, the calls and task activations are not processed.
506 -- -gnatdL ignore external calls from instances for elaboration
508 -- The ABE mechanism does not generate N_Call_Marker nodes for
509 -- calls which occur in expanded instances, do not invoke generic
510 -- actual subprograms through formal subprograms, and the target
511 -- is external to the instance. As a result, the calls are not
512 -- recorded or processed.
514 -- -gnatd.o conservative elaboration order for indirect calls
516 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
517 -- operator, or subprogram as an immediate invocation of the
518 -- target. As a result, it performs ABE checks and diagnostics on
519 -- the immediate call.
521 -- -gnatd_p ignore assertion pragmas for elaboration
523 -- The ABE mechanism does not generate N_Call_Marker nodes for
524 -- calls to subprograms which verify the run-time semantics of
525 -- the following assertion pragmas:
527 -- Default_Initial_Condition
535 -- Type_Invariant_Class
537 -- As a result, the assertion expressions of the pragmas are not
540 -- -gnatd_s stop elaboration checks on synchronous suspension
542 -- The ABE mechanism stops the traversal of a task body when it
543 -- encounters a call to one of the following routines:
545 -- Ada.Synchronous_Barriers.Wait_For_Release
546 -- Ada.Synchronous_Task_Control.Suspend_Until_True
548 -- -gnatd_T output trace information on invocation relation construction
550 -- The ABE mechanism outputs text information concerning relation
551 -- construction to standard output.
553 -- -gnatd.U ignore indirect calls for static elaboration
555 -- The ABE mechanism does not consider '[Unrestricted_]Access of
556 -- entries, operators, and subprograms. As a result, the scenarios
557 -- are not recorder or processed.
559 -- -gnatd.v enforce SPARK elaboration rules in SPARK code
561 -- The ABE mechanism applies some of the SPARK elaboration rules
562 -- defined in the SPARK reference manual, chapter 7.7. Note that
563 -- certain rules are always enforced, regardless of whether the
566 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies
568 -- The ABE mechanism does not generate implicit Elaborate_All when
569 -- the need for the pragma came from a task body.
571 -- -gnatE dynamic elaboration checking mode enabled
573 -- The ABE mechanism assumes that any scenario is elaborated or
574 -- invoked by elaboration code. The ABE mechanism performs very
575 -- little diagnostics and generates condintional ABE checks to
576 -- detect ABE issues at run-time.
578 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas
580 -- The ABE mechanism produces information messages on generated
581 -- implicit Elabote[_All] pragmas along with traceback showing
582 -- why the pragma was generated. In addition, the ABE mechanism
583 -- produces information messages for each scenario elaborated or
584 -- invoked by elaboration code.
586 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas
588 -- The complementary switch for -gnatel.
590 -- -gnatH legacy elaboration checking mode enabled
592 -- When this switch is in effect, the pre-18.x ABE model becomes
593 -- the defacto ABE model. This ammounts to cutting off all entry
594 -- points into the new ABE mechanism, and giving full control to
595 -- the old ABE mechanism.
597 -- -gnatJ permissive elaboration checking mode enabled
599 -- This switch activates the following switches:
611 -- IMPORTANT: The behavior of the ABE mechanism becomes more
612 -- permissive at the cost of accurate diagnostics and runtime
615 -- -gnatw.f turn on warnings for suspicious Subp'Access
617 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
618 -- operator, or subprogram as a pseudo invocation of the target.
619 -- As a result, it performs ABE diagnostics on the pseudo call.
621 -- -gnatw.F turn off warnings for suspicious Subp'Access
623 -- The complementary switch for -gnatw.f.
625 -- -gnatwl turn on warnings for elaboration problems
627 -- The ABE mechanism produces warnings on detected ABEs along with
628 -- a traceback showing the graph of the ABE.
630 -- -gnatwL turn off warnings for elaboration problems
632 -- The complementary switch for -gnatwl.
634 --------------------------
635 -- Debugging ABE issues --
636 --------------------------
638 -- * If the issue involves a call, ensure that the call is eligible for ABE
639 -- processing and receives a corresponding call marker. The routines of
643 -- Record_Elaboration_Scenario
645 -- * If the issue involves an arbitrary scenario, ensure that the scenario
646 -- is either recorded, or is successfully recognized while traversing a
647 -- body. The routines of interest are
649 -- Record_Elaboration_Scenario
650 -- Process_Conditional_ABE
651 -- Process_Guaranteed_ABE
654 -- * If the issue involves a circularity in the elaboration order, examine
655 -- the ALI files and look for the following encodings next to units:
657 -- E indicates a source Elaborate
659 -- EA indicates a source Elaborate_All
661 -- AD indicates an implicit Elaborate_All
663 -- ED indicates an implicit Elaborate
665 -- If possible, compare these encodings with those generated by the old
666 -- ABE mechanism. The routines of interest are
668 -- Ensure_Prior_Elaboration
674 -- The following type enumerates all possible elaboration phase statutes
676 type Elaboration_Phase_Status is
678 -- The elaboration phase of the compiler has not started yet
681 -- The elaboration phase of the compiler is currently in progress
684 -- The elaboration phase of the compiler has finished
686 Elaboration_Phase : Elaboration_Phase_Status := Inactive;
687 -- The status of the elaboration phase. Use routine Set_Elaboration_Phase
688 -- to alter its value.
690 -- The following type enumerates all subprogram body traversal modes
692 type Body_Traversal_Kind is
694 -- The traversal examines the internals of a subprogram
698 -- The following type enumerates all operation modes
700 type Processing_Kind is
701 (Conditional_ABE_Processing,
702 -- The ABE mechanism detects and diagnoses conditional ABEs for library
703 -- and declaration-level scenarios.
705 Dynamic_Model_Processing,
706 -- The ABE mechanism installs conditional ABE checks for all eligible
707 -- scenarios when the dynamic model is in effect.
709 Guaranteed_ABE_Processing,
710 -- The ABE mechanism detects and diagnoses guaranteed ABEs caused by
711 -- calls, instantiations, and task activations.
713 Invocation_Construct_Processing,
714 -- The ABE mechanism locates all invocation constructs within the main
715 -- unit and utilizes them as roots of miltiple DFS traversals aimed at
716 -- detecting transitions from the main unit to an external unit.
718 Invocation_Body_Processing,
719 -- The ABE mechanism utilizes all library-level body scenarios as roots
720 -- of miltiple DFS traversals aimed at detecting transitions from the
721 -- main unit to an external unit.
723 Invocation_Spec_Processing,
724 -- The ABE mechanism utilizes all library-level spec scenarios as roots
725 -- of miltiple DFS traversals aimed at detecting transitions from the
726 -- main unit to an external unit.
729 -- The ABE mechanism detects and diagnoses violations of the SPARK
730 -- elaboration rules for SPARK-specific scenarios.
734 -- The following type enumerates all possible scenario kinds
736 type Scenario_Kind is
737 (Access_Taken_Scenario,
738 -- An attribute reference which takes 'Access or 'Unrestricted_Access of
739 -- an entry, operator, or subprogram.
742 -- A call which invokes an entry, operator, or subprogram
744 Derived_Type_Scenario,
745 -- A declaration of a derived type. This is a SPARK-specific scenario.
747 Instantiation_Scenario,
748 -- An instantiation which instantiates a generic package or subprogram.
749 -- This scenario is also subject to SPARK-specific rules.
751 Refined_State_Pragma_Scenario,
752 -- A Refined_State pragma. This is a SPARK-specific scenario.
754 Task_Activation_Scenario,
755 -- A call which activates objects of various task types
757 Variable_Assignment_Scenario,
758 -- An assignment statement which modifies the value of some variable
760 Variable_Reference_Scenario,
761 -- A reference to a variable. This is a SPARK-specific scenario.
765 -- The following type enumerates all possible consistency models of target
766 -- and scenario representations.
768 type Representation_Kind is
769 (Inconsistent_Representation,
770 -- A representation is said to be "inconsistent" when it is created from
771 -- a partially analyzed tree. In such an environment, certain attributes
772 -- such as a completing body may not be available yet.
774 Consistent_Representation,
775 -- A representation is said to be "consistent" when it is created from a
776 -- fully analyzed tree, where all attributes are available.
780 -- The following type enumerates all possible target kinds
784 -- A generic unit being instantiated
787 -- The package form of an instantiation
790 -- An entry, operator, or subprogram being invoked, or aliased through
791 -- 'Access or 'Unrestricted_Access.
794 -- A task being activated by an activation call
797 -- A variable being updated through an assignment statement, or read
798 -- through a variable reference.
806 procedure Destroy (NE : in out Node_Or_Entity_Id);
807 pragma Inline (Destroy);
808 -- Destroy node or entity NE
810 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type;
811 pragma Inline (Hash);
812 -- Obtain the hash value of key NE
814 -- The following is a general purpose list for nodes and entities
816 package NE_List is new Doubly_Linked_Lists
817 (Element_Type => Node_Or_Entity_Id,
819 Destroy_Element => Destroy);
821 -- The following is a general purpose map which relates nodes and entities
822 -- to lists of nodes and entities.
824 package NE_List_Map is new Dynamic_Hash_Tables
825 (Key_Type => Node_Or_Entity_Id,
826 Value_Type => NE_List.Doubly_Linked_List,
827 No_Value => NE_List.Nil,
828 Expansion_Threshold => 1.5,
829 Expansion_Factor => 2,
830 Compression_Threshold => 0.3,
831 Compression_Factor => 2,
833 Destroy_Value => NE_List.Destroy,
836 -- The following is a general purpose membership set for nodes and entities
838 package NE_Set is new Membership_Sets
839 (Element_Type => Node_Or_Entity_Id,
843 -- The following type captures relevant attributes which pertain to the
844 -- in state of the Processing phase.
846 type Processing_In_State is record
847 Processing : Processing_Kind := No_Processing;
848 -- Operation mode of the Processing phase. Once set, this value should
851 Representation : Representation_Kind := No_Representation;
852 -- Required level of scenario and target representation. Once set, this
853 -- value should not be changed.
855 Suppress_Checks : Boolean := False;
856 -- This flag is set when the Processing phase must not generate any ABE
859 Suppress_Implicit_Pragmas : Boolean := False;
860 -- This flag is set when the Processing phase must not generate any
861 -- implicit Elaborate[_All] pragmas.
863 Suppress_Info_Messages : Boolean := False;
864 -- This flag is set when the Processing phase must not emit any info
867 Suppress_Up_Level_Targets : Boolean := False;
868 -- This flag is set when the Processing phase must ignore up-level
871 Suppress_Warnings : Boolean := False;
872 -- This flag is set when the Processing phase must not emit any warnings
873 -- on elaboration problems.
875 Traversal : Body_Traversal_Kind := No_Traversal;
876 -- The subprogram body traversal mode. Once set, this value should not
879 Within_Generic : Boolean := False;
880 -- This flag is set when the Processing phase is currently within a
883 Within_Initial_Condition : Boolean := False;
884 -- This flag is set when the Processing phase is currently examining a
885 -- scenario which was reached from an initial condition procedure.
887 Within_Partial_Finalization : Boolean := False;
888 -- This flag is set when the Processing phase is currently examining a
889 -- scenario which was reached from a partial finalization procedure.
891 Within_Task_Body : Boolean := False;
892 -- This flag is set when the Processing phase is currently examining a
893 -- scenario which was reached from a task body.
896 -- The following constants define the various operational states of the
899 -- The conditional ABE state is used when processing scenarios that appear
900 -- at the declaration, instantiation, and library levels to detect errors
901 -- and install conditional ABE checks.
903 Conditional_ABE_State : constant Processing_In_State :=
904 (Processing => Conditional_ABE_Processing,
905 Representation => Consistent_Representation,
906 Traversal => Deep_Traversal,
909 -- The dynamic model state is used to install conditional ABE checks when
910 -- switch -gnatE (dynamic elaboration checking mode enabled) is in effect.
912 Dynamic_Model_State : constant Processing_In_State :=
913 (Processing => Dynamic_Model_Processing,
914 Representation => Consistent_Representation,
915 Suppress_Implicit_Pragmas => True,
916 Suppress_Info_Messages => True,
917 Suppress_Up_Level_Targets => True,
918 Suppress_Warnings => True,
919 Traversal => No_Traversal,
922 -- The guaranteed ABE state is used when processing scenarios that appear
923 -- at the declaration, instantiation, and library levels to detect errors
924 -- and install guarateed ABE failures.
926 Guaranteed_ABE_State : constant Processing_In_State :=
927 (Processing => Guaranteed_ABE_Processing,
928 Representation => Inconsistent_Representation,
929 Suppress_Implicit_Pragmas => True,
930 Traversal => No_Traversal,
933 -- The invocation body state is used when processing scenarios that appear
934 -- at the body library level to encode paths that start from elaboration
935 -- code and ultimately reach into external units.
937 Invocation_Body_State : constant Processing_In_State :=
938 (Processing => Invocation_Body_Processing,
939 Representation => Consistent_Representation,
940 Suppress_Checks => True,
941 Suppress_Implicit_Pragmas => True,
942 Suppress_Info_Messages => True,
943 Suppress_Up_Level_Targets => True,
944 Suppress_Warnings => True,
945 Traversal => Deep_Traversal,
948 -- The invocation construct state is used when processing constructs that
949 -- appear within the spec and body of the main unit and eventually reach
950 -- into external units.
952 Invocation_Construct_State : constant Processing_In_State :=
953 (Processing => Invocation_Construct_Processing,
954 Representation => Consistent_Representation,
955 Suppress_Checks => True,
956 Suppress_Implicit_Pragmas => True,
957 Suppress_Info_Messages => True,
958 Suppress_Up_Level_Targets => True,
959 Suppress_Warnings => True,
960 Traversal => Deep_Traversal,
963 -- The invocation spec state is used when processing scenarios that appear
964 -- at the spec library level to encode paths that start from elaboration
965 -- code and ultimately reach into external units.
967 Invocation_Spec_State : constant Processing_In_State :=
968 (Processing => Invocation_Spec_Processing,
969 Representation => Consistent_Representation,
970 Suppress_Checks => True,
971 Suppress_Implicit_Pragmas => True,
972 Suppress_Info_Messages => True,
973 Suppress_Up_Level_Targets => True,
974 Suppress_Warnings => True,
975 Traversal => Deep_Traversal,
978 -- The SPARK state is used when verying SPARK-specific semantics of certain
981 SPARK_State : constant Processing_In_State :=
982 (Processing => SPARK_Processing,
983 Representation => Consistent_Representation,
984 Traversal => No_Traversal,
987 -- The following type identifies a scenario representation
989 type Scenario_Rep_Id is new Natural;
991 No_Scenario_Rep : constant Scenario_Rep_Id := Scenario_Rep_Id'First;
992 First_Scenario_Rep : constant Scenario_Rep_Id := No_Scenario_Rep + 1;
994 -- The following type identifies a target representation
996 type Target_Rep_Id is new Natural;
998 No_Target_Rep : constant Target_Rep_Id := Target_Rep_Id'First;
999 First_Target_Rep : constant Target_Rep_Id := No_Target_Rep + 1;
1005 -- The following package keeps track of all active scenarios during a DFS
1008 package Active_Scenarios is
1014 -- The following type defines the position within the active scenario
1017 type Active_Scenario_Pos is new Natural;
1019 ---------------------
1020 -- Data structures --
1021 ---------------------
1023 -- The following table stores all active scenarios in a DFS traversal.
1024 -- This table must be maintained in a FIFO fashion.
1026 package Active_Scenario_Stack is new Table.Table
1027 (Table_Index_Type => Active_Scenario_Pos,
1028 Table_Component_Type => Node_Id,
1029 Table_Low_Bound => 1,
1030 Table_Initial => 50,
1031 Table_Increment => 200,
1032 Table_Name => "Active_Scenario_Stack");
1038 procedure Output_Active_Scenarios
1039 (Error_Nod : Node_Id;
1040 In_State : Processing_In_State);
1041 pragma Inline (Output_Active_Scenarios);
1042 -- Output the contents of the active scenario stack from earliest to
1043 -- latest to supplement an earlier error emitted for node Error_Nod.
1044 -- In_State denotes the current state of the Processing phase.
1046 procedure Pop_Active_Scenario (N : Node_Id);
1047 pragma Inline (Pop_Active_Scenario);
1048 -- Pop the top of the scenario stack. A check is made to ensure that the
1049 -- scenario being removed is the same as N.
1051 procedure Push_Active_Scenario (N : Node_Id);
1052 pragma Inline (Push_Active_Scenario);
1053 -- Push scenario N on top of the scenario stack
1055 function Root_Scenario return Node_Id;
1056 pragma Inline (Root_Scenario);
1057 -- Return the scenario which started a DFS traversal
1059 end Active_Scenarios;
1060 use Active_Scenarios;
1062 -- The following package provides the main entry point for task activation
1065 package Activation_Processor is
1071 type Activation_Processor_Ptr is access procedure
1073 Call_Rep : Scenario_Rep_Id;
1075 Obj_Rep : Target_Rep_Id;
1076 Task_Typ : Entity_Id;
1077 Task_Rep : Target_Rep_Id;
1078 In_State : Processing_In_State);
1079 -- Reference to a procedure that takes all attributes of an activation
1080 -- and performs a desired action. Call is the activation call. Call_Rep
1081 -- is the representation of the call. Obj_Id is the task object being
1082 -- activated. Obj_Rep is the representation of the object. Task_Typ is
1083 -- the task type whose body is being activated. Task_Rep denotes the
1084 -- representation of the task type. In_State is the current state of
1085 -- the Processing phase.
1091 procedure Process_Activation
1093 Call_Rep : Scenario_Rep_Id;
1094 Processor : Activation_Processor_Ptr;
1095 In_State : Processing_In_State);
1096 -- Find all task objects activated by activation call Call and invoke
1097 -- Processor on them. Call_Rep denotes the representation of the call.
1098 -- In_State is the current state of the Processing phase.
1100 end Activation_Processor;
1101 use Activation_Processor;
1103 -- The following package profides functionality for traversing subprogram
1104 -- bodies in DFS manner and processing of eligible scenarios within.
1106 package Body_Processor is
1112 type Scenario_Predicate_Ptr is access function
1113 (N : Node_Id) return Boolean;
1114 -- Reference to a function which determines whether arbitrary node N
1115 -- denotes a suitable scenario for processing.
1117 type Scenario_Processor_Ptr is access procedure
1118 (N : Node_Id; In_State : Processing_In_State);
1119 -- Reference to a procedure which processes scenario N. In_State is the
1120 -- current state of the Processing phase.
1126 procedure Traverse_Body
1128 Requires_Processing : Scenario_Predicate_Ptr;
1129 Processor : Scenario_Processor_Ptr;
1130 In_State : Processing_In_State);
1131 pragma Inline (Traverse_Body);
1132 -- Traverse the declarations and handled statements of subprogram body
1133 -- N, looking for scenarios that satisfy predicate Requires_Processing.
1134 -- Routine Processor is invoked for each such scenario.
1136 procedure Reset_Traversed_Bodies;
1137 pragma Inline (Reset_Traversed_Bodies);
1138 -- Reset the visited status of all subprogram bodies that have already
1139 -- been processed by routine Traverse_Body.
1145 procedure Finalize_Body_Processor;
1146 pragma Inline (Finalize_Body_Processor);
1147 -- Finalize all internal data structures
1149 procedure Initialize_Body_Processor;
1150 pragma Inline (Initialize_Body_Processor);
1151 -- Initialize all internal data structures
1156 -- The following package provides functionality for installing ABE-related
1157 -- checks and failures.
1159 package Check_Installer is
1165 function Check_Or_Failure_Generation_OK return Boolean;
1166 pragma Inline (Check_Or_Failure_Generation_OK);
1167 -- Determine whether a conditional ABE check or guaranteed ABE failure
1168 -- can be generated.
1170 procedure Install_Dynamic_ABE_Checks;
1171 pragma Inline (Install_Dynamic_ABE_Checks);
1172 -- Install conditional ABE checks for all saved scenarios when the
1173 -- dynamic model is in effect.
1175 procedure Install_Scenario_ABE_Check
1177 Targ_Id : Entity_Id;
1178 Targ_Rep : Target_Rep_Id;
1179 Disable : Scenario_Rep_Id);
1180 pragma Inline (Install_Scenario_ABE_Check);
1181 -- Install a conditional ABE check for scenario N to ensure that target
1182 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
1183 -- target. If the check is installed, disable the elaboration checks of
1184 -- scenario Disable.
1186 procedure Install_Scenario_ABE_Check
1188 Targ_Id : Entity_Id;
1189 Targ_Rep : Target_Rep_Id;
1190 Disable : Target_Rep_Id);
1191 pragma Inline (Install_Scenario_ABE_Check);
1192 -- Install a conditional ABE check for scenario N to ensure that target
1193 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
1194 -- target. If the check is installed, disable the elaboration checks of
1197 procedure Install_Scenario_ABE_Failure
1199 Targ_Id : Entity_Id;
1200 Targ_Rep : Target_Rep_Id;
1201 Disable : Scenario_Rep_Id);
1202 pragma Inline (Install_Scenario_ABE_Failure);
1203 -- Install a guaranteed ABE failure for scenario N with target Targ_Id.
1204 -- Targ_Rep denotes the representation of the target. If the failure is
1205 -- installed, disable the elaboration checks of scenario Disable.
1207 procedure Install_Scenario_ABE_Failure
1209 Targ_Id : Entity_Id;
1210 Targ_Rep : Target_Rep_Id;
1211 Disable : Target_Rep_Id);
1212 pragma Inline (Install_Scenario_ABE_Failure);
1213 -- Install a guaranteed ABE failure for scenario N with target Targ_Id.
1214 -- Targ_Rep denotes the representation of the target. If the failure is
1215 -- installed, disable the elaboration checks of target Disable.
1217 procedure Install_Unit_ABE_Check
1219 Unit_Id : Entity_Id;
1220 Disable : Scenario_Rep_Id);
1221 pragma Inline (Install_Unit_ABE_Check);
1222 -- Install a conditional ABE check for scenario N to ensure that unit
1223 -- Unit_Id is properly elaborated. If the check is installed, disable
1224 -- the elaboration checks of scenario Disable.
1226 procedure Install_Unit_ABE_Check
1228 Unit_Id : Entity_Id;
1229 Disable : Target_Rep_Id);
1230 pragma Inline (Install_Unit_ABE_Check);
1231 -- Install a conditional ABE check for scenario N to ensure that unit
1232 -- Unit_Id is properly elaborated. If the check is installed, disable
1233 -- the elaboration checks of target Disable.
1235 end Check_Installer;
1236 use Check_Installer;
1238 -- The following package provides the main entry point for conditional ABE
1239 -- checks and diagnostics.
1241 package Conditional_ABE_Processor is
1247 procedure Check_Conditional_ABE_Scenarios
1248 (Iter : in out NE_Set.Iterator);
1249 pragma Inline (Check_Conditional_ABE_Scenarios);
1250 -- Perform conditional ABE checks and diagnostics for all scenarios
1251 -- available through iterator Iter.
1253 procedure Process_Conditional_ABE
1255 In_State : Processing_In_State);
1256 pragma Inline (Process_Conditional_ABE);
1257 -- Perform conditional ABE checks and diagnostics for scenario N.
1258 -- In_State denotes the current state of the Processing phase.
1260 end Conditional_ABE_Processor;
1261 use Conditional_ABE_Processor;
1263 -- The following package provides functionality to emit errors, information
1264 -- messages, and warnings.
1266 package Diagnostics is
1272 procedure Elab_Msg_NE
1277 In_SPARK : Boolean);
1278 pragma Inline (Elab_Msg_NE);
1279 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary
1280 -- node N and entity. If flag Info_Msg is set, the routine emits an
1281 -- information message, otherwise it emits an error. If flag In_SPARK
1282 -- is set, then string " in SPARK" is added to the end of the message.
1286 Subp_Id : Entity_Id;
1288 In_SPARK : Boolean);
1289 pragma Inline (Info_Call);
1290 -- Output information concerning call Call that invokes subprogram
1291 -- Subp_Id. When flag Info_Msg is set, the routine emits an information
1292 -- message, otherwise it emits an error. When flag In_SPARK is set, " in
1293 -- SPARK" is added to the end of the message.
1295 procedure Info_Instantiation
1299 In_SPARK : Boolean);
1300 pragma Inline (Info_Instantiation);
1301 -- Output information concerning instantiation Inst which instantiates
1302 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an
1303 -- information message, otherwise it emits an error. If flag In_SPARK
1304 -- is set, then string " in SPARK" is added to the end of the message.
1306 procedure Info_Variable_Reference
1310 In_SPARK : Boolean);
1311 pragma Inline (Info_Variable_Reference);
1312 -- Output information concerning reference Ref which mentions variable
1313 -- Var_Id. If flag Info_Msg is set, the routine emits an information
1314 -- message, otherwise it emits an error. If flag In_SPARK is set, then
1315 -- string " in SPARK" is added to the end of the message.
1320 -- The following package provides functionality to locate the early call
1321 -- region of a subprogram body.
1323 package Early_Call_Region_Processor is
1329 function Find_Early_Call_Region
1330 (Body_Decl : Node_Id;
1331 Assume_Elab_Body : Boolean := False;
1332 Skip_Memoization : Boolean := False) return Node_Id;
1333 pragma Inline (Find_Early_Call_Region);
1334 -- Find the start of the early call region that belongs to subprogram
1335 -- body Body_Decl as defined in SPARK RM 7.7. This routine finds the
1336 -- early call region, memoizes it, and returns it, but this behavior
1337 -- can be altered. Flag Assume_Elab_Body should be set when a package
1338 -- spec may lack pragma Elaborate_Body, but the routine must still
1339 -- examine that spec. Flag Skip_Memoization should be set when the
1340 -- routine must avoid memoizing the region.
1346 procedure Finalize_Early_Call_Region_Processor;
1347 pragma Inline (Finalize_Early_Call_Region_Processor);
1348 -- Finalize all internal data structures
1350 procedure Initialize_Early_Call_Region_Processor;
1351 pragma Inline (Initialize_Early_Call_Region_Processor);
1352 -- Initialize all internal data structures
1354 end Early_Call_Region_Processor;
1355 use Early_Call_Region_Processor;
1357 -- The following package provides access to the elaboration statuses of all
1358 -- units withed by the main unit.
1360 package Elaborated_Units is
1366 procedure Collect_Elaborated_Units;
1367 pragma Inline (Collect_Elaborated_Units);
1368 -- Save the elaboration statuses of all units withed by the main unit
1370 procedure Ensure_Prior_Elaboration
1372 Unit_Id : Entity_Id;
1374 In_State : Processing_In_State);
1375 pragma Inline (Ensure_Prior_Elaboration);
1376 -- Guarantee the elaboration of unit Unit_Id with respect to the main
1377 -- unit by either suggesting or installing an Elaborate[_All] pragma
1378 -- denoted by Prag_Nam. N denotes the related scenario. In_State is the
1379 -- current state of the Processing phase.
1381 function Has_Prior_Elaboration
1382 (Unit_Id : Entity_Id;
1383 Context_OK : Boolean := False;
1384 Elab_Body_OK : Boolean := False;
1385 Same_Unit_OK : Boolean := False) return Boolean;
1386 pragma Inline (Has_Prior_Elaboration);
1387 -- Determine whether unit Unit_Id is elaborated prior to the main unit.
1388 -- If flag Context_OK is set, the routine considers the following case
1389 -- as valid prior elaboration:
1391 -- * Unit_Id is in the elaboration context of the main unit
1393 -- If flag Elab_Body_OK is set, the routine considers the following case
1394 -- as valid prior elaboration:
1396 -- * Unit_Id has pragma Elaborate_Body and is not the main unit
1398 -- If flag Same_Unit_OK is set, the routine considers the following
1399 -- cases as valid prior elaboration:
1401 -- * Unit_Id is the main unit
1403 -- * Unit_Id denotes the spec of the main unit body
1405 procedure Meet_Elaboration_Requirement
1407 Targ_Id : Entity_Id;
1409 In_State : Processing_In_State);
1410 pragma Inline (Meet_Elaboration_Requirement);
1411 -- Determine whether elaboration requirement Req_Nam for scenario N with
1412 -- target Targ_Id is met by the context of the main unit using the SPARK
1413 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an
1414 -- error if this is not the case. In_State denotes the current state of
1415 -- the Processing phase.
1421 procedure Finalize_Elaborated_Units;
1422 pragma Inline (Finalize_Elaborated_Units);
1423 -- Finalize all internal data structures
1425 procedure Initialize_Elaborated_Units;
1426 pragma Inline (Initialize_Elaborated_Units);
1427 -- Initialize all internal data structures
1429 end Elaborated_Units;
1430 use Elaborated_Units;
1432 -- The following package provides the main entry point for guaranteed ABE
1433 -- checks and diagnostics.
1435 package Guaranteed_ABE_Processor is
1441 procedure Process_Guaranteed_ABE
1443 In_State : Processing_In_State);
1444 pragma Inline (Process_Guaranteed_ABE);
1445 -- Perform guaranteed ABE checks and diagnostics for scenario N.
1446 -- In_State is the current state of the Processing phase.
1448 end Guaranteed_ABE_Processor;
1449 use Guaranteed_ABE_Processor;
1451 -- The following package provides access to the internal representation of
1452 -- scenarios and targets.
1454 package Internal_Representation is
1460 -- The following type enumerates all possible Ghost mode mode kinds
1462 type Extended_Ghost_Mode is
1464 Is_Checked_Or_Not_Specified);
1466 -- The following type enumerates all possible SPARK mode kinds
1468 type Extended_SPARK_Mode is
1470 Is_Off_Or_Not_Specified);
1476 function Scenario_Representation_Of
1478 In_State : Processing_In_State) return Scenario_Rep_Id;
1479 pragma Inline (Scenario_Representation_Of);
1480 -- Obtain the id of elaboration scenario N's representation. The routine
1481 -- constructs the representation if it is not available. In_State is the
1482 -- current state of the Processing phase.
1484 function Target_Representation_Of
1486 In_State : Processing_In_State) return Target_Rep_Id;
1487 pragma Inline (Target_Representation_Of);
1488 -- Obtain the id of elaboration target Id's representation. The routine
1489 -- constructs the representation if it is not available. In_State is the
1490 -- current state of the Processing phase.
1492 -------------------------
1493 -- Scenario attributes --
1494 -------------------------
1496 function Activated_Task_Objects
1497 (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List;
1498 pragma Inline (Activated_Task_Objects);
1499 -- For Task_Activation_Scenario S_Id, obtain the list of task objects
1500 -- the scenario is activating.
1502 function Activated_Task_Type (S_Id : Scenario_Rep_Id) return Entity_Id;
1503 pragma Inline (Activated_Task_Type);
1504 -- For Task_Activation_Scenario S_Id, obtain the currently activated
1507 procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id);
1508 pragma Inline (Disable_Elaboration_Checks);
1509 -- Disable elaboration checks of scenario S_Id
1511 function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean;
1512 pragma Inline (Elaboration_Checks_OK);
1513 -- Determine whether scenario S_Id may be subjected to elaboration
1516 function Elaboration_Warnings_OK (S_Id : Scenario_Rep_Id) return Boolean;
1517 pragma Inline (Elaboration_Warnings_OK);
1518 -- Determine whether scenario S_Id may be subjected to elaboration
1521 function Ghost_Mode_Of
1522 (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode;
1523 pragma Inline (Ghost_Mode_Of);
1524 -- Obtain the Ghost mode of scenario S_Id
1526 function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean;
1527 pragma Inline (Is_Dispatching_Call);
1528 -- For Call_Scenario S_Id, determine whether the call is dispatching
1530 function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean;
1531 pragma Inline (Is_Read_Reference);
1532 -- For Variable_Reference_Scenario S_Id, determine whether the reference
1535 function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind;
1536 pragma Inline (Kind);
1537 -- Obtain the nature of scenario S_Id
1539 function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind;
1540 pragma Inline (Level);
1541 -- Obtain the enclosing level of scenario S_Id
1543 procedure Set_Activated_Task_Objects
1544 (S_Id : Scenario_Rep_Id;
1545 Task_Objs : NE_List.Doubly_Linked_List);
1546 pragma Inline (Set_Activated_Task_Objects);
1547 -- For Task_Activation_Scenario S_Id, set the list of task objects
1548 -- activated by the scenario to Task_Objs.
1550 procedure Set_Activated_Task_Type
1551 (S_Id : Scenario_Rep_Id;
1552 Task_Typ : Entity_Id);
1553 pragma Inline (Set_Activated_Task_Type);
1554 -- For Task_Activation_Scenario S_Id, set the currently activated task
1555 -- type to Task_Typ.
1557 function SPARK_Mode_Of
1558 (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode;
1559 pragma Inline (SPARK_Mode_Of);
1560 -- Obtain the SPARK mode of scenario S_Id
1562 function Target (S_Id : Scenario_Rep_Id) return Entity_Id;
1563 pragma Inline (Target);
1564 -- Obtain the target of scenario S_Id
1566 -----------------------
1567 -- Target attributes --
1568 -----------------------
1570 function Barrier_Body_Declaration (T_Id : Target_Rep_Id) return Node_Id;
1571 pragma Inline (Barrier_Body_Declaration);
1572 -- For Subprogram_Target T_Id, obtain the declaration of the barrier
1575 function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id;
1576 pragma Inline (Body_Declaration);
1577 -- Obtain the declaration of the body which belongs to target T_Id
1579 procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id);
1580 pragma Inline (Disable_Elaboration_Checks);
1581 -- Disable elaboration checks of target T_Id
1583 function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean;
1584 pragma Inline (Elaboration_Checks_OK);
1585 -- Determine whether target T_Id may be subjected to elaboration checks
1587 function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean;
1588 pragma Inline (Elaboration_Warnings_OK);
1589 -- Determine whether target T_Id may be subjected to elaboration
1592 function Ghost_Mode_Of (T_Id : Target_Rep_Id) return Extended_Ghost_Mode;
1593 pragma Inline (Ghost_Mode_Of);
1594 -- Obtain the Ghost mode of target T_Id
1596 function Kind (T_Id : Target_Rep_Id) return Target_Kind;
1597 pragma Inline (Kind);
1598 -- Obtain the nature of target T_Id
1600 function SPARK_Mode_Of (T_Id : Target_Rep_Id) return Extended_SPARK_Mode;
1601 pragma Inline (SPARK_Mode_Of);
1602 -- Obtain the SPARK mode of target T_Id
1604 function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id;
1605 pragma Inline (Spec_Declaration);
1606 -- Obtain the declaration of the spec which belongs to target T_Id
1608 function Unit (T_Id : Target_Rep_Id) return Entity_Id;
1609 pragma Inline (Unit);
1610 -- Obtain the unit where the target is defined
1612 function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id;
1613 pragma Inline (Variable_Declaration);
1614 -- For Variable_Target T_Id, obtain the declaration of the variable
1620 procedure Finalize_Internal_Representation;
1621 pragma Inline (Finalize_Internal_Representation);
1622 -- Finalize all internal data structures
1624 procedure Initialize_Internal_Representation;
1625 pragma Inline (Initialize_Internal_Representation);
1626 -- Initialize all internal data structures
1628 end Internal_Representation;
1629 use Internal_Representation;
1631 -- The following package provides functionality for recording pieces of the
1632 -- invocation graph in the ALI file of the main unit.
1634 package Invocation_Graph is
1640 procedure Record_Invocation_Graph;
1641 pragma Inline (Record_Invocation_Graph);
1642 -- Process all declaration, instantiation, and library level scenarios,
1643 -- along with invocation construct within the spec and body of the main
1644 -- unit to determine whether any of these reach into an external unit.
1645 -- If such a path exists, encode in the ALI file of the main unit.
1651 procedure Finalize_Invocation_Graph;
1652 pragma Inline (Finalize_Invocation_Graph);
1653 -- Finalize all internal data structures
1655 procedure Initialize_Invocation_Graph;
1656 pragma Inline (Initialize_Invocation_Graph);
1657 -- Initialize all internal data structures
1659 end Invocation_Graph;
1660 use Invocation_Graph;
1662 -- The following package stores scenarios
1664 package Scenario_Storage is
1670 procedure Add_Declaration_Scenario (N : Node_Id);
1671 pragma Inline (Add_Declaration_Scenario);
1672 -- Save declaration level scenario N
1674 procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id);
1675 pragma Inline (Add_Dynamic_ABE_Check_Scenario);
1676 -- Save scenario N for conditional ABE check installation purposes when
1677 -- the dynamic model is in effect.
1679 procedure Add_Library_Body_Scenario (N : Node_Id);
1680 pragma Inline (Add_Library_Body_Scenario);
1681 -- Save library-level body scenario N
1683 procedure Add_Library_Spec_Scenario (N : Node_Id);
1684 pragma Inline (Add_Library_Spec_Scenario);
1685 -- Save library-level spec scenario N
1687 procedure Add_SPARK_Scenario (N : Node_Id);
1688 pragma Inline (Add_SPARK_Scenario);
1689 -- Save SPARK scenario N
1691 procedure Delete_Scenario (N : Node_Id);
1692 pragma Inline (Delete_Scenario);
1693 -- Delete arbitrary scenario N
1695 function Iterate_Declaration_Scenarios return NE_Set.Iterator;
1696 pragma Inline (Iterate_Declaration_Scenarios);
1697 -- Obtain an iterator over all declaration level scenarios
1699 function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator;
1700 pragma Inline (Iterate_Dynamic_ABE_Check_Scenarios);
1701 -- Obtain an iterator over all scenarios that require a conditional ABE
1702 -- check when the dynamic model is in effect.
1704 function Iterate_Library_Body_Scenarios return NE_Set.Iterator;
1705 pragma Inline (Iterate_Library_Body_Scenarios);
1706 -- Obtain an iterator over all library level body scenarios
1708 function Iterate_Library_Spec_Scenarios return NE_Set.Iterator;
1709 pragma Inline (Iterate_Library_Spec_Scenarios);
1710 -- Obtain an iterator over all library level spec scenarios
1712 function Iterate_SPARK_Scenarios return NE_Set.Iterator;
1713 pragma Inline (Iterate_SPARK_Scenarios);
1714 -- Obtain an iterator over all SPARK scenarios
1716 procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id);
1717 pragma Inline (Replace_Scenario);
1718 -- Replace scenario Old_N with scenario New_N
1724 procedure Finalize_Scenario_Storage;
1725 pragma Inline (Finalize_Scenario_Storage);
1726 -- Finalize all internal data structures
1728 procedure Initialize_Scenario_Storage;
1729 pragma Inline (Initialize_Scenario_Storage);
1730 -- Initialize all internal data structures
1732 end Scenario_Storage;
1733 use Scenario_Storage;
1735 -- The following package provides various semantic predicates
1737 package Semantics is
1743 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean;
1744 pragma Inline (Is_Accept_Alternative_Proc);
1745 -- Determine whether arbitrary entity Id denotes an internally generated
1746 -- procedure which encapsulates the statements of an accept alternative.
1748 function Is_Activation_Proc (Id : Entity_Id) return Boolean;
1749 pragma Inline (Is_Activation_Proc);
1750 -- Determine whether arbitrary entity Id denotes a runtime procedure in
1751 -- charge with activating tasks.
1753 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean;
1754 pragma Inline (Is_Ada_Semantic_Target);
1755 -- Determine whether arbitrary entity Id denodes a source or internally
1756 -- generated subprogram which emulates Ada semantics.
1758 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean;
1759 pragma Inline (Is_Assertion_Pragma_Target);
1760 -- Determine whether arbitrary entity Id denotes a procedure which
1761 -- varifies the run-time semantics of an assertion pragma.
1763 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean;
1764 pragma Inline (Is_Bodiless_Subprogram);
1765 -- Determine whether subprogram Subp_Id will never have a body
1767 function Is_Bridge_Target (Id : Entity_Id) return Boolean;
1768 pragma Inline (Is_Bridge_Target);
1769 -- Determine whether arbitrary entity Id denotes a bridge target
1771 function Is_Controlled_Proc
1772 (Subp_Id : Entity_Id;
1773 Subp_Nam : Name_Id) return Boolean;
1774 pragma Inline (Is_Controlled_Proc);
1775 -- Determine whether subprogram Subp_Id denotes controlled type
1776 -- primitives Adjust, Finalize, or Initialize as denoted by name
1779 function Is_Default_Initial_Condition_Proc
1780 (Id : Entity_Id) return Boolean;
1781 pragma Inline (Is_Default_Initial_Condition_Proc);
1782 -- Determine whether arbitrary entity Id denotes internally generated
1783 -- routine Default_Initial_Condition.
1785 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean;
1786 pragma Inline (Is_Finalizer_Proc);
1787 -- Determine whether arbitrary entity Id denotes internally generated
1788 -- routine _Finalizer.
1790 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean;
1791 pragma Inline (Is_Initial_Condition_Proc);
1792 -- Determine whether arbitrary entity Id denotes internally generated
1793 -- routine Initial_Condition.
1795 function Is_Initialized (Obj_Decl : Node_Id) return Boolean;
1796 pragma Inline (Is_Initialized);
1797 -- Determine whether object declaration Obj_Decl is initialized
1799 function Is_Invariant_Proc (Id : Entity_Id) return Boolean;
1800 pragma Inline (Is_Invariant_Proc);
1801 -- Determine whether arbitrary entity Id denotes an invariant procedure
1803 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean;
1804 pragma Inline (Is_Non_Library_Level_Encapsulator);
1805 -- Determine whether arbitrary node N is a non-library encapsulator
1807 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean;
1808 pragma Inline (Is_Partial_Invariant_Proc);
1809 -- Determine whether arbitrary entity Id denotes a partial invariant
1812 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean;
1813 pragma Inline (Is_Postconditions_Proc);
1814 -- Determine whether arbitrary entity Id denotes internally generated
1815 -- routine _Postconditions.
1817 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean;
1818 pragma Inline (Is_Preelaborated_Unit);
1819 -- Determine whether arbitrary entity Id denotes a unit which is subject
1820 -- to one of the following pragmas:
1824 -- * Remote_Call_Interface
1828 function Is_Protected_Entry (Id : Entity_Id) return Boolean;
1829 pragma Inline (Is_Protected_Entry);
1830 -- Determine whether arbitrary entity Id denotes a protected entry
1832 function Is_Protected_Subp (Id : Entity_Id) return Boolean;
1833 pragma Inline (Is_Protected_Subp);
1834 -- Determine whether entity Id denotes a protected subprogram
1836 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean;
1837 pragma Inline (Is_Protected_Body_Subp);
1838 -- Determine whether entity Id denotes the protected or unprotected
1839 -- version of a protected subprogram.
1841 function Is_Scenario (N : Node_Id) return Boolean;
1842 pragma Inline (Is_Scenario);
1843 -- Determine whether attribute node N denotes a scenario. The scenario
1844 -- may not necessarily be eligible for ABE processing.
1846 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean;
1847 pragma Inline (Is_SPARK_Semantic_Target);
1848 -- Determine whether arbitrary entity Id nodes a source or internally
1849 -- generated subprogram which emulates SPARK semantics.
1851 function Is_Subprogram_Inst (Id : Entity_Id) return Boolean;
1852 pragma Inline (Is_Subprogram_Inst);
1853 -- Determine whether arbitrary entity Id denotes a subprogram instance
1855 function Is_Suitable_Access_Taken (N : Node_Id) return Boolean;
1856 pragma Inline (Is_Suitable_Access_Taken);
1857 -- Determine whether arbitrary node N denotes a suitable attribute for
1860 function Is_Suitable_Call (N : Node_Id) return Boolean;
1861 pragma Inline (Is_Suitable_Call);
1862 -- Determine whether arbitrary node N denotes a suitable call for ABE
1865 function Is_Suitable_Instantiation (N : Node_Id) return Boolean;
1866 pragma Inline (Is_Suitable_Instantiation);
1867 -- Determine whether arbitrary node N is a suitable instantiation for
1870 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean;
1871 pragma Inline (Is_Suitable_SPARK_Derived_Type);
1872 -- Determine whether arbitrary node N denotes a suitable derived type
1873 -- declaration for ABE processing using the SPARK rules.
1875 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean;
1876 pragma Inline (Is_Suitable_SPARK_Instantiation);
1877 -- Determine whether arbitrary node N denotes a suitable instantiation
1878 -- for ABE processing using the SPARK rules.
1880 function Is_Suitable_SPARK_Refined_State_Pragma
1881 (N : Node_Id) return Boolean;
1882 pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma);
1883 -- Determine whether arbitrary node N denotes a suitable Refined_State
1884 -- pragma for ABE processing using the SPARK rules.
1886 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean;
1887 pragma Inline (Is_Suitable_Variable_Assignment);
1888 -- Determine whether arbitrary node N denotes a suitable assignment for
1891 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean;
1892 pragma Inline (Is_Suitable_Variable_Reference);
1893 -- Determine whether arbitrary node N is a suitable variable reference
1894 -- for ABE processing.
1896 function Is_Task_Entry (Id : Entity_Id) return Boolean;
1897 pragma Inline (Is_Task_Entry);
1898 -- Determine whether arbitrary entity Id denotes a task entry
1900 function Is_Up_Level_Target
1901 (Targ_Decl : Node_Id;
1902 In_State : Processing_In_State) return Boolean;
1903 pragma Inline (Is_Up_Level_Target);
1904 -- Determine whether the current root resides at the declaration level.
1905 -- If this is the case, determine whether a target with by declaration
1906 -- Target_Decl is within a context which encloses the current root or is
1907 -- in a different unit. In_State is the current state of the Processing
1913 -- The following package provides the main entry point for SPARK-related
1914 -- checks and diagnostics.
1916 package SPARK_Processor is
1922 procedure Check_SPARK_Model_In_Effect;
1923 pragma Inline (Check_SPARK_Model_In_Effect);
1924 -- Determine whether a suitable elaboration model is currently in effect
1925 -- for verifying SPARK rules. Emit a warning if this is not the case.
1927 procedure Check_SPARK_Scenarios;
1928 pragma Inline (Check_SPARK_Scenarios);
1929 -- Examine SPARK scenarios which are not necessarily executable during
1930 -- elaboration, but still requires elaboration-related checks.
1932 end SPARK_Processor;
1933 use SPARK_Processor;
1935 -----------------------
1936 -- Local subprograms --
1937 -----------------------
1939 function Assignment_Target (Asmt : Node_Id) return Node_Id;
1940 pragma Inline (Assignment_Target);
1941 -- Obtain the target of assignment statement Asmt
1943 function Call_Name (Call : Node_Id) return Node_Id;
1944 pragma Inline (Call_Name);
1945 -- Obtain the name of an entry, operator, or subprogram call Call
1947 function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id;
1948 pragma Inline (Canonical_Subprogram);
1949 -- Obtain the uniform canonical entity of subprogram Subp_Id
1951 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id;
1952 pragma Inline (Compilation_Unit);
1953 -- Return the N_Compilation_Unit node of unit Unit_Id
1955 function Find_Enclosing_Instance (N : Node_Id) return Node_Id;
1956 pragma Inline (Find_Enclosing_Instance);
1957 -- Find the declaration or body of the nearest expanded instance which
1958 -- encloses arbitrary node N. Return Empty if no such instance exists.
1960 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id;
1961 pragma Inline (Find_Top_Unit);
1962 -- Return the top unit which contains arbitrary node or entity N. The unit
1963 -- is obtained by logically unwinding instantiations and subunits when N
1964 -- resides within one.
1966 function Find_Unit_Entity (N : Node_Id) return Entity_Id;
1967 pragma Inline (Find_Unit_Entity);
1968 -- Return the entity of unit N
1970 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id;
1971 pragma Inline (First_Formal_Type);
1972 -- Return the type of subprogram Subp_Id's first formal parameter. If the
1973 -- subprogram lacks formal parameters, return Empty.
1975 function Elaboration_Phase_Active return Boolean;
1976 pragma Inline (Elaboration_Phase_Active);
1977 -- Determine whether the elaboration phase of the compilation has started
1979 procedure Finalize_All_Data_Structures;
1980 pragma Inline (Finalize_All_Data_Structures);
1981 -- Destroy all internal data structures
1983 function Has_Body (Pack_Decl : Node_Id) return Boolean;
1984 pragma Inline (Has_Body);
1985 -- Determine whether package declaration Pack_Decl has a corresponding body
1986 -- or would eventually have one.
1988 function In_External_Instance
1990 Target_Decl : Node_Id) return Boolean;
1991 pragma Inline (In_External_Instance);
1992 -- Determine whether a target desctibed by its declaration Target_Decl
1993 -- resides in a package instance which is external to scenario N.
1995 function In_Main_Context (N : Node_Id) return Boolean;
1996 pragma Inline (In_Main_Context);
1997 -- Determine whether arbitrary node N appears within the main compilation
2000 function In_Same_Context
2003 Nested_OK : Boolean := False) return Boolean;
2004 pragma Inline (In_Same_Context);
2005 -- Determine whether two arbitrary nodes N1 and N2 appear within the same
2006 -- context ignoring enclosing library levels. Nested_OK should be set when
2007 -- the context of N1 can enclose that of N2.
2009 procedure Initialize_All_Data_Structures;
2010 pragma Inline (Initialize_All_Data_Structures);
2011 -- Create all internal data structures
2013 function Instantiated_Generic (Inst : Node_Id) return Entity_Id;
2014 pragma Inline (Instantiated_Generic);
2015 -- Obtain the generic instantiated by instance Inst
2017 function Is_Safe_Activation
2019 Task_Rep : Target_Rep_Id) return Boolean;
2020 pragma Inline (Is_Safe_Activation);
2021 -- Determine whether activation call Call which activates an object of a
2022 -- task type described by representation Task_Rep is always ABE-safe.
2024 function Is_Safe_Call
2026 Subp_Id : Entity_Id;
2027 Subp_Rep : Target_Rep_Id) return Boolean;
2028 pragma Inline (Is_Safe_Call);
2029 -- Determine whether call Call which invokes entry, operator, or subprogram
2030 -- Subp_Id is always ABE-safe. Subp_Rep is the representation of the entry,
2031 -- operator, or subprogram.
2033 function Is_Safe_Instantiation
2036 Gen_Rep : Target_Rep_Id) return Boolean;
2037 pragma Inline (Is_Safe_Instantiation);
2038 -- Determine whether instantiation Inst which instantiates generic Gen_Id
2039 -- is always ABE-safe. Gen_Rep is the representation of the generic.
2041 function Is_Same_Unit
2042 (Unit_1 : Entity_Id;
2043 Unit_2 : Entity_Id) return Boolean;
2044 pragma Inline (Is_Same_Unit);
2045 -- Determine whether entities Unit_1 and Unit_2 denote the same unit
2047 function Main_Unit_Entity return Entity_Id;
2048 pragma Inline (Main_Unit_Entity);
2049 -- Return the entity of the main unit
2051 function Non_Private_View (Typ : Entity_Id) return Entity_Id;
2052 pragma Inline (Non_Private_View);
2053 -- Return the full view of private type Typ if available, otherwise return
2056 function Scenario (N : Node_Id) return Node_Id;
2057 pragma Inline (Scenario);
2058 -- Return the appropriate scenario node for scenario N
2060 procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status);
2061 pragma Inline (Set_Elaboration_Phase);
2062 -- Change the status of the elaboration phase of the compiler to Status
2064 procedure Spec_And_Body_From_Entity
2066 Spec_Decl : out Node_Id;
2067 Body_Decl : out Node_Id);
2068 pragma Inline (Spec_And_Body_From_Entity);
2069 -- Given arbitrary entity Id representing a construct with a spec and body,
2070 -- retrieve declaration of the spec in Spec_Decl and the declaration of the
2071 -- body in Body_Decl.
2073 procedure Spec_And_Body_From_Node
2075 Spec_Decl : out Node_Id;
2076 Body_Decl : out Node_Id);
2077 pragma Inline (Spec_And_Body_From_Node);
2078 -- Given arbitrary node N representing a construct with a spec and body,
2079 -- retrieve declaration of the spec in Spec_Decl and the declaration of
2080 -- the body in Body_Decl.
2082 function Static_Elaboration_Checks return Boolean;
2083 pragma Inline (Static_Elaboration_Checks);
2084 -- Determine whether the static model is in effect
2086 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id;
2087 pragma Inline (Unit_Entity);
2088 -- Return the entity of the initial declaration for unit Unit_Id
2090 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id);
2091 pragma Inline (Update_Elaboration_Scenario);
2092 -- Update all relevant internal data structures when scenario Old_N is
2093 -- transformed into scenario New_N by Atree.Rewrite.
2095 ----------------------
2096 -- Active_Scenarios --
2097 ----------------------
2099 package body Active_Scenarios is
2101 -----------------------
2102 -- Local subprograms --
2103 -----------------------
2105 procedure Output_Access_Taken
2107 Attr_Rep : Scenario_Rep_Id;
2108 Error_Nod : Node_Id);
2109 pragma Inline (Output_Access_Taken);
2110 -- Emit a specific diagnostic message for 'Access attribute reference
2111 -- Attr with representation Attr_Rep. The message is associated with
2114 procedure Output_Active_Scenario
2116 Error_Nod : Node_Id;
2117 In_State : Processing_In_State);
2118 pragma Inline (Output_Active_Scenario);
2119 -- Top level dispatcher for outputting a scenario. Emit a specific
2120 -- diagnostic message for scenario N. The message is associated with
2121 -- node Error_Nod. In_State is the current state of the Processing
2124 procedure Output_Call
2126 Call_Rep : Scenario_Rep_Id;
2127 Error_Nod : Node_Id);
2128 pragma Inline (Output_Call);
2129 -- Emit a diagnostic message for call Call with representation Call_Rep.
2130 -- The message is associated with node Error_Nod.
2132 procedure Output_Header (Error_Nod : Node_Id);
2133 pragma Inline (Output_Header);
2134 -- Emit a specific diagnostic message for the unit of the root scenario.
2135 -- The message is associated with node Error_Nod.
2137 procedure Output_Instantiation
2139 Inst_Rep : Scenario_Rep_Id;
2140 Error_Nod : Node_Id);
2141 pragma Inline (Output_Instantiation);
2142 -- Emit a specific diagnostic message for instantiation Inst with
2143 -- representation Inst_Rep. The message is associated with node
2146 procedure Output_Refined_State_Pragma
2148 Prag_Rep : Scenario_Rep_Id;
2149 Error_Nod : Node_Id);
2150 pragma Inline (Output_Refined_State_Pragma);
2151 -- Emit a specific diagnostic message for Refined_State pragma Prag
2152 -- with representation Prag_Rep. The message is associated with node
2155 procedure Output_Task_Activation
2157 Call_Rep : Scenario_Rep_Id;
2158 Error_Nod : Node_Id);
2159 pragma Inline (Output_Task_Activation);
2160 -- Emit a specific diagnostic message for activation call Call
2161 -- with representation Call_Rep. The message is associated with
2164 procedure Output_Variable_Assignment
2166 Asmt_Rep : Scenario_Rep_Id;
2167 Error_Nod : Node_Id);
2168 pragma Inline (Output_Variable_Assignment);
2169 -- Emit a specific diagnostic message for assignment statement Asmt
2170 -- with representation Asmt_Rep. The message is associated with node
2173 procedure Output_Variable_Reference
2175 Ref_Rep : Scenario_Rep_Id;
2176 Error_Nod : Node_Id);
2177 pragma Inline (Output_Variable_Reference);
2178 -- Emit a specific diagnostic message for read reference Ref with
2179 -- representation Ref_Rep. The message is associated with node
2186 procedure Output_Access_Taken
2188 Attr_Rep : Scenario_Rep_Id;
2189 Error_Nod : Node_Id)
2191 Subp_Id : constant Entity_Id := Target (Attr_Rep);
2194 Error_Msg_Name_1 := Attribute_Name (Attr);
2195 Error_Msg_Sloc := Sloc (Attr);
2196 Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id);
2197 end Output_Access_Taken;
2199 ----------------------------
2200 -- Output_Active_Scenario --
2201 ----------------------------
2203 procedure Output_Active_Scenario
2205 Error_Nod : Node_Id;
2206 In_State : Processing_In_State)
2208 Scen : constant Node_Id := Scenario (N);
2209 Scen_Rep : Scenario_Rep_Id;
2214 if Is_Suitable_Access_Taken (Scen) then
2217 Attr_Rep => Scenario_Representation_Of (Scen, In_State),
2218 Error_Nod => Error_Nod);
2220 -- Call or task activation
2222 elsif Is_Suitable_Call (Scen) then
2223 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
2225 if Kind (Scen_Rep) = Call_Scenario then
2228 Call_Rep => Scen_Rep,
2229 Error_Nod => Error_Nod);
2232 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario);
2234 Output_Task_Activation
2236 Call_Rep => Scen_Rep,
2237 Error_Nod => Error_Nod);
2242 elsif Is_Suitable_Instantiation (Scen) then
2243 Output_Instantiation
2245 Inst_Rep => Scenario_Representation_Of (Scen, In_State),
2246 Error_Nod => Error_Nod);
2248 -- Pragma Refined_State
2250 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then
2251 Output_Refined_State_Pragma
2253 Prag_Rep => Scenario_Representation_Of (Scen, In_State),
2254 Error_Nod => Error_Nod);
2256 -- Variable assignment
2258 elsif Is_Suitable_Variable_Assignment (Scen) then
2259 Output_Variable_Assignment
2261 Asmt_Rep => Scenario_Representation_Of (Scen, In_State),
2262 Error_Nod => Error_Nod);
2264 -- Variable reference
2266 elsif Is_Suitable_Variable_Reference (Scen) then
2267 Output_Variable_Reference
2269 Ref_Rep => Scenario_Representation_Of (Scen, In_State),
2270 Error_Nod => Error_Nod);
2272 end Output_Active_Scenario;
2274 -----------------------------
2275 -- Output_Active_Scenarios --
2276 -----------------------------
2278 procedure Output_Active_Scenarios
2279 (Error_Nod : Node_Id;
2280 In_State : Processing_In_State)
2282 package Scenarios renames Active_Scenario_Stack;
2284 Header_Posted : Boolean := False;
2287 -- Output the contents of the active scenario stack starting from the
2288 -- bottom, or the least recent scenario.
2290 for Index in Scenarios.First .. Scenarios.Last loop
2291 if not Header_Posted then
2292 Output_Header (Error_Nod);
2293 Header_Posted := True;
2296 Output_Active_Scenario
2297 (N => Scenarios.Table (Index),
2298 Error_Nod => Error_Nod,
2299 In_State => In_State);
2301 end Output_Active_Scenarios;
2307 procedure Output_Call
2309 Call_Rep : Scenario_Rep_Id;
2310 Error_Nod : Node_Id)
2312 procedure Output_Accept_Alternative (Alt_Id : Entity_Id);
2313 pragma Inline (Output_Accept_Alternative);
2314 -- Emit a specific diagnostic message concerning accept alternative
2315 -- with entity Alt_Id.
2317 procedure Output_Call (Subp_Id : Entity_Id; Kind : String);
2318 pragma Inline (Output_Call);
2319 -- Emit a specific diagnostic message concerning a call of kind Kind
2320 -- which invokes subprogram Subp_Id.
2322 procedure Output_Type_Actions (Subp_Id : Entity_Id; Action : String);
2323 pragma Inline (Output_Type_Actions);
2324 -- Emit a specific diagnostic message concerning action Action of a
2325 -- type performed by subprogram Subp_Id.
2327 procedure Output_Verification_Call
2331 pragma Inline (Output_Verification_Call);
2332 -- Emit a specific diagnostic message concerning the verification of
2333 -- predicate Pred applied to related entity Id with kind Id_Kind.
2335 -------------------------------
2336 -- Output_Accept_Alternative --
2337 -------------------------------
2339 procedure Output_Accept_Alternative (Alt_Id : Entity_Id) is
2340 Entry_Id : constant Entity_Id := Receiving_Entry (Alt_Id);
2343 pragma Assert (Present (Entry_Id));
2345 Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id);
2346 end Output_Accept_Alternative;
2352 procedure Output_Call (Subp_Id : Entity_Id; Kind : String) is
2354 Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Subp_Id);
2357 -------------------------
2358 -- Output_Type_Actions --
2359 -------------------------
2361 procedure Output_Type_Actions
2362 (Subp_Id : Entity_Id;
2365 Typ : constant Entity_Id := First_Formal_Type (Subp_Id);
2368 pragma Assert (Present (Typ));
2371 ("\\ " & Action & " actions for type & #", Error_Nod, Typ);
2372 end Output_Type_Actions;
2374 ------------------------------
2375 -- Output_Verification_Call --
2376 ------------------------------
2378 procedure Output_Verification_Call
2384 pragma Assert (Present (Id));
2387 ("\\ " & Pred & " of " & Id_Kind & " & verified #",
2389 end Output_Verification_Call;
2393 Subp_Id : constant Entity_Id := Target (Call_Rep);
2395 -- Start of processing for Output_Call
2398 Error_Msg_Sloc := Sloc (Call);
2400 -- Accept alternative
2402 if Is_Accept_Alternative_Proc (Subp_Id) then
2403 Output_Accept_Alternative (Subp_Id);
2407 elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then
2408 Output_Type_Actions (Subp_Id, "adjustment");
2410 -- Default_Initial_Condition
2412 elsif Is_Default_Initial_Condition_Proc (Subp_Id) then
2413 Output_Verification_Call
2414 (Pred => "Default_Initial_Condition",
2415 Id => First_Formal_Type (Subp_Id),
2420 elsif Is_Protected_Entry (Subp_Id) then
2421 Output_Call (Subp_Id, "entry");
2423 -- Task entry calls are never processed because the entry being
2424 -- invoked does not have a corresponding "body", it has a select. A
2425 -- task entry call appears in the stack of active scenarios for the
2426 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
2429 elsif Is_Task_Entry (Subp_Id) then
2434 elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then
2435 Output_Type_Actions (Subp_Id, "finalization");
2437 -- Calls to _Finalizer procedures must not appear in the output
2438 -- because this creates confusing noise.
2440 elsif Is_Finalizer_Proc (Subp_Id) then
2443 -- Initial_Condition
2445 elsif Is_Initial_Condition_Proc (Subp_Id) then
2446 Output_Verification_Call
2447 (Pred => "Initial_Condition",
2448 Id => Find_Enclosing_Scope (Call),
2449 Id_Kind => "package");
2453 elsif Is_Init_Proc (Subp_Id)
2454 or else Is_TSS (Subp_Id, TSS_Deep_Initialize)
2456 Output_Type_Actions (Subp_Id, "initialization");
2460 elsif Is_Invariant_Proc (Subp_Id) then
2461 Output_Verification_Call
2462 (Pred => "invariants",
2463 Id => First_Formal_Type (Subp_Id),
2466 -- Partial invariant calls must not appear in the output because this
2467 -- creates confusing noise. Note that a partial invariant is always
2468 -- invoked by the "full" invariant which is already placed on the
2471 elsif Is_Partial_Invariant_Proc (Subp_Id) then
2476 elsif Is_Postconditions_Proc (Subp_Id) then
2477 Output_Verification_Call
2478 (Pred => "postconditions",
2479 Id => Find_Enclosing_Scope (Call),
2480 Id_Kind => "subprogram");
2482 -- Subprograms must come last because some of the previous cases fall
2483 -- under this category.
2485 elsif Ekind (Subp_Id) = E_Function then
2486 Output_Call (Subp_Id, "function");
2488 elsif Ekind (Subp_Id) = E_Procedure then
2489 Output_Call (Subp_Id, "procedure");
2492 pragma Assert (False);
2501 procedure Output_Header (Error_Nod : Node_Id) is
2502 Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario);
2505 if Ekind (Unit_Id) = E_Package then
2506 Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id);
2508 elsif Ekind (Unit_Id) = E_Package_Body then
2509 Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id);
2512 Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id);
2516 --------------------------
2517 -- Output_Instantiation --
2518 --------------------------
2520 procedure Output_Instantiation
2522 Inst_Rep : Scenario_Rep_Id;
2523 Error_Nod : Node_Id)
2525 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String);
2526 pragma Inline (Output_Instantiation);
2527 -- Emit a specific diagnostic message concerning an instantiation of
2528 -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
2530 --------------------------
2531 -- Output_Instantiation --
2532 --------------------------
2534 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is
2537 ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id);
2538 end Output_Instantiation;
2542 Gen_Id : constant Entity_Id := Target (Inst_Rep);
2544 -- Start of processing for Output_Instantiation
2547 Error_Msg_Node_2 := Defining_Entity (Inst);
2548 Error_Msg_Sloc := Sloc (Inst);
2550 if Nkind (Inst) = N_Function_Instantiation then
2551 Output_Instantiation (Gen_Id, "function");
2553 elsif Nkind (Inst) = N_Package_Instantiation then
2554 Output_Instantiation (Gen_Id, "package");
2556 elsif Nkind (Inst) = N_Procedure_Instantiation then
2557 Output_Instantiation (Gen_Id, "procedure");
2560 pragma Assert (False);
2563 end Output_Instantiation;
2565 ---------------------------------
2566 -- Output_Refined_State_Pragma --
2567 ---------------------------------
2569 procedure Output_Refined_State_Pragma
2571 Prag_Rep : Scenario_Rep_Id;
2572 Error_Nod : Node_Id)
2574 pragma Unreferenced (Prag_Rep);
2577 Error_Msg_Sloc := Sloc (Prag);
2578 Error_Msg_N ("\\ refinement constituents read #", Error_Nod);
2579 end Output_Refined_State_Pragma;
2581 ----------------------------
2582 -- Output_Task_Activation --
2583 ----------------------------
2585 procedure Output_Task_Activation
2587 Call_Rep : Scenario_Rep_Id;
2588 Error_Nod : Node_Id)
2590 pragma Unreferenced (Call_Rep);
2592 function Find_Activator return Entity_Id;
2593 -- Find the nearest enclosing construct which houses call Call
2595 --------------------
2596 -- Find_Activator --
2597 --------------------
2599 function Find_Activator return Entity_Id is
2603 -- Climb the parent chain looking for a package [body] or a
2604 -- construct with a statement sequence.
2606 Par := Parent (Call);
2607 while Present (Par) loop
2608 if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then
2609 return Defining_Entity (Par);
2611 elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then
2612 return Defining_Entity (Parent (Par));
2615 Par := Parent (Par);
2623 Activator : constant Entity_Id := Find_Activator;
2625 -- Start of processing for Output_Task_Activation
2628 pragma Assert (Present (Activator));
2630 Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator);
2631 end Output_Task_Activation;
2633 --------------------------------
2634 -- Output_Variable_Assignment --
2635 --------------------------------
2637 procedure Output_Variable_Assignment
2639 Asmt_Rep : Scenario_Rep_Id;
2640 Error_Nod : Node_Id)
2642 Var_Id : constant Entity_Id := Target (Asmt_Rep);
2645 Error_Msg_Sloc := Sloc (Asmt);
2646 Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id);
2647 end Output_Variable_Assignment;
2649 -------------------------------
2650 -- Output_Variable_Reference --
2651 -------------------------------
2653 procedure Output_Variable_Reference
2655 Ref_Rep : Scenario_Rep_Id;
2656 Error_Nod : Node_Id)
2658 Var_Id : constant Entity_Id := Target (Ref_Rep);
2661 Error_Msg_Sloc := Sloc (Ref);
2662 Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id);
2663 end Output_Variable_Reference;
2665 -------------------------
2666 -- Pop_Active_Scenario --
2667 -------------------------
2669 procedure Pop_Active_Scenario (N : Node_Id) is
2670 package Scenarios renames Active_Scenario_Stack;
2671 Top : Node_Id renames Scenarios.Table (Scenarios.Last);
2674 pragma Assert (Top = N);
2675 Scenarios.Decrement_Last;
2676 end Pop_Active_Scenario;
2678 --------------------------
2679 -- Push_Active_Scenario --
2680 --------------------------
2682 procedure Push_Active_Scenario (N : Node_Id) is
2684 Active_Scenario_Stack.Append (N);
2685 end Push_Active_Scenario;
2691 function Root_Scenario return Node_Id is
2692 package Scenarios renames Active_Scenario_Stack;
2695 -- Ensure that the scenario stack has at least one active scenario in
2696 -- it. The one at the bottom (index First) is the root scenario.
2698 pragma Assert (Scenarios.Last >= Scenarios.First);
2699 return Scenarios.Table (Scenarios.First);
2701 end Active_Scenarios;
2703 --------------------------
2704 -- Activation_Processor --
2705 --------------------------
2707 package body Activation_Processor is
2709 ------------------------
2710 -- Process_Activation --
2711 ------------------------
2713 procedure Process_Activation
2715 Call_Rep : Scenario_Rep_Id;
2716 Processor : Activation_Processor_Ptr;
2717 In_State : Processing_In_State)
2719 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id);
2720 pragma Inline (Process_Task_Object);
2721 -- Invoke Processor for task object Obj_Id of type Typ
2723 procedure Process_Task_Objects
2724 (Task_Objs : NE_List.Doubly_Linked_List);
2725 pragma Inline (Process_Task_Objects);
2726 -- Invoke Processor for all task objects found in list Task_Objs
2728 procedure Traverse_List
2730 Task_Objs : NE_List.Doubly_Linked_List);
2731 pragma Inline (Traverse_List);
2732 -- Traverse declarative or statement list List while searching for
2733 -- objects of a task type, or containing task components. If such an
2734 -- object is found, first save it in list Task_Objs and then invoke
2737 -------------------------
2738 -- Process_Task_Object --
2739 -------------------------
2741 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is
2742 Root_Typ : constant Entity_Id :=
2743 Non_Private_View (Root_Type (Typ));
2744 Comp_Id : Entity_Id;
2745 Obj_Rep : Target_Rep_Id;
2746 Root_Rep : Target_Rep_Id;
2748 New_In_State : Processing_In_State := In_State;
2749 -- Each step of the Processing phase constitutes a new state
2752 if Is_Task_Type (Typ) then
2753 Obj_Rep := Target_Representation_Of (Obj_Id, New_In_State);
2754 Root_Rep := Target_Representation_Of (Root_Typ, New_In_State);
2756 -- Warnings are suppressed when a prior scenario is already in
2757 -- that mode, or when the object, activation call, or task type
2758 -- have warnings suppressed. Update the state of the Processing
2759 -- phase to reflect this.
2761 New_In_State.Suppress_Warnings :=
2762 New_In_State.Suppress_Warnings
2763 or else not Elaboration_Warnings_OK (Call_Rep)
2764 or else not Elaboration_Warnings_OK (Obj_Rep)
2765 or else not Elaboration_Warnings_OK (Root_Rep);
2767 -- Update the state of the Processing phase to indicate that
2768 -- any further traversal is now within a task body.
2770 New_In_State.Within_Task_Body := True;
2772 -- Associate the current task type with the activation call
2774 Set_Activated_Task_Type (Call_Rep, Root_Typ);
2776 -- Process the activation of the current task object by calling
2777 -- the supplied processor.
2781 Call_Rep => Call_Rep,
2784 Task_Typ => Root_Typ,
2785 Task_Rep => Root_Rep,
2786 In_State => New_In_State);
2788 -- Reset the association between the current task and the
2791 Set_Activated_Task_Type (Call_Rep, Empty);
2793 -- Examine the component type when the object is an array
2795 elsif Is_Array_Type (Typ) and then Has_Task (Root_Typ) then
2798 Typ => Component_Type (Typ));
2800 -- Examine individual component types when the object is a record
2802 elsif Is_Record_Type (Typ) and then Has_Task (Root_Typ) then
2803 Comp_Id := First_Component (Typ);
2804 while Present (Comp_Id) loop
2807 Typ => Etype (Comp_Id));
2809 Next_Component (Comp_Id);
2812 end Process_Task_Object;
2814 --------------------------
2815 -- Process_Task_Objects --
2816 --------------------------
2818 procedure Process_Task_Objects
2819 (Task_Objs : NE_List.Doubly_Linked_List)
2821 Iter : NE_List.Iterator;
2825 Iter := NE_List.Iterate (Task_Objs);
2826 while NE_List.Has_Next (Iter) loop
2827 NE_List.Next (Iter, Obj_Id);
2831 Typ => Etype (Obj_Id));
2833 end Process_Task_Objects;
2839 procedure Traverse_List
2841 Task_Objs : NE_List.Doubly_Linked_List)
2844 Item_Id : Entity_Id;
2845 Item_Typ : Entity_Id;
2848 -- Examine the contents of the list looking for an object
2849 -- declaration of a task type or one that contains a task
2852 Item := First (List);
2853 while Present (Item) loop
2854 if Nkind (Item) = N_Object_Declaration then
2855 Item_Id := Defining_Entity (Item);
2856 Item_Typ := Etype (Item_Id);
2858 if Has_Task (Item_Typ) then
2860 -- The object is either of a task type, or contains a
2861 -- task component. Save it in the list of task objects
2862 -- associated with the activation call.
2864 NE_List.Append (Task_Objs, Item_Id);
2880 Task_Objs : NE_List.Doubly_Linked_List;
2882 -- Start of processing for Process_Activation
2885 -- Nothing to do when the activation is a guaranteed ABE
2887 if Is_Known_Guaranteed_ABE (Call) then
2891 Task_Objs := Activated_Task_Objects (Call_Rep);
2893 -- The activation call has been processed at least once, and all
2894 -- task objects have already been collected. Directly process the
2895 -- objects without having to reexamine the context of the call.
2897 if NE_List.Present (Task_Objs) then
2898 Process_Task_Objects (Task_Objs);
2900 -- Otherwise the activation call is being processed for the first
2901 -- time. Collect all task objects in case the call is reprocessed
2905 Task_Objs := NE_List.Create;
2906 Set_Activated_Task_Objects (Call_Rep, Task_Objs);
2908 -- Find the context of the activation call where all task objects
2909 -- being activated are declared. This is usually the parent of the
2912 Context := Parent (Call);
2914 -- Handle the case where the activation call appears within the
2915 -- handled statements of a block or a body.
2917 if Nkind (Context) = N_Handled_Sequence_Of_Statements then
2918 Context := Parent (Context);
2921 -- Process all task objects in both the spec and body when the
2922 -- activation call appears in a package body.
2924 if Nkind (Context) = N_Package_Body then
2927 (Unit_Declaration_Node (Corresponding_Spec (Context)));
2930 (List => Visible_Declarations (Spec),
2931 Task_Objs => Task_Objs);
2934 (List => Private_Declarations (Spec),
2935 Task_Objs => Task_Objs);
2938 (List => Declarations (Context),
2939 Task_Objs => Task_Objs);
2941 -- Process all task objects in the spec when the activation call
2942 -- appears in a package spec.
2944 elsif Nkind (Context) = N_Package_Specification then
2946 (List => Visible_Declarations (Context),
2947 Task_Objs => Task_Objs);
2950 (List => Private_Declarations (Context),
2951 Task_Objs => Task_Objs);
2953 -- Otherwise the context must be a block or a body. Process all
2954 -- task objects found in the declarations.
2957 pragma Assert (Nkind_In (Context, N_Block_Statement,
2964 (List => Declarations (Context),
2965 Task_Objs => Task_Objs);
2968 end Process_Activation;
2969 end Activation_Processor;
2971 -----------------------
2972 -- Assignment_Target --
2973 -----------------------
2975 function Assignment_Target (Asmt : Node_Id) return Node_Id is
2981 -- When the name denotes an array or record component, find the whole
2984 while Nkind_In (Nam, N_Explicit_Dereference,
2985 N_Indexed_Component,
2986 N_Selected_Component,
2989 Nam := Prefix (Nam);
2993 end Assignment_Target;
2995 --------------------
2996 -- Body_Processor --
2997 --------------------
2999 package body Body_Processor is
3001 ---------------------
3002 -- Data structures --
3003 ---------------------
3005 -- The following map relates scenario lists to subprogram bodies
3007 Nested_Scenarios_Map : NE_List_Map.Dynamic_Hash_Table := NE_List_Map.Nil;
3009 -- The following set contains all subprogram bodies that have been
3010 -- processed by routine Traverse_Body.
3012 Traversed_Bodies_Set : NE_Set.Membership_Set := NE_Set.Nil;
3014 -----------------------
3015 -- Local subprograms --
3016 -----------------------
3018 function Is_Traversed_Body (N : Node_Id) return Boolean;
3019 pragma Inline (Is_Traversed_Body);
3020 -- Determine whether subprogram body N has already been traversed
3022 function Nested_Scenarios
3023 (N : Node_Id) return NE_List.Doubly_Linked_List;
3024 pragma Inline (Nested_Scenarios);
3025 -- Obtain the list of scenarios associated with subprogram body N
3027 procedure Set_Is_Traversed_Body
3029 Val : Boolean := True);
3030 pragma Inline (Set_Is_Traversed_Body);
3031 -- Mark subprogram body N as traversed depending on value Val
3033 procedure Set_Nested_Scenarios
3035 Scenarios : NE_List.Doubly_Linked_List);
3036 pragma Inline (Set_Nested_Scenarios);
3037 -- Associate scenario list Scenarios with subprogram body N
3039 -----------------------------
3040 -- Finalize_Body_Processor --
3041 -----------------------------
3043 procedure Finalize_Body_Processor is
3045 NE_List_Map.Destroy (Nested_Scenarios_Map);
3046 NE_Set.Destroy (Traversed_Bodies_Set);
3047 end Finalize_Body_Processor;
3049 -------------------------------
3050 -- Initialize_Body_Processor --
3051 -------------------------------
3053 procedure Initialize_Body_Processor is
3055 Nested_Scenarios_Map := NE_List_Map.Create (250);
3056 Traversed_Bodies_Set := NE_Set.Create (250);
3057 end Initialize_Body_Processor;
3059 -----------------------
3060 -- Is_Traversed_Body --
3061 -----------------------
3063 function Is_Traversed_Body (N : Node_Id) return Boolean is
3064 pragma Assert (Present (N));
3066 return NE_Set.Contains (Traversed_Bodies_Set, N);
3067 end Is_Traversed_Body;
3069 ----------------------
3070 -- Nested_Scenarios --
3071 ----------------------
3073 function Nested_Scenarios
3074 (N : Node_Id) return NE_List.Doubly_Linked_List
3076 pragma Assert (Present (N));
3077 pragma Assert (Nkind (N) = N_Subprogram_Body);
3080 return NE_List_Map.Get (Nested_Scenarios_Map, N);
3081 end Nested_Scenarios;
3083 ----------------------------
3084 -- Reset_Traversed_Bodies --
3085 ----------------------------
3087 procedure Reset_Traversed_Bodies is
3089 NE_Set.Reset (Traversed_Bodies_Set);
3090 end Reset_Traversed_Bodies;
3092 ---------------------------
3093 -- Set_Is_Traversed_Body --
3094 ---------------------------
3096 procedure Set_Is_Traversed_Body
3098 Val : Boolean := True)
3100 pragma Assert (Present (N));
3104 NE_Set.Insert (Traversed_Bodies_Set, N);
3106 NE_Set.Delete (Traversed_Bodies_Set, N);
3108 end Set_Is_Traversed_Body;
3110 --------------------------
3111 -- Set_Nested_Scenarios --
3112 --------------------------
3114 procedure Set_Nested_Scenarios
3116 Scenarios : NE_List.Doubly_Linked_List)
3118 pragma Assert (Present (N));
3120 NE_List_Map.Put (Nested_Scenarios_Map, N, Scenarios);
3121 end Set_Nested_Scenarios;
3127 procedure Traverse_Body
3129 Requires_Processing : Scenario_Predicate_Ptr;
3130 Processor : Scenario_Processor_Ptr;
3131 In_State : Processing_In_State)
3133 Scenarios : NE_List.Doubly_Linked_List := NE_List.Nil;
3134 -- The list of scenarios that appear within the declarations and
3135 -- statement of subprogram body N. The variable is intentionally
3136 -- global because Is_Potential_Scenario needs to populate it.
3138 function In_Task_Body (Nod : Node_Id) return Boolean;
3139 pragma Inline (In_Task_Body);
3140 -- Determine whether arbitrary node Nod appears within a task body
3142 function Is_Synchronous_Suspension_Call
3143 (Nod : Node_Id) return Boolean;
3144 pragma Inline (Is_Synchronous_Suspension_Call);
3145 -- Determine whether arbitrary node Nod denotes a call to one of
3148 -- Ada.Synchronous_Barriers.Wait_For_Release
3149 -- Ada.Synchronous_Task_Control.Suspend_Until_True
3151 procedure Traverse_Collected_Scenarios;
3152 pragma Inline (Traverse_Collected_Scenarios);
3153 -- Traverse the already collected scenarios in list Scenarios by
3154 -- invoking Processor on each individual one.
3156 procedure Traverse_List (List : List_Id);
3157 pragma Inline (Traverse_List);
3158 -- Invoke Traverse_Potential_Scenarios on each node in list List
3160 function Traverse_Potential_Scenario
3161 (Scen : Node_Id) return Traverse_Result;
3162 pragma Inline (Traverse_Potential_Scenario);
3163 -- Determine whether arbitrary node Scen is a suitable scenario using
3164 -- predicate Is_Scenario and traverse it by invoking Processor on it.
3166 procedure Traverse_Potential_Scenarios is
3167 new Traverse_Proc (Traverse_Potential_Scenario);
3173 function In_Task_Body (Nod : Node_Id) return Boolean is
3177 -- Climb the parent chain looking for a task body [procedure]
3180 while Present (Par) loop
3181 if Nkind (Par) = N_Task_Body then
3184 elsif Nkind (Par) = N_Subprogram_Body
3185 and then Is_Task_Body_Procedure (Par)
3189 -- Prevent the search from going too far. Note that this test
3190 -- shares nodes with the two cases above, and must come last.
3192 elsif Is_Body_Or_Package_Declaration (Par) then
3196 Par := Parent (Par);
3202 ------------------------------------
3203 -- Is_Synchronous_Suspension_Call --
3204 ------------------------------------
3206 function Is_Synchronous_Suspension_Call
3207 (Nod : Node_Id) return Boolean
3209 Subp_Id : Entity_Id;
3212 -- To qualify, the call must invoke one of the runtime routines
3213 -- which perform synchronous suspension.
3215 if Is_Suitable_Call (Nod) then
3216 Subp_Id := Target (Nod);
3219 Is_RTE (Subp_Id, RE_Suspend_Until_True)
3221 Is_RTE (Subp_Id, RE_Wait_For_Release);
3225 end Is_Synchronous_Suspension_Call;
3227 ----------------------------------
3228 -- Traverse_Collected_Scenarios --
3229 ----------------------------------
3231 procedure Traverse_Collected_Scenarios is
3232 Iter : NE_List.Iterator;
3236 Iter := NE_List.Iterate (Scenarios);
3237 while NE_List.Has_Next (Iter) loop
3238 NE_List.Next (Iter, Scen);
3240 -- The current scenario satisfies the input predicate, process
3243 if Requires_Processing.all (Scen) then
3244 Processor.all (Scen, In_State);
3247 end Traverse_Collected_Scenarios;
3253 procedure Traverse_List (List : List_Id) is
3257 Scen := First (List);
3258 while Present (Scen) loop
3259 Traverse_Potential_Scenarios (Scen);
3264 ---------------------------------
3265 -- Traverse_Potential_Scenario --
3266 ---------------------------------
3268 function Traverse_Potential_Scenario
3269 (Scen : Node_Id) return Traverse_Result
3274 -- Skip constructs which do not have elaboration of their own and
3275 -- need to be elaborated by other means such as invocation, task
3278 if Is_Non_Library_Level_Encapsulator (Scen) then
3281 -- Terminate the traversal of a task body when encountering an
3282 -- accept or select statement, and
3284 -- * Entry calls during elaboration are not allowed. In this
3285 -- case the accept or select statement will cause the task
3286 -- to block at elaboration time because there are no entry
3287 -- calls to unblock it.
3291 -- * Switch -gnatd_a (stop elaboration checks on accept or
3292 -- select statement) is in effect.
3294 elsif (Debug_Flag_Underscore_A
3295 or else Restriction_Active
3296 (No_Entry_Calls_In_Elaboration_Code))
3297 and then Nkind_In (Original_Node (Scen), N_Accept_Statement,
3302 -- Terminate the traversal of a task body when encountering a
3303 -- suspension call, and
3305 -- * Entry calls during elaboration are not allowed. In this
3306 -- case the suspension call emulates an entry call and will
3307 -- cause the task to block at elaboration time.
3311 -- * Switch -gnatd_s (stop elaboration checks on synchronous
3312 -- suspension) is in effect.
3314 -- Note that the guard should not be checking the state of flag
3315 -- Within_Task_Body because only suspension calls which appear
3316 -- immediately within the statements of the task are supported.
3317 -- Flag Within_Task_Body carries over to deeper levels of the
3320 elsif (Debug_Flag_Underscore_S
3321 or else Restriction_Active
3322 (No_Entry_Calls_In_Elaboration_Code))
3323 and then Is_Synchronous_Suspension_Call (Scen)
3324 and then In_Task_Body (Scen)
3328 -- Certain nodes carry semantic lists which act as repositories
3329 -- until expansion transforms the node and relocates the contents.
3330 -- Examine these lists in case expansion is disabled.
3332 elsif Nkind_In (Scen, N_And_Then, N_Or_Else) then
3333 Traverse_List (Actions (Scen));
3335 elsif Nkind_In (Scen, N_Elsif_Part, N_Iteration_Scheme) then
3336 Traverse_List (Condition_Actions (Scen));
3338 elsif Nkind (Scen) = N_If_Expression then
3339 Traverse_List (Then_Actions (Scen));
3340 Traverse_List (Else_Actions (Scen));
3342 elsif Nkind_In (Scen, N_Component_Association,
3343 N_Iterated_Component_Association)
3345 Traverse_List (Loop_Actions (Scen));
3349 -- The current node satisfies the input predicate, process it
3351 elsif Requires_Processing.all (Scen) then
3352 Processor.all (Scen, In_State);
3355 -- Save a general scenario regardless of whether it satisfies the
3356 -- input predicate. This allows for quick subsequent traversals of
3357 -- general scenarios, even with different predicates.
3359 if Is_Suitable_Access_Taken (Scen)
3360 or else Is_Suitable_Call (Scen)
3361 or else Is_Suitable_Instantiation (Scen)
3362 or else Is_Suitable_Variable_Assignment (Scen)
3363 or else Is_Suitable_Variable_Reference (Scen)
3365 NE_List.Append (Scenarios, Scen);
3369 end Traverse_Potential_Scenario;
3371 -- Start of processing for Traverse_Body
3374 -- Nothing to do when the traversal is suppressed
3376 if In_State.Traversal = No_Traversal then
3379 -- Nothing to do when there is no input
3384 -- Nothing to do when the input is not a subprogram body
3386 elsif Nkind (N) /= N_Subprogram_Body then
3389 -- Nothing to do if the subprogram body was already traversed
3391 elsif Is_Traversed_Body (N) then
3395 -- Mark the subprogram body as traversed
3397 Set_Is_Traversed_Body (N);
3399 Scenarios := Nested_Scenarios (N);
3401 -- The subprogram body has been traversed at least once, and all
3402 -- scenarios that appear within its declarations and statements
3403 -- have already been collected. Directly retraverse the scenarios
3404 -- without having to retraverse the subprogram body subtree.
3406 if NE_List.Present (Scenarios) then
3407 Traverse_Collected_Scenarios;
3409 -- Otherwise the subprogram body is being traversed for the first
3410 -- time. Collect all scenarios that appear within its declarations
3411 -- and statements in case the subprogram body has to be retraversed
3415 Scenarios := NE_List.Create;
3416 Set_Nested_Scenarios (N, Scenarios);
3418 Traverse_List (Declarations (N));
3419 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N));
3424 -----------------------
3425 -- Build_Call_Marker --
3426 -----------------------
3428 procedure Build_Call_Marker (N : Node_Id) is
3429 function In_External_Context
3431 Subp_Id : Entity_Id) return Boolean;
3432 pragma Inline (In_External_Context);
3433 -- Determine whether entry, operator, or subprogram Subp_Id is external
3434 -- to call Call which must reside within an instance.
3436 function In_Premature_Context (Call : Node_Id) return Boolean;
3437 pragma Inline (In_Premature_Context);
3438 -- Determine whether call Call appears within a premature context
3440 function Is_Default_Expression (Call : Node_Id) return Boolean;
3441 pragma Inline (Is_Default_Expression);
3442 -- Determine whether call Call acts as the expression of a defaulted
3443 -- parameter within a source call.
3445 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean;
3446 pragma Inline (Is_Generic_Formal_Subp);
3447 -- Determine whether subprogram Subp_Id denotes a generic formal
3448 -- subprogram which appears in the "prologue" of an instantiation.
3450 -------------------------
3451 -- In_External_Context --
3452 -------------------------
3454 function In_External_Context
3456 Subp_Id : Entity_Id) return Boolean
3458 Spec_Decl : constant Entity_Id := Unit_Declaration_Node (Subp_Id);
3461 Inst_Body : Node_Id;
3462 Inst_Spec : Node_Id;
3465 Inst := Find_Enclosing_Instance (Call);
3467 -- The call appears within an instance
3469 if Present (Inst) then
3471 -- The call comes from the main unit and the target does not
3473 if In_Extended_Main_Code_Unit (Call)
3474 and then not In_Extended_Main_Code_Unit (Spec_Decl)
3478 -- Otherwise the target declaration must not appear within the
3479 -- instance spec or body.
3482 Spec_And_Body_From_Node
3484 Spec_Decl => Inst_Spec,
3485 Body_Decl => Inst_Body);
3487 return not In_Subtree
3490 Root2 => Inst_Body);
3495 end In_External_Context;
3497 --------------------------
3498 -- In_Premature_Context --
3499 --------------------------
3501 function In_Premature_Context (Call : Node_Id) return Boolean is
3505 -- Climb the parent chain looking for premature contexts
3507 Par := Parent (Call);
3508 while Present (Par) loop
3510 -- Aspect specifications and generic associations are premature
3511 -- contexts because nested calls has not been relocated to their
3514 if Nkind_In (Par, N_Aspect_Specification,
3515 N_Generic_Association)
3519 -- Prevent the search from going too far
3521 elsif Is_Body_Or_Package_Declaration (Par) then
3525 Par := Parent (Par);
3529 end In_Premature_Context;
3531 ---------------------------
3532 -- Is_Default_Expression --
3533 ---------------------------
3535 function Is_Default_Expression (Call : Node_Id) return Boolean is
3536 Outer_Call : constant Node_Id := Parent (Call);
3537 Outer_Nam : Node_Id;
3540 -- To qualify, the node must appear immediately within a source call
3541 -- which invokes a source target.
3543 if Nkind_In (Outer_Call, N_Entry_Call_Statement,
3545 N_Procedure_Call_Statement)
3546 and then Comes_From_Source (Outer_Call)
3548 Outer_Nam := Call_Name (Outer_Call);
3551 Is_Entity_Name (Outer_Nam)
3552 and then Present (Entity (Outer_Nam))
3553 and then Is_Subprogram_Or_Entry (Entity (Outer_Nam))
3554 and then Comes_From_Source (Entity (Outer_Nam));
3558 end Is_Default_Expression;
3560 ----------------------------
3561 -- Is_Generic_Formal_Subp --
3562 ----------------------------
3564 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is
3565 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
3566 Context : constant Node_Id := Parent (Subp_Decl);
3569 -- To qualify, the subprogram must rename a generic actual subprogram
3570 -- where the enclosing context is an instantiation.
3573 Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
3574 and then not Comes_From_Source (Subp_Decl)
3575 and then Nkind_In (Context, N_Function_Specification,
3576 N_Package_Specification,
3577 N_Procedure_Specification)
3578 and then Present (Generic_Parent (Context));
3579 end Is_Generic_Formal_Subp;
3585 Subp_Id : Entity_Id;
3587 -- Start of processing for Build_Call_Marker
3590 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
3591 -- enabled) is in effect because the legacy ABE mechanism does not need
3592 -- to carry out this action.
3594 if Legacy_Elaboration_Checks then
3597 -- Nothing to do for ASIS because ABE checks and diagnostics are not
3598 -- performed in this mode.
3600 elsif ASIS_Mode then
3603 -- Nothing to do when the call is being preanalyzed as the marker will
3604 -- be inserted in the wrong place.
3606 elsif Preanalysis_Active then
3609 -- Nothing to do when the elaboration phase of the compiler is not
3612 elsif not Elaboration_Phase_Active then
3615 -- Nothing to do when the input does not denote a call or a requeue
3617 elsif not Nkind_In (N, N_Entry_Call_Statement,
3619 N_Procedure_Call_Statement,
3620 N_Requeue_Statement)
3624 -- Nothing to do when the input denotes entry call or requeue statement,
3625 -- and switch -gnatd_e (ignore entry calls and requeue statements for
3626 -- elaboration) is in effect.
3628 elsif Debug_Flag_Underscore_E
3629 and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement)
3633 -- Nothing to do when the call is analyzed/resolved too early within an
3634 -- intermediate context. This check is saved for last because it incurs
3635 -- a performance penalty.
3637 elsif In_Premature_Context (N) then
3641 Call_Nam := Call_Name (N);
3643 -- Nothing to do when the call is erroneous or left in a bad state
3645 if not (Is_Entity_Name (Call_Nam)
3646 and then Present (Entity (Call_Nam))
3647 and then Is_Subprogram_Or_Entry (Entity (Call_Nam)))
3652 Subp_Id := Canonical_Subprogram (Entity (Call_Nam));
3654 -- Nothing to do when the call invokes a generic formal subprogram and
3655 -- switch -gnatd.G (ignore calls through generic formal parameters for
3656 -- elaboration) is in effect. This check must be performed with the
3657 -- direct target of the call to avoid the side effects of mapping
3658 -- actuals to formals using renamings.
3660 if Debug_Flag_Dot_GG
3661 and then Is_Generic_Formal_Subp (Entity (Call_Nam))
3665 -- Nothing to do when the call appears within the expanded spec or
3666 -- body of an instantiated generic, the call does not invoke a generic
3667 -- formal subprogram, the target is external to the instance, and switch
3668 -- -gnatdL (ignore external calls from instances for elaboration) is in
3669 -- effect. This check must be performed with the direct target of the
3670 -- call to avoid the side effects of mapping actuals to formals using
3674 and then not Is_Generic_Formal_Subp (Entity (Call_Nam))
3675 and then In_External_Context
3681 -- Nothing to do when the call invokes an assertion pragma procedure
3682 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is
3685 elsif Debug_Flag_Underscore_P
3686 and then Is_Assertion_Pragma_Target (Subp_Id)
3690 -- Source calls to source targets are always considered because they
3691 -- reflect the original call graph.
3693 elsif Comes_From_Source (N) and then Comes_From_Source (Subp_Id) then
3696 -- A call to a source function which acts as the default expression in
3697 -- another call requires special detection.
3699 elsif Comes_From_Source (Subp_Id)
3700 and then Nkind (N) = N_Function_Call
3701 and then Is_Default_Expression (N)
3705 -- The target emulates Ada semantics
3707 elsif Is_Ada_Semantic_Target (Subp_Id) then
3710 -- The target acts as a link between scenarios
3712 elsif Is_Bridge_Target (Subp_Id) then
3715 -- The target emulates SPARK semantics
3717 elsif Is_SPARK_Semantic_Target (Subp_Id) then
3720 -- Otherwise the call is not suitable for ABE processing. This prevents
3721 -- the generation of call markers which will never play a role in ABE
3728 -- At this point it is known that the call will play some role in ABE
3729 -- checks and diagnostics. Create a corresponding call marker in case
3730 -- the original call is heavily transformed by expansion later on.
3732 Marker := Make_Call_Marker (Sloc (N));
3734 -- Inherit the attributes of the original call
3736 Set_Is_Declaration_Level_Node
3737 (Marker, Find_Enclosing_Level (N) = Declaration_Level);
3739 Set_Is_Dispatching_Call
3740 (Marker, Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
3741 and then Present (Controlling_Argument (N)));
3743 Set_Is_Elaboration_Checks_OK_Node
3744 (Marker, Is_Elaboration_Checks_OK_Node (N));
3746 Set_Is_Elaboration_Warnings_OK_Node
3747 (Marker, Is_Elaboration_Warnings_OK_Node (N));
3749 Set_Is_Ignored_Ghost_Node (Marker, Is_Ignored_Ghost_Node (N));
3750 Set_Is_Source_Call (Marker, Comes_From_Source (N));
3751 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N));
3752 Set_Target (Marker, Subp_Id);
3754 -- The marker is inserted prior to the original call. This placement has
3755 -- several desirable effects:
3757 -- 1) The marker appears in the same context, in close proximity to
3763 -- 2) Inserting the marker prior to the call ensures that an ABE check
3764 -- will take effect prior to the call.
3770 -- 3) The above two properties are preserved even when the call is a
3771 -- function which is subsequently relocated in order to capture its
3772 -- result. Note that if the call is relocated to a new context, the
3773 -- relocated call will receive a marker of its own.
3777 -- Temp : ... := Func_Call ...;
3780 -- The insertion must take place even when the call does not occur in
3781 -- the main unit to keep the tree symmetric. This ensures that internal
3782 -- name serialization is consistent in case the call marker causes the
3783 -- tree to transform in some way.
3785 Insert_Action (N, Marker);
3787 -- The marker becomes the "corresponding" scenario for the call. Save
3788 -- the marker for later processing by the ABE phase.
3790 Record_Elaboration_Scenario (Marker);
3791 end Build_Call_Marker;
3793 -------------------------------------
3794 -- Build_Variable_Reference_Marker --
3795 -------------------------------------
3797 procedure Build_Variable_Reference_Marker
3802 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id;
3803 pragma Inline (Ultimate_Variable);
3804 -- Obtain the ultimate renamed variable of variable Var_Id
3806 -----------------------
3807 -- Ultimate_Variable --
3808 -----------------------
3810 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id is
3815 while Present (Renamed_Entity (Ren_Id))
3816 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity
3818 Ren_Id := Renamed_Entity (Ren_Id);
3822 end Ultimate_Variable;
3826 Var_Id : constant Entity_Id := Ultimate_Variable (Entity (N));
3829 -- Start of processing for Build_Variable_Reference_Marker
3832 -- Nothing to do when the elaboration phase of the compiler is not
3835 if not Elaboration_Phase_Active then
3839 Marker := Make_Variable_Reference_Marker (Sloc (N));
3841 -- Inherit the attributes of the original variable reference
3843 Set_Is_Elaboration_Checks_OK_Node
3844 (Marker, Is_Elaboration_Checks_OK_Node (N));
3846 Set_Is_Elaboration_Warnings_OK_Node
3847 (Marker, Is_Elaboration_Warnings_OK_Node (N));
3849 Set_Is_Read (Marker, Read);
3850 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N));
3851 Set_Is_Write (Marker, Write);
3852 Set_Target (Marker, Var_Id);
3854 -- The marker is inserted prior to the original variable reference. The
3855 -- insertion must take place even when the reference does not occur in
3856 -- the main unit to keep the tree symmetric. This ensures that internal
3857 -- name serialization is consistent in case the variable marker causes
3858 -- the tree to transform in some way.
3860 Insert_Action (N, Marker);
3862 -- The marker becomes the "corresponding" scenario for the reference.
3863 -- Save the marker for later processing for the ABE phase.
3865 Record_Elaboration_Scenario (Marker);
3866 end Build_Variable_Reference_Marker;
3872 function Call_Name (Call : Node_Id) return Node_Id is
3878 -- When the call invokes an entry family, the name appears as an indexed
3881 if Nkind (Nam) = N_Indexed_Component then
3882 Nam := Prefix (Nam);
3885 -- When the call employs the object.operation form, the name appears as
3886 -- a selected component.
3888 if Nkind (Nam) = N_Selected_Component then
3889 Nam := Selector_Name (Nam);
3895 --------------------------
3896 -- Canonical_Subprogram --
3897 --------------------------
3899 function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id is
3900 Canon_Id : Entity_Id;
3903 Canon_Id := Subp_Id;
3905 -- Use the original protected subprogram when dealing with one of the
3906 -- specialized lock-manipulating versions.
3908 if Is_Protected_Body_Subp (Canon_Id) then
3909 Canon_Id := Protected_Subprogram (Canon_Id);
3912 -- Obtain the original subprogram except when the subprogram is also
3913 -- an instantiation. In this case the alias is the internally generated
3914 -- subprogram which appears within the anonymous package created for the
3915 -- instantiation, making it unuitable.
3917 if not Is_Generic_Instance (Canon_Id) then
3918 Canon_Id := Get_Renamed_Entity (Canon_Id);
3922 end Canonical_Subprogram;
3924 ---------------------------------
3925 -- Check_Elaboration_Scenarios --
3926 ---------------------------------
3928 procedure Check_Elaboration_Scenarios is
3929 Iter : NE_Set.Iterator;
3932 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
3933 -- enabled) is in effect because the legacy ABE mechanism does not need
3934 -- to carry out this action.
3936 if Legacy_Elaboration_Checks then
3937 Finalize_All_Data_Structures;
3940 -- Nothing to do for ASIS because ABE checks and diagnostics are not
3941 -- performed in this mode.
3943 elsif ASIS_Mode then
3944 Finalize_All_Data_Structures;
3947 -- Nothing to do when the elaboration phase of the compiler is not
3950 elsif not Elaboration_Phase_Active then
3951 Finalize_All_Data_Structures;
3955 -- Restore the original elaboration model which was in effect when the
3956 -- scenarios were first recorded. The model may be specified by pragma
3957 -- Elaboration_Checks which appears on the initial declaration of the
3960 Install_Elaboration_Model (Unit_Entity (Main_Unit_Entity));
3962 -- Examine the context of the main unit and record all units with prior
3963 -- elaboration with respect to it.
3965 Collect_Elaborated_Units;
3967 -- Examine all scenarios saved during the Recording phase applying the
3968 -- Ada or SPARK elaboration rules in order to detect and diagnose ABE
3969 -- issues, install conditional ABE checks, and ensure the elaboration
3972 Iter := Iterate_Declaration_Scenarios;
3973 Check_Conditional_ABE_Scenarios (Iter);
3975 Iter := Iterate_Library_Body_Scenarios;
3976 Check_Conditional_ABE_Scenarios (Iter);
3978 Iter := Iterate_Library_Spec_Scenarios;
3979 Check_Conditional_ABE_Scenarios (Iter);
3981 -- Examine each SPARK scenario saved during the Recording phase which
3982 -- is not necessarily executable during elaboration, but still requires
3983 -- elaboration-related checks.
3985 Check_SPARK_Scenarios;
3987 -- Add conditional ABE checks for all scenarios that require one when
3988 -- the dynamic model is in effect.
3990 Install_Dynamic_ABE_Checks;
3992 -- Examine all scenarios saved during the Recording phase along with
3993 -- invocation constructs within the spec and body of the main unit.
3994 -- Record the declarations and paths that reach into an external unit
3995 -- in the ALI file of the main unit.
3997 Record_Invocation_Graph;
3999 -- Destroy all internal data structures and complete the elaboration
4000 -- phase of the compiler.
4002 Finalize_All_Data_Structures;
4003 Set_Elaboration_Phase (Completed);
4004 end Check_Elaboration_Scenarios;
4006 ---------------------
4007 -- Check_Installer --
4008 ---------------------
4010 package body Check_Installer is
4012 -----------------------
4013 -- Local subprograms --
4014 -----------------------
4016 function ABE_Check_Or_Failure_OK
4018 Targ_Id : Entity_Id;
4019 Unit_Id : Entity_Id) return Boolean;
4020 pragma Inline (ABE_Check_Or_Failure_OK);
4021 -- Determine whether a conditional ABE check or guaranteed ABE failure
4022 -- can be installed for scenario N with target Targ_Id which resides in
4025 function Insertion_Node (N : Node_Id) return Node_Id;
4026 pragma Inline (Insertion_Node);
4027 -- Obtain the proper insertion node of an ABE check or failure for
4030 procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id);
4031 pragma Inline (Insert_ABE_Check_Or_Failure);
4032 -- Insert conditional ABE check or guaranteed ABE failure Check prior to
4035 procedure Install_Scenario_ABE_Check_Common
4037 Targ_Id : Entity_Id;
4038 Targ_Rep : Target_Rep_Id);
4039 pragma Inline (Install_Scenario_ABE_Check_Common);
4040 -- Install a conditional ABE check for scenario N to ensure that target
4041 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
4044 procedure Install_Scenario_ABE_Failure_Common (N : Node_Id);
4045 pragma Inline (Install_Scenario_ABE_Failure_Common);
4046 -- Install a guaranteed ABE failure for scenario N
4048 procedure Install_Unit_ABE_Check_Common
4050 Unit_Id : Entity_Id);
4051 pragma Inline (Install_Unit_ABE_Check_Common);
4052 -- Install a conditional ABE check for scenario N to ensure that unit
4053 -- Unit_Id is properly elaborated.
4055 -----------------------------
4056 -- ABE_Check_Or_Failure_OK --
4057 -----------------------------
4059 function ABE_Check_Or_Failure_OK
4061 Targ_Id : Entity_Id;
4062 Unit_Id : Entity_Id) return Boolean
4064 pragma Unreferenced (Targ_Id);
4066 Ins_Node : constant Node_Id := Insertion_Node (N);
4069 if not Check_Or_Failure_Generation_OK then
4072 -- Nothing to do when the scenario denots a compilation unit because
4073 -- there is no executable environment at that level.
4075 elsif Nkind (Parent (Ins_Node)) = N_Compilation_Unit then
4078 -- An ABE check or failure is not needed when the target is defined
4079 -- in a unit which is elaborated prior to the main unit. This check
4080 -- must also consider the following cases:
4082 -- * The unit of the target appears in the context of the main unit
4084 -- * The unit of the target is subject to pragma Elaborate_Body. An
4085 -- ABE check MUST NOT be generated because the unit is always
4086 -- elaborated prior to the main unit.
4088 -- * The unit of the target is the main unit. An ABE check MUST be
4089 -- added in this case because a conditional ABE may be raised
4090 -- depending on the flow of execution within the main unit (flag
4091 -- Same_Unit_OK is False).
4093 elsif Has_Prior_Elaboration
4094 (Unit_Id => Unit_Id,
4096 Elab_Body_OK => True)
4102 end ABE_Check_Or_Failure_OK;
4104 ------------------------------------
4105 -- Check_Or_Failure_Generation_OK --
4106 ------------------------------------
4108 function Check_Or_Failure_Generation_OK return Boolean is
4110 -- An ABE check or failure is not needed when the compilation will
4111 -- not produce an executable.
4113 if Serious_Errors_Detected > 0 then
4116 -- An ABE check or failure must not be installed when compiling for
4117 -- GNATprove because raise statements are not supported.
4119 elsif GNATprove_Mode then
4124 end Check_Or_Failure_Generation_OK;
4126 --------------------
4127 -- Insertion_Node --
4128 --------------------
4130 function Insertion_Node (N : Node_Id) return Node_Id is
4132 -- When the scenario denotes an instantiation, the proper insertion
4133 -- node is the instance spec. This ensures that the generic actuals
4134 -- will not be evaluated prior to a potential ABE.
4136 if Nkind (N) in N_Generic_Instantiation
4137 and then Present (Instance_Spec (N))
4139 return Instance_Spec (N);
4141 -- Otherwise the proper insertion node is the scenario itself
4148 ---------------------------------
4149 -- Insert_ABE_Check_Or_Failure --
4150 ---------------------------------
4152 procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id) is
4153 Ins_Nod : constant Node_Id := Insertion_Node (N);
4154 Scop_Id : constant Entity_Id := Find_Enclosing_Scope (Ins_Nod);
4157 -- Install the nearest enclosing scope of the scenario as there must
4158 -- be something on the scope stack.
4160 Push_Scope (Scop_Id);
4162 Insert_Action (Ins_Nod, Check);
4165 end Insert_ABE_Check_Or_Failure;
4167 --------------------------------
4168 -- Install_Dynamic_ABE_Checks --
4169 --------------------------------
4171 procedure Install_Dynamic_ABE_Checks is
4172 Iter : NE_Set.Iterator;
4176 if not Check_Or_Failure_Generation_OK then
4179 -- Nothing to do if the dynamic model is not in effect
4181 elsif not Dynamic_Elaboration_Checks then
4185 -- Install a conditional ABE check for each saved scenario
4187 Iter := Iterate_Dynamic_ABE_Check_Scenarios;
4188 while NE_Set.Has_Next (Iter) loop
4189 NE_Set.Next (Iter, N);
4191 Process_Conditional_ABE
4193 In_State => Dynamic_Model_State);
4195 end Install_Dynamic_ABE_Checks;
4197 --------------------------------
4198 -- Install_Scenario_ABE_Check --
4199 --------------------------------
4201 procedure Install_Scenario_ABE_Check
4203 Targ_Id : Entity_Id;
4204 Targ_Rep : Target_Rep_Id;
4205 Disable : Scenario_Rep_Id)
4208 -- Nothing to do when the scenario does not need an ABE check
4210 if not ABE_Check_Or_Failure_OK
4213 Unit_Id => Unit (Targ_Rep))
4218 -- Prevent multiple attempts to install the same ABE check
4220 Disable_Elaboration_Checks (Disable);
4222 Install_Scenario_ABE_Check_Common
4225 Targ_Rep => Targ_Rep);
4226 end Install_Scenario_ABE_Check;
4228 --------------------------------
4229 -- Install_Scenario_ABE_Check --
4230 --------------------------------
4232 procedure Install_Scenario_ABE_Check
4234 Targ_Id : Entity_Id;
4235 Targ_Rep : Target_Rep_Id;
4236 Disable : Target_Rep_Id)
4239 -- Nothing to do when the scenario does not need an ABE check
4241 if not ABE_Check_Or_Failure_OK
4244 Unit_Id => Unit (Targ_Rep))
4249 -- Prevent multiple attempts to install the same ABE check
4251 Disable_Elaboration_Checks (Disable);
4253 Install_Scenario_ABE_Check_Common
4256 Targ_Rep => Targ_Rep);
4257 end Install_Scenario_ABE_Check;
4259 ---------------------------------------
4260 -- Install_Scenario_ABE_Check_Common --
4261 ---------------------------------------
4263 procedure Install_Scenario_ABE_Check_Common
4265 Targ_Id : Entity_Id;
4266 Targ_Rep : Target_Rep_Id)
4268 Targ_Body : constant Node_Id := Body_Declaration (Targ_Rep);
4269 Targ_Decl : constant Node_Id := Spec_Declaration (Targ_Rep);
4271 pragma Assert (Present (Targ_Body));
4272 pragma Assert (Present (Targ_Decl));
4274 procedure Build_Elaboration_Entity;
4275 pragma Inline (Build_Elaboration_Entity);
4276 -- Create a new elaboration flag for Targ_Id, insert it prior to
4277 -- Targ_Decl, and set it after Targ_Body.
4279 ------------------------------
4280 -- Build_Elaboration_Entity --
4281 ------------------------------
4283 procedure Build_Elaboration_Entity is
4284 Loc : constant Source_Ptr := Sloc (Targ_Id);
4285 Flag_Id : Entity_Id;
4288 -- Nothing to do if the target has an elaboration flag
4290 if Present (Elaboration_Entity (Targ_Id)) then
4294 -- Create the declaration of the elaboration flag. The name
4295 -- carries a unique counter in case the name is overloaded.
4298 Make_Defining_Identifier (Loc,
4299 Chars => New_External_Name (Chars (Targ_Id), 'E', -1));
4301 Set_Elaboration_Entity (Targ_Id, Flag_Id);
4302 Set_Elaboration_Entity_Required (Targ_Id);
4304 Push_Scope (Scope (Targ_Id));
4307 -- Enn : Short_Integer := 0;
4309 Insert_Action (Targ_Decl,
4310 Make_Object_Declaration (Loc,
4311 Defining_Identifier => Flag_Id,
4312 Object_Definition =>
4313 New_Occurrence_Of (Standard_Short_Integer, Loc),
4314 Expression => Make_Integer_Literal (Loc, Uint_0)));
4319 Set_Elaboration_Flag (Targ_Body, Targ_Id);
4322 end Build_Elaboration_Entity;
4326 Loc : constant Source_Ptr := Sloc (N);
4328 -- Start for processing for Install_Scenario_ABE_Check_Common
4331 -- Create an elaboration flag for the target when it does not have
4334 Build_Elaboration_Entity;
4337 -- if not Targ_Id'Elaborated then
4338 -- raise Program_Error with "access before elaboration";
4341 Insert_ABE_Check_Or_Failure
4344 Make_Raise_Program_Error (Loc,
4348 Make_Attribute_Reference (Loc,
4349 Prefix => New_Occurrence_Of (Targ_Id, Loc),
4350 Attribute_Name => Name_Elaborated)),
4351 Reason => PE_Access_Before_Elaboration));
4352 end Install_Scenario_ABE_Check_Common;
4354 ----------------------------------
4355 -- Install_Scenario_ABE_Failure --
4356 ----------------------------------
4358 procedure Install_Scenario_ABE_Failure
4360 Targ_Id : Entity_Id;
4361 Targ_Rep : Target_Rep_Id;
4362 Disable : Scenario_Rep_Id)
4365 -- Nothing to do when the scenario does not require an ABE failure
4367 if not ABE_Check_Or_Failure_OK
4370 Unit_Id => Unit (Targ_Rep))
4375 -- Prevent multiple attempts to install the same ABE check
4377 Disable_Elaboration_Checks (Disable);
4379 Install_Scenario_ABE_Failure_Common (N);
4380 end Install_Scenario_ABE_Failure;
4382 ----------------------------------
4383 -- Install_Scenario_ABE_Failure --
4384 ----------------------------------
4386 procedure Install_Scenario_ABE_Failure
4388 Targ_Id : Entity_Id;
4389 Targ_Rep : Target_Rep_Id;
4390 Disable : Target_Rep_Id)
4393 -- Nothing to do when the scenario does not require an ABE failure
4395 if not ABE_Check_Or_Failure_OK
4398 Unit_Id => Unit (Targ_Rep))
4403 -- Prevent multiple attempts to install the same ABE check
4405 Disable_Elaboration_Checks (Disable);
4407 Install_Scenario_ABE_Failure_Common (N);
4408 end Install_Scenario_ABE_Failure;
4410 -----------------------------------------
4411 -- Install_Scenario_ABE_Failure_Common --
4412 -----------------------------------------
4414 procedure Install_Scenario_ABE_Failure_Common (N : Node_Id) is
4415 Loc : constant Source_Ptr := Sloc (N);
4419 -- raise Program_Error with "access before elaboration";
4421 Insert_ABE_Check_Or_Failure
4424 Make_Raise_Program_Error (Loc,
4425 Reason => PE_Access_Before_Elaboration));
4426 end Install_Scenario_ABE_Failure_Common;
4428 ----------------------------
4429 -- Install_Unit_ABE_Check --
4430 ----------------------------
4432 procedure Install_Unit_ABE_Check
4434 Unit_Id : Entity_Id;
4435 Disable : Scenario_Rep_Id)
4437 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id);
4440 -- Nothing to do when the scenario does not require an ABE check
4442 if not ABE_Check_Or_Failure_OK
4450 -- Prevent multiple attempts to install the same ABE check
4452 Disable_Elaboration_Checks (Disable);
4454 Install_Unit_ABE_Check_Common
4456 Unit_Id => Unit_Id);
4457 end Install_Unit_ABE_Check;
4459 ----------------------------
4460 -- Install_Unit_ABE_Check --
4461 ----------------------------
4463 procedure Install_Unit_ABE_Check
4465 Unit_Id : Entity_Id;
4466 Disable : Target_Rep_Id)
4468 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id);
4471 -- Nothing to do when the scenario does not require an ABE check
4473 if not ABE_Check_Or_Failure_OK
4481 -- Prevent multiple attempts to install the same ABE check
4483 Disable_Elaboration_Checks (Disable);
4485 Install_Unit_ABE_Check_Common
4487 Unit_Id => Unit_Id);
4488 end Install_Unit_ABE_Check;
4490 -----------------------------------
4491 -- Install_Unit_ABE_Check_Common --
4492 -----------------------------------
4494 procedure Install_Unit_ABE_Check_Common
4496 Unit_Id : Entity_Id)
4498 Loc : constant Source_Ptr := Sloc (N);
4499 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id);
4503 -- if not Spec_Id'Elaborated then
4504 -- raise Program_Error with "access before elaboration";
4507 Insert_ABE_Check_Or_Failure
4510 Make_Raise_Program_Error (Loc,
4514 Make_Attribute_Reference (Loc,
4515 Prefix => New_Occurrence_Of (Spec_Id, Loc),
4516 Attribute_Name => Name_Elaborated)),
4517 Reason => PE_Access_Before_Elaboration));
4518 end Install_Unit_ABE_Check_Common;
4519 end Check_Installer;
4521 ----------------------
4522 -- Compilation_Unit --
4523 ----------------------
4525 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is
4526 Comp_Unit : Node_Id;
4529 Comp_Unit := Parent (Unit_Id);
4531 -- Handle the case where a concurrent subunit is rewritten as a null
4532 -- statement due to expansion activities.
4534 if Nkind (Comp_Unit) = N_Null_Statement
4535 and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body,
4538 Comp_Unit := Parent (Comp_Unit);
4539 pragma Assert (Nkind (Comp_Unit) = N_Subunit);
4541 -- Otherwise use the declaration node of the unit
4544 Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id));
4547 -- Handle the case where a subprogram instantiation which acts as a
4548 -- compilation unit is expanded into an anonymous package that wraps
4549 -- the instantiated subprogram.
4551 if Nkind (Comp_Unit) = N_Package_Specification
4552 and then Nkind_In (Original_Node (Parent (Comp_Unit)),
4553 N_Function_Instantiation,
4554 N_Procedure_Instantiation)
4556 Comp_Unit := Parent (Parent (Comp_Unit));
4558 -- Handle the case where the compilation unit is a subunit
4560 elsif Nkind (Comp_Unit) = N_Subunit then
4561 Comp_Unit := Parent (Comp_Unit);
4564 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
4567 end Compilation_Unit;
4569 -------------------------------
4570 -- Conditional_ABE_Processor --
4571 -------------------------------
4573 package body Conditional_ABE_Processor is
4575 -----------------------
4576 -- Local subprograms --
4577 -----------------------
4579 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean;
4580 pragma Inline (Is_Conditional_ABE_Scenario);
4581 -- Determine whether node N is a suitable scenario for conditional ABE
4582 -- checks and diagnostics.
4584 procedure Process_Conditional_ABE_Access_Taken
4586 Attr_Rep : Scenario_Rep_Id;
4587 In_State : Processing_In_State);
4588 pragma Inline (Process_Conditional_ABE_Access_Taken);
4589 -- Perform ABE checks and diagnostics for attribute reference Attr with
4590 -- representation Attr_Rep which takes 'Access of an entry, operator, or
4591 -- subprogram. In_State is the current state of the Processing phase.
4593 procedure Process_Conditional_ABE_Activation
4595 Call_Rep : Scenario_Rep_Id;
4597 Obj_Rep : Target_Rep_Id;
4598 Task_Typ : Entity_Id;
4599 Task_Rep : Target_Rep_Id;
4600 In_State : Processing_In_State);
4601 pragma Inline (Process_Conditional_ABE_Activation);
4602 -- Perform common conditional ABE checks and diagnostics for activation
4603 -- call Call which activates object Obj_Id of task type Task_Typ. Formal
4604 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the
4605 -- representation of the object. Task_Rep denotes the representation of
4606 -- the task type. In_State is the current state of the Processing phase.
4608 procedure Process_Conditional_ABE_Call
4610 Call_Rep : Scenario_Rep_Id;
4611 In_State : Processing_In_State);
4612 pragma Inline (Process_Conditional_ABE_Call);
4613 -- Top-level dispatcher for processing of calls. Perform ABE checks and
4614 -- diagnostics for call Call with representation Call_Rep. In_State is
4615 -- the current state of the Processing phase.
4617 procedure Process_Conditional_ABE_Call_Ada
4619 Call_Rep : Scenario_Rep_Id;
4620 Subp_Id : Entity_Id;
4621 Subp_Rep : Target_Rep_Id;
4622 In_State : Processing_In_State);
4623 pragma Inline (Process_Conditional_ABE_Call_Ada);
4624 -- Perform ABE checks and diagnostics for call Call which invokes entry,
4625 -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes
4626 -- the representation of the call. Subp_Rep denotes the representation
4627 -- of the subprogram. In_State is the current state of the Processing
4630 procedure Process_Conditional_ABE_Call_SPARK
4632 Call_Rep : Scenario_Rep_Id;
4633 Subp_Id : Entity_Id;
4634 Subp_Rep : Target_Rep_Id;
4635 In_State : Processing_In_State);
4636 pragma Inline (Process_Conditional_ABE_Call_SPARK);
4637 -- Perform ABE checks and diagnostics for call Call which invokes entry,
4638 -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is
4639 -- the representation of the call. Subp_Rep denotes the representation
4640 -- of the subprogram. In_State is the current state of the Processing
4643 procedure Process_Conditional_ABE_Instantiation
4645 Inst_Rep : Scenario_Rep_Id;
4646 In_State : Processing_In_State);
4647 pragma Inline (Process_Conditional_ABE_Instantiation);
4648 -- Top-level dispatcher for processing of instantiations. Perform ABE
4649 -- checks and diagnostics for instantiation Inst with representation
4650 -- Inst_Rep. In_State is the current state of the Processing phase.
4652 procedure Process_Conditional_ABE_Instantiation_Ada
4654 Inst_Rep : Scenario_Rep_Id;
4656 Gen_Rep : Target_Rep_Id;
4657 In_State : Processing_In_State);
4658 pragma Inline (Process_Conditional_ABE_Instantiation_Ada);
4659 -- Perform ABE checks and diagnostics for instantiation Inst of generic
4660 -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of
4661 -- the instnace. Gen_Rep is the representation of the generic. In_State
4662 -- is the current state of the Processing phase.
4664 procedure Process_Conditional_ABE_Instantiation_SPARK
4666 Inst_Rep : Scenario_Rep_Id;
4668 Gen_Rep : Target_Rep_Id;
4669 In_State : Processing_In_State);
4670 pragma Inline (Process_Conditional_ABE_Instantiation_SPARK);
4671 -- Perform ABE checks and diagnostics for instantiation Inst of generic
4672 -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of
4673 -- the instnace. Gen_Rep is the representation of the generic. In_State
4674 -- is the current state of the Processing phase.
4676 procedure Process_Conditional_ABE_Variable_Assignment
4678 Asmt_Rep : Scenario_Rep_Id;
4679 In_State : Processing_In_State);
4680 pragma Inline (Process_Conditional_ABE_Variable_Assignment);
4681 -- Top-level dispatcher for processing of variable assignments. Perform
4682 -- ABE checks and diagnostics for assignment Asmt with representation
4683 -- Asmt_Rep. In_State denotes the current state of the Processing phase.
4685 procedure Process_Conditional_ABE_Variable_Assignment_Ada
4687 Asmt_Rep : Scenario_Rep_Id;
4689 Var_Rep : Target_Rep_Id;
4690 In_State : Processing_In_State);
4691 pragma Inline (Process_Conditional_ABE_Variable_Assignment_Ada);
4692 -- Perform ABE checks and diagnostics for assignment statement Asmt that
4693 -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep
4694 -- denotes the representation of the assignment. Var_Rep denotes the
4695 -- representation of the variable. In_State is the current state of the
4696 -- Processing phase.
4698 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
4700 Asmt_Rep : Scenario_Rep_Id;
4702 Var_Rep : Target_Rep_Id;
4703 In_State : Processing_In_State);
4704 pragma Inline (Process_Conditional_ABE_Variable_Assignment_SPARK);
4705 -- Perform ABE checks and diagnostics for assignment statement Asmt that
4706 -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep
4707 -- denotes the representation of the assignment. Var_Rep denotes the
4708 -- representation of the variable. In_State is the current state of the
4709 -- Processing phase.
4711 procedure Process_Conditional_ABE_Variable_Reference
4713 Ref_Rep : Scenario_Rep_Id;
4714 In_State : Processing_In_State);
4715 pragma Inline (Process_Conditional_ABE_Variable_Reference);
4716 -- Perform ABE checks and diagnostics for variable reference Ref with
4717 -- representation Ref_Rep. In_State denotes the current state of the
4718 -- Processing phase.
4720 procedure Traverse_Conditional_ABE_Body
4722 In_State : Processing_In_State);
4723 pragma Inline (Traverse_Conditional_ABE_Body);
4724 -- Traverse subprogram body N looking for suitable scenarios that need
4725 -- to be processed for conditional ABE checks and diagnostics. In_State
4726 -- is the current state of the Processing phase.
4728 -------------------------------------
4729 -- Check_Conditional_ABE_Scenarios --
4730 -------------------------------------
4732 procedure Check_Conditional_ABE_Scenarios
4733 (Iter : in out NE_Set.Iterator)
4738 while NE_Set.Has_Next (Iter) loop
4739 NE_Set.Next (Iter, N);
4741 -- Reset the traversed status of all subprogram bodies because the
4742 -- current conditional scenario acts as a new DFS traversal root.
4744 Reset_Traversed_Bodies;
4746 Process_Conditional_ABE
4748 In_State => Conditional_ABE_State);
4750 end Check_Conditional_ABE_Scenarios;
4752 ---------------------------------
4753 -- Is_Conditional_ABE_Scenario --
4754 ---------------------------------
4756 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean is
4759 Is_Suitable_Access_Taken (N)
4760 or else Is_Suitable_Call (N)
4761 or else Is_Suitable_Instantiation (N)
4762 or else Is_Suitable_Variable_Assignment (N)
4763 or else Is_Suitable_Variable_Reference (N);
4764 end Is_Conditional_ABE_Scenario;
4766 -----------------------------
4767 -- Process_Conditional_ABE --
4768 -----------------------------
4770 procedure Process_Conditional_ABE
4772 In_State : Processing_In_State)
4774 Scen : constant Node_Id := Scenario (N);
4775 Scen_Rep : Scenario_Rep_Id;
4778 -- Add the current scenario to the stack of active scenarios
4780 Push_Active_Scenario (Scen);
4784 if Is_Suitable_Access_Taken (Scen) then
4785 Process_Conditional_ABE_Access_Taken
4787 Attr_Rep => Scenario_Representation_Of (Scen, In_State),
4788 In_State => In_State);
4790 -- Call or task activation
4792 elsif Is_Suitable_Call (Scen) then
4793 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
4795 -- Routine Build_Call_Marker creates call markers regardless of
4796 -- whether the call occurs within the main unit or not. This way
4797 -- the serialization of internal names is kept consistent. Only
4798 -- call markers found within the main unit must be processed.
4800 if In_Main_Context (Scen) then
4801 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
4803 if Kind (Scen_Rep) = Call_Scenario then
4804 Process_Conditional_ABE_Call
4806 Call_Rep => Scen_Rep,
4807 In_State => In_State);
4810 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario);
4814 Call_Rep => Scen_Rep,
4815 Processor => Process_Conditional_ABE_Activation'Access,
4816 In_State => In_State);
4822 elsif Is_Suitable_Instantiation (Scen) then
4823 Process_Conditional_ABE_Instantiation
4825 Inst_Rep => Scenario_Representation_Of (Scen, In_State),
4826 In_State => In_State);
4828 -- Variable assignments
4830 elsif Is_Suitable_Variable_Assignment (Scen) then
4831 Process_Conditional_ABE_Variable_Assignment
4833 Asmt_Rep => Scenario_Representation_Of (Scen, In_State),
4834 In_State => In_State);
4836 -- Variable references
4838 elsif Is_Suitable_Variable_Reference (Scen) then
4840 -- Routine Build_Variable_Reference_Marker makes variable markers
4841 -- regardless of whether the reference occurs within the main unit
4842 -- or not. This way the serialization of internal names is kept
4843 -- consistent. Only variable markers within the main unit must be
4846 if In_Main_Context (Scen) then
4847 Process_Conditional_ABE_Variable_Reference
4849 Ref_Rep => Scenario_Representation_Of (Scen, In_State),
4850 In_State => In_State);
4854 -- Remove the current scenario from the stack of active scenarios
4855 -- once all ABE diagnostics and checks have been performed.
4857 Pop_Active_Scenario (Scen);
4858 end Process_Conditional_ABE;
4860 ------------------------------------------
4861 -- Process_Conditional_ABE_Access_Taken --
4862 ------------------------------------------
4864 procedure Process_Conditional_ABE_Access_Taken
4866 Attr_Rep : Scenario_Rep_Id;
4867 In_State : Processing_In_State)
4869 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id;
4870 pragma Inline (Build_Access_Marker);
4871 -- Create a suitable call marker which invokes subprogram Subp_Id
4873 -------------------------
4874 -- Build_Access_Marker --
4875 -------------------------
4877 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id is
4881 Marker := Make_Call_Marker (Sloc (Attr));
4883 -- Inherit relevant attributes from the attribute
4885 Set_Target (Marker, Subp_Id);
4886 Set_Is_Declaration_Level_Node
4887 (Marker, Level (Attr_Rep) = Declaration_Level);
4888 Set_Is_Dispatching_Call
4890 Set_Is_Elaboration_Checks_OK_Node
4891 (Marker, Elaboration_Checks_OK (Attr_Rep));
4892 Set_Is_Elaboration_Warnings_OK_Node
4893 (Marker, Elaboration_Warnings_OK (Attr_Rep));
4895 (Marker, Comes_From_Source (Attr));
4896 Set_Is_SPARK_Mode_On_Node
4897 (Marker, SPARK_Mode_Of (Attr_Rep) = Is_On);
4899 -- Partially insert the call marker into the tree by setting its
4902 Set_Parent (Marker, Attr);
4905 end Build_Access_Marker;
4909 Root : constant Node_Id := Root_Scenario;
4910 Subp_Id : constant Entity_Id := Target (Attr_Rep);
4911 Subp_Rep : constant Target_Rep_Id :=
4912 Target_Representation_Of (Subp_Id, In_State);
4913 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep);
4915 New_In_State : Processing_In_State := In_State;
4916 -- Each step of the Processing phase constitutes a new state
4918 -- Start of processing for Process_Conditional_ABE_Access
4921 -- Output relevant information when switch -gnatel (info messages on
4922 -- implicit Elaborate[_All] pragmas) is in effect.
4924 if Elab_Info_Messages
4925 and then not New_In_State.Suppress_Info_Messages
4928 ("info: access to & during elaboration", Attr, Subp_Id);
4931 -- Warnings are suppressed when a prior scenario is already in that
4932 -- mode or when the attribute or the target have warnings suppressed.
4933 -- Update the state of the Processing phase to reflect this.
4935 New_In_State.Suppress_Warnings :=
4936 New_In_State.Suppress_Warnings
4937 or else not Elaboration_Warnings_OK (Attr_Rep)
4938 or else not Elaboration_Warnings_OK (Subp_Rep);
4940 -- Do not emit any ABE diagnostics when the current or previous
4941 -- scenario in this traversal has suppressed elaboration warnings.
4943 if New_In_State.Suppress_Warnings then
4946 -- Both the attribute and the corresponding subprogram body are in
4947 -- the same unit. The body must appear prior to the root scenario
4948 -- which started the recursive search. If this is not the case, then
4949 -- there is a potential ABE if the access value is used to call the
4950 -- subprogram. Emit a warning only when switch -gnatw.f (warnings on
4951 -- suspucious 'Access) is in effect.
4953 elsif Warn_On_Elab_Access
4954 and then Present (Body_Decl)
4955 and then In_Extended_Main_Code_Unit (Body_Decl)
4956 and then Earlier_In_Extended_Unit (Root, Body_Decl)
4958 Error_Msg_Name_1 := Attribute_Name (Attr);
4960 ("??% attribute of & before body seen", Attr, Subp_Id);
4961 Error_Msg_N ("\possible Program_Error on later references", Attr);
4963 Output_Active_Scenarios (Attr, New_In_State);
4966 -- Treat the attribute an an immediate invocation of the target when
4967 -- switch -gnatd.o (conservative elaboration order for indirect
4968 -- calls) is in effect. This has the following desirable effects:
4970 -- * Ensure that the unit with the corresponding body is elaborated
4971 -- prior to the main unit.
4973 -- * Perform conditional ABE checks and diagnostics
4975 -- * Traverse the body of the target (if available)
4977 if Debug_Flag_Dot_O then
4978 Process_Conditional_ABE
4979 (N => Build_Access_Marker (Subp_Id),
4980 In_State => New_In_State);
4982 -- Otherwise ensure that the unit with the corresponding body is
4983 -- elaborated prior to the main unit.
4986 Ensure_Prior_Elaboration
4988 Unit_Id => Unit (Subp_Rep),
4989 Prag_Nam => Name_Elaborate_All,
4990 In_State => New_In_State);
4992 end Process_Conditional_ABE_Access_Taken;
4994 ----------------------------------------
4995 -- Process_Conditional_ABE_Activation --
4996 ----------------------------------------
4998 procedure Process_Conditional_ABE_Activation
5000 Call_Rep : Scenario_Rep_Id;
5002 Obj_Rep : Target_Rep_Id;
5003 Task_Typ : Entity_Id;
5004 Task_Rep : Target_Rep_Id;
5005 In_State : Processing_In_State)
5007 pragma Unreferenced (Task_Typ);
5009 Body_Decl : constant Node_Id := Body_Declaration (Task_Rep);
5010 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep);
5011 Root : constant Node_Id := Root_Scenario;
5012 Unit_Id : constant Node_Id := Unit (Task_Rep);
5014 Check_OK : constant Boolean :=
5015 not In_State.Suppress_Checks
5016 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored
5017 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored
5018 and then Elaboration_Checks_OK (Obj_Rep)
5019 and then Elaboration_Checks_OK (Task_Rep);
5020 -- A run-time ABE check may be installed only when the object and the
5021 -- task type have active elaboration checks, and both are not ignored
5022 -- Ghost constructs.
5024 New_In_State : Processing_In_State := In_State;
5025 -- Each step of the Processing phase constitutes a new state
5028 -- Output relevant information when switch -gnatel (info messages on
5029 -- implicit Elaborate[_All] pragmas) is in effect.
5031 if Elab_Info_Messages
5032 and then not New_In_State.Suppress_Info_Messages
5035 ("info: activation of & during elaboration", Call, Obj_Id);
5038 -- Nothing to do when the call activates a task whose type is defined
5039 -- within an instance and switch -gnatd_i (ignore activations and
5040 -- calls to instances for elaboration) is in effect.
5042 if Debug_Flag_Underscore_I
5043 and then In_External_Instance
5045 Target_Decl => Spec_Decl)
5049 -- Nothing to do when the activation is a guaranteed ABE
5051 elsif Is_Known_Guaranteed_ABE (Call) then
5054 -- Nothing to do when the root scenario appears at the declaration
5055 -- level and the task is in the same unit, but outside this context.
5057 -- task type Task_Typ; -- task declaration
5059 -- procedure Proc is
5060 -- function A ... is
5062 -- if Some_Condition then
5066 -- <activation call> -- activation site
5071 -- X : ... := A; -- root scenario
5074 -- task body Task_Typ is
5078 -- In the example above, the context of X is the declarative list of
5079 -- Proc. The "elaboration" of X may reach the activation of T whose
5080 -- body is defined outside of X's context. The task body is relevant
5081 -- only when Proc is invoked, but this happens only during "normal"
5082 -- elaboration, therefore the task body must not be considered if
5083 -- this is not the case.
5085 elsif Is_Up_Level_Target
5086 (Targ_Decl => Spec_Decl,
5087 In_State => New_In_State)
5091 -- Nothing to do when the activation is ABE-safe
5095 -- task type Task_Typ;
5098 -- package body Gen is
5099 -- task body Task_Typ is
5106 -- procedure Main is
5107 -- package Nested is
5108 -- package Inst is new Gen;
5109 -- T : Inst.Task_Typ;
5110 -- <activation call> -- safe activation
5114 elsif Is_Safe_Activation (Call, Task_Rep) then
5116 -- Note that the task body must still be examined for any nested
5121 -- The activation call and the task body are both in the main unit
5123 -- If the root scenario appears prior to the task body, then this is
5124 -- a possible ABE with respect to the root scenario.
5126 -- task type Task_Typ;
5128 -- function A ... is
5130 -- if Some_Condition then
5134 -- end Pack; -- activation of T
5138 -- X : ... := A; -- root scenario
5140 -- task body Task_Typ is -- task body
5144 -- Y : ... := A; -- root scenario
5146 -- IMPORTANT: The activation of T is a possible ABE for X, but
5147 -- not for Y. Intalling an unconditional ABE raise prior to the
5148 -- activation call would be wrong as it will fail for Y as well
5149 -- but in Y's case the activation of T is never an ABE.
5151 elsif Present (Body_Decl)
5152 and then In_Extended_Main_Code_Unit (Body_Decl)
5154 if Earlier_In_Extended_Unit (Root, Body_Decl) then
5156 -- Do not emit any ABE diagnostics when a previous scenario in
5157 -- this traversal has suppressed elaboration warnings.
5159 if New_In_State.Suppress_Warnings then
5162 -- Do not emit any ABE diagnostics when the activation occurs
5163 -- in a partial finalization context because this action leads
5164 -- to confusing noise.
5166 elsif New_In_State.Within_Partial_Finalization then
5169 -- Otherwise emit the ABE disgnostic
5172 Error_Msg_Sloc := Sloc (Call);
5174 ("??task & will be activated # before elaboration of its "
5177 ("\Program_Error may be raised at run time", Obj_Id);
5179 Output_Active_Scenarios (Obj_Id, New_In_State);
5182 -- Install a conditional run-time ABE check to verify that the
5183 -- task body has been elaborated prior to the activation call.
5186 Install_Scenario_ABE_Check
5188 Targ_Id => Defining_Entity (Spec_Decl),
5189 Targ_Rep => Task_Rep,
5190 Disable => Obj_Rep);
5192 -- Update the state of the Processing phase to indicate that
5193 -- no implicit Elaborate[_All] pragma must be generated from
5196 -- task type Task_Typ;
5198 -- function A ... is
5200 -- if Some_Condition then
5205 -- end Pack; -- activation of T
5211 -- task body Task_Typ is
5213 -- External.Subp; -- imparts Elaborate_All
5216 -- If Some_Condition is True, then the ABE check will fail
5217 -- at runtime and the call to External.Subp will never take
5218 -- place, rendering the implicit Elaborate_All useless.
5220 -- If the value of Some_Condition is False, then the call
5221 -- to External.Subp will never take place, rendering the
5222 -- implicit Elaborate_All useless.
5224 New_In_State.Suppress_Implicit_Pragmas := True;
5228 -- Otherwise the task body is not available in this compilation or
5229 -- it resides in an external unit. Install a run-time ABE check to
5230 -- verify that the task body has been elaborated prior to the
5231 -- activation call when the dynamic model is in effect.
5234 and then New_In_State.Processing = Dynamic_Model_Processing
5236 Install_Unit_ABE_Check
5239 Disable => Obj_Rep);
5242 -- Both the activation call and task type are subject to SPARK_Mode
5243 -- On, this triggers the SPARK rules for task activation. Compared
5244 -- to calls and instantiations, task activation in SPARK does not
5245 -- require the presence of Elaborate[_All] pragmas in case the task
5246 -- type is defined outside the main unit. This is because SPARK uses
5247 -- a special policy which activates all tasks after the main unit has
5248 -- finished its elaboration.
5250 if SPARK_Mode_Of (Call_Rep) = Is_On
5251 and then SPARK_Mode_Of (Task_Rep) = Is_On
5255 -- Otherwise the Ada rules are in effect. Ensure that the unit with
5256 -- the task body is elaborated prior to the main unit.
5259 Ensure_Prior_Elaboration
5262 Prag_Nam => Name_Elaborate_All,
5263 In_State => New_In_State);
5266 Traverse_Conditional_ABE_Body
5268 In_State => New_In_State);
5269 end Process_Conditional_ABE_Activation;
5271 ----------------------------------
5272 -- Process_Conditional_ABE_Call --
5273 ----------------------------------
5275 procedure Process_Conditional_ABE_Call
5277 Call_Rep : Scenario_Rep_Id;
5278 In_State : Processing_In_State)
5280 function In_Initialization_Context (N : Node_Id) return Boolean;
5281 pragma Inline (In_Initialization_Context);
5282 -- Determine whether arbitrary node N appears within a type init
5283 -- proc, primitive [Deep_]Initialize, or a block created for
5284 -- initialization purposes.
5286 function Is_Partial_Finalization_Proc
5287 (Subp_Id : Entity_Id) return Boolean;
5288 pragma Inline (Is_Partial_Finalization_Proc);
5289 -- Determine whether subprogram Subp_Id is a partial finalization
5292 -------------------------------
5293 -- In_Initialization_Context --
5294 -------------------------------
5296 function In_Initialization_Context (N : Node_Id) return Boolean is
5298 Spec_Id : Entity_Id;
5301 -- Climb the parent chain looking for initialization actions
5304 while Present (Par) loop
5306 -- A block may be part of the initialization actions of a
5307 -- default initialized object.
5309 if Nkind (Par) = N_Block_Statement
5310 and then Is_Initialization_Block (Par)
5314 -- A subprogram body may denote an initialization routine
5316 elsif Nkind (Par) = N_Subprogram_Body then
5317 Spec_Id := Unique_Defining_Entity (Par);
5319 -- The current subprogram body denotes a type init proc or
5320 -- primitive [Deep_]Initialize.
5322 if Is_Init_Proc (Spec_Id)
5323 or else Is_Controlled_Proc (Spec_Id, Name_Initialize)
5324 or else Is_TSS (Spec_Id, TSS_Deep_Initialize)
5329 -- Prevent the search from going too far
5331 elsif Is_Body_Or_Package_Declaration (Par) then
5335 Par := Parent (Par);
5339 end In_Initialization_Context;
5341 ----------------------------------
5342 -- Is_Partial_Finalization_Proc --
5343 ----------------------------------
5345 function Is_Partial_Finalization_Proc
5346 (Subp_Id : Entity_Id) return Boolean
5349 -- To qualify, the subprogram must denote a finalizer procedure
5350 -- or primitive [Deep_]Finalize, and the call must appear within
5351 -- an initialization context.
5354 (Is_Controlled_Proc (Subp_Id, Name_Finalize)
5355 or else Is_Finalizer_Proc (Subp_Id)
5356 or else Is_TSS (Subp_Id, TSS_Deep_Finalize))
5357 and then In_Initialization_Context (Call);
5358 end Is_Partial_Finalization_Proc;
5362 Subp_Id : constant Entity_Id := Target (Call_Rep);
5363 Subp_Rep : constant Target_Rep_Id :=
5364 Target_Representation_Of (Subp_Id, In_State);
5365 Subp_Decl : constant Node_Id := Spec_Declaration (Subp_Rep);
5367 SPARK_Rules_On : constant Boolean :=
5368 SPARK_Mode_Of (Call_Rep) = Is_On
5369 and then SPARK_Mode_Of (Subp_Rep) = Is_On;
5371 New_In_State : Processing_In_State := In_State;
5372 -- Each step of the Processing phase constitutes a new state
5374 -- Start of processing for Process_Conditional_ABE_Call
5377 -- Output relevant information when switch -gnatel (info messages on
5378 -- implicit Elaborate[_All] pragmas) is in effect.
5380 if Elab_Info_Messages
5381 and then not New_In_State.Suppress_Info_Messages
5387 In_SPARK => SPARK_Rules_On);
5390 -- Check whether the invocation of an entry clashes with an existing
5391 -- restriction. This check is relevant only when the processing was
5392 -- started from some library-level scenario.
5394 if Is_Protected_Entry (Subp_Id) then
5395 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call);
5397 elsif Is_Task_Entry (Subp_Id) then
5398 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call);
5400 -- Task entry calls are never processed because the entry being
5401 -- invoked does not have a corresponding "body", it has a select.
5406 -- Nothing to do when the call invokes a target defined within an
5407 -- instance and switch -gnatd_i (ignore activations and calls to
5408 -- instances for elaboration) is in effect.
5410 if Debug_Flag_Underscore_I
5411 and then In_External_Instance
5413 Target_Decl => Subp_Decl)
5417 -- Nothing to do when the call is a guaranteed ABE
5419 elsif Is_Known_Guaranteed_ABE (Call) then
5422 -- Nothing to do when the root scenario appears at the declaration
5423 -- level and the target is in the same unit but outside this context.
5425 -- function B ...; -- target declaration
5427 -- procedure Proc is
5428 -- function A ... is
5430 -- if Some_Condition then
5431 -- return B; -- call site
5435 -- X : ... := A; -- root scenario
5438 -- function B ... is
5442 -- In the example above, the context of X is the declarative region
5443 -- of Proc. The "elaboration" of X may eventually reach B which is
5444 -- defined outside of X's context. B is relevant only when Proc is
5445 -- invoked, but this happens only by means of "normal" elaboration,
5446 -- therefore B must not be considered if this is not the case.
5448 elsif Is_Up_Level_Target
5449 (Targ_Decl => Subp_Decl,
5450 In_State => New_In_State)
5455 -- Warnings are suppressed when a prior scenario is already in that
5456 -- mode, or the call or target have warnings suppressed. Update the
5457 -- state of the Processing phase to reflect this.
5459 New_In_State.Suppress_Warnings :=
5460 New_In_State.Suppress_Warnings
5461 or else not Elaboration_Warnings_OK (Call_Rep)
5462 or else not Elaboration_Warnings_OK (Subp_Rep);
5464 -- The call occurs in an initial condition context when a prior
5465 -- scenario is already in that mode, or when the target is an
5466 -- Initial_Condition procedure. Update the state of the Processing
5467 -- phase to reflect this.
5469 New_In_State.Within_Initial_Condition :=
5470 New_In_State.Within_Initial_Condition
5471 or else Is_Initial_Condition_Proc (Subp_Id);
5473 -- The call occurs in a partial finalization context when a prior
5474 -- scenario is already in that mode, or when the target denotes a
5475 -- [Deep_]Finalize primitive or a finalizer within an initialization
5476 -- context. Update the state of the Processing phase to reflect this.
5478 New_In_State.Within_Partial_Finalization :=
5479 New_In_State.Within_Partial_Finalization
5480 or else Is_Partial_Finalization_Proc (Subp_Id);
5482 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK
5483 -- elaboration rules in SPARK code) is intentionally not taken into
5484 -- account here because Process_Conditional_ABE_Call_SPARK has two
5485 -- separate modes of operation.
5487 if SPARK_Rules_On then
5488 Process_Conditional_ABE_Call_SPARK
5490 Call_Rep => Call_Rep,
5492 Subp_Rep => Subp_Rep,
5493 In_State => New_In_State);
5495 -- Otherwise the Ada rules are in effect
5498 Process_Conditional_ABE_Call_Ada
5500 Call_Rep => Call_Rep,
5502 Subp_Rep => Subp_Rep,
5503 In_State => New_In_State);
5506 -- Inspect the target body (and barried function) for other suitable
5507 -- elaboration scenarios.
5509 Traverse_Conditional_ABE_Body
5510 (N => Barrier_Body_Declaration (Subp_Rep),
5511 In_State => New_In_State);
5513 Traverse_Conditional_ABE_Body
5514 (N => Body_Declaration (Subp_Rep),
5515 In_State => New_In_State);
5516 end Process_Conditional_ABE_Call;
5518 --------------------------------------
5519 -- Process_Conditional_ABE_Call_Ada --
5520 --------------------------------------
5522 procedure Process_Conditional_ABE_Call_Ada
5524 Call_Rep : Scenario_Rep_Id;
5525 Subp_Id : Entity_Id;
5526 Subp_Rep : Target_Rep_Id;
5527 In_State : Processing_In_State)
5529 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep);
5530 Root : constant Node_Id := Root_Scenario;
5531 Unit_Id : constant Node_Id := Unit (Subp_Rep);
5533 Check_OK : constant Boolean :=
5534 not In_State.Suppress_Checks
5535 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored
5536 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored
5537 and then Elaboration_Checks_OK (Call_Rep)
5538 and then Elaboration_Checks_OK (Subp_Rep);
5539 -- A run-time ABE check may be installed only when both the call
5540 -- and the target have active elaboration checks, and both are not
5541 -- ignored Ghost constructs.
5543 New_In_State : Processing_In_State := In_State;
5544 -- Each step of the Processing phase constitutes a new state
5547 -- Nothing to do for an Ada dispatching call because there are no
5548 -- ABE diagnostics for either models. ABE checks for the dynamic
5549 -- model are handled by Install_Primitive_Elaboration_Check.
5551 if Is_Dispatching_Call (Call_Rep) then
5554 -- Nothing to do when the call is ABE-safe
5557 -- function Gen ...;
5559 -- function Gen ... is
5565 -- procedure Main is
5566 -- function Inst is new Gen;
5567 -- X : ... := Inst; -- safe call
5570 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then
5573 -- The call and the target body are both in the main unit
5575 -- If the root scenario appears prior to the target body, then this
5576 -- is a possible ABE with respect to the root scenario.
5580 -- function A ... is
5582 -- if Some_Condition then
5583 -- return B; -- call site
5587 -- X : ... := A; -- root scenario
5589 -- function B ... is -- target body
5593 -- Y : ... := A; -- root scenario
5595 -- IMPORTANT: The call to B from A is a possible ABE for X, but
5596 -- not for Y. Installing an unconditional ABE raise prior to the
5597 -- call to B would be wrong as it will fail for Y as well, but in
5598 -- Y's case the call to B is never an ABE.
5600 elsif Present (Body_Decl)
5601 and then In_Extended_Main_Code_Unit (Body_Decl)
5603 if Earlier_In_Extended_Unit (Root, Body_Decl) then
5605 -- Do not emit any ABE diagnostics when a previous scenario in
5606 -- this traversal has suppressed elaboration warnings.
5608 if New_In_State.Suppress_Warnings then
5611 -- Do not emit any ABE diagnostics when the call occurs in a
5612 -- partial finalization context because this leads to confusing
5615 elsif New_In_State.Within_Partial_Finalization then
5618 -- Otherwise emit the ABE diagnostic
5622 ("??cannot call & before body seen", Call, Subp_Id);
5624 ("\Program_Error may be raised at run time", Call);
5626 Output_Active_Scenarios (Call, New_In_State);
5629 -- Install a conditional run-time ABE check to verify that the
5630 -- target body has been elaborated prior to the call.
5633 Install_Scenario_ABE_Check
5636 Targ_Rep => Subp_Rep,
5637 Disable => Call_Rep);
5639 -- Update the state of the Processing phase to indicate that
5640 -- no implicit Elaborate[_All] pragma must be generated from
5645 -- function A ... is
5647 -- if Some_Condition then
5655 -- function B ... is
5656 -- External.Subp; -- imparts Elaborate_All
5659 -- If Some_Condition is True, then the ABE check will fail
5660 -- at runtime and the call to External.Subp will never take
5661 -- place, rendering the implicit Elaborate_All useless.
5663 -- If the value of Some_Condition is False, then the call
5664 -- to External.Subp will never take place, rendering the
5665 -- implicit Elaborate_All useless.
5667 New_In_State.Suppress_Implicit_Pragmas := True;
5671 -- Otherwise the target body is not available in this compilation or
5672 -- it resides in an external unit. Install a run-time ABE check to
5673 -- verify that the target body has been elaborated prior to the call
5674 -- site when the dynamic model is in effect.
5677 and then New_In_State.Processing = Dynamic_Model_Processing
5679 Install_Unit_ABE_Check
5682 Disable => Call_Rep);
5685 -- Ensure that the unit with the target body is elaborated prior to
5686 -- the main unit. The implicit Elaborate[_All] is generated only when
5687 -- the call has elaboration checks enabled. This behaviour parallels
5688 -- that of the old ABE mechanism.
5690 if Elaboration_Checks_OK (Call_Rep) then
5691 Ensure_Prior_Elaboration
5694 Prag_Nam => Name_Elaborate_All,
5695 In_State => New_In_State);
5697 end Process_Conditional_ABE_Call_Ada;
5699 ----------------------------------------
5700 -- Process_Conditional_ABE_Call_SPARK --
5701 ----------------------------------------
5703 procedure Process_Conditional_ABE_Call_SPARK
5705 Call_Rep : Scenario_Rep_Id;
5706 Subp_Id : Entity_Id;
5707 Subp_Rep : Target_Rep_Id;
5708 In_State : Processing_In_State)
5710 pragma Unreferenced (Call_Rep);
5712 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep);
5716 -- Ensure that a suitable elaboration model is in effect for SPARK
5717 -- rule verification.
5719 Check_SPARK_Model_In_Effect;
5721 -- The call and the target body are both in the main unit
5723 if Present (Body_Decl)
5724 and then In_Extended_Main_Code_Unit (Body_Decl)
5725 and then Earlier_In_Extended_Unit (Call, Body_Decl)
5727 -- Do not emit any ABE diagnostics when a previous scenario in
5728 -- this traversal has suppressed elaboration warnings.
5730 if In_State.Suppress_Warnings then
5733 -- Do not emit any ABE diagnostics when the call occurs in an
5734 -- initial condition context because this leads to incorrect
5737 elsif In_State.Within_Initial_Condition then
5740 -- Do not emit any ABE diagnostics when the call occurs in a
5741 -- partial finalization context because this leads to confusing
5744 elsif In_State.Within_Partial_Finalization then
5747 -- Ensure that a call that textually precedes the subprogram body
5748 -- it invokes appears within the early call region of the body.
5750 -- IMPORTANT: This check must always be performed even when switch
5751 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
5752 -- specified because the static model cannot guarantee the absence
5753 -- of elaboration issues when dispatching calls are involved.
5756 Region := Find_Early_Call_Region (Body_Decl);
5758 if Earlier_In_Extended_Unit (Call, Region) then
5760 ("call must appear within early call region of subprogram "
5761 & "body & (SPARK RM 7.7(3))",
5764 Error_Msg_Sloc := Sloc (Region);
5765 Error_Msg_N ("\region starts #", Call);
5767 Error_Msg_Sloc := Sloc (Body_Decl);
5768 Error_Msg_N ("\region ends #", Call);
5770 Output_Active_Scenarios (Call, In_State);
5775 -- A call to a source target or to a target which emulates Ada
5776 -- or SPARK semantics imposes an Elaborate_All requirement on the
5777 -- context of the main unit. Determine whether the context has a
5778 -- pragma strong enough to meet the requirement.
5780 -- IMPORTANT: This check must be performed only when switch -gnatd.v
5781 -- (enforce SPARK elaboration rules in SPARK code) is active because
5782 -- the static model can ensure the prior elaboration of the unit
5783 -- which contains a body by installing an implicit Elaborate[_All]
5786 if Debug_Flag_Dot_V then
5787 if Comes_From_Source (Subp_Id)
5788 or else Is_Ada_Semantic_Target (Subp_Id)
5789 or else Is_SPARK_Semantic_Target (Subp_Id)
5791 Meet_Elaboration_Requirement
5794 Req_Nam => Name_Elaborate_All,
5795 In_State => In_State);
5798 -- Otherwise ensure that the unit with the target body is elaborated
5799 -- prior to the main unit.
5802 Ensure_Prior_Elaboration
5804 Unit_Id => Unit (Subp_Rep),
5805 Prag_Nam => Name_Elaborate_All,
5806 In_State => In_State);
5808 end Process_Conditional_ABE_Call_SPARK;
5810 -------------------------------------------
5811 -- Process_Conditional_ABE_Instantiation --
5812 -------------------------------------------
5814 procedure Process_Conditional_ABE_Instantiation
5816 Inst_Rep : Scenario_Rep_Id;
5817 In_State : Processing_In_State)
5819 Gen_Id : constant Entity_Id := Target (Inst_Rep);
5820 Gen_Rep : constant Target_Rep_Id :=
5821 Target_Representation_Of (Gen_Id, In_State);
5823 SPARK_Rules_On : constant Boolean :=
5824 SPARK_Mode_Of (Inst_Rep) = Is_On
5825 and then SPARK_Mode_Of (Gen_Rep) = Is_On;
5827 New_In_State : Processing_In_State := In_State;
5828 -- Each step of the Processing phase constitutes a new state
5831 -- Output relevant information when switch -gnatel (info messages on
5832 -- implicit Elaborate[_All] pragmas) is in effect.
5834 if Elab_Info_Messages
5835 and then not New_In_State.Suppress_Info_Messages
5841 In_SPARK => SPARK_Rules_On);
5844 -- Nothing to do when the instantiation is a guaranteed ABE
5846 if Is_Known_Guaranteed_ABE (Inst) then
5849 -- Nothing to do when the root scenario appears at the declaration
5850 -- level and the generic is in the same unit, but outside this
5854 -- procedure Gen is ...; -- generic declaration
5856 -- procedure Proc is
5857 -- function A ... is
5859 -- if Some_Condition then
5861 -- procedure I is new Gen; -- instantiation site
5866 -- X : ... := A; -- root scenario
5873 -- In the example above, the context of X is the declarative region
5874 -- of Proc. The "elaboration" of X may eventually reach Gen which
5875 -- appears outside of X's context. Gen is relevant only when Proc is
5876 -- invoked, but this happens only by means of "normal" elaboration,
5877 -- therefore Gen must not be considered if this is not the case.
5879 elsif Is_Up_Level_Target
5880 (Targ_Decl => Spec_Declaration (Gen_Rep),
5881 In_State => New_In_State)
5886 -- Warnings are suppressed when a prior scenario is already in that
5887 -- mode, or when the instantiation has warnings suppressed. Update
5888 -- the state of the processing phase to reflect this.
5890 New_In_State.Suppress_Warnings :=
5891 New_In_State.Suppress_Warnings
5892 or else not Elaboration_Warnings_OK (Inst_Rep);
5894 -- The SPARK rules are in effect
5896 if SPARK_Rules_On then
5897 Process_Conditional_ABE_Instantiation_SPARK
5899 Inst_Rep => Inst_Rep,
5902 In_State => New_In_State);
5904 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
5905 -- violate the SPARK rules.
5908 Process_Conditional_ABE_Instantiation_Ada
5910 Inst_Rep => Inst_Rep,
5913 In_State => New_In_State);
5915 end Process_Conditional_ABE_Instantiation;
5917 -----------------------------------------------
5918 -- Process_Conditional_ABE_Instantiation_Ada --
5919 -----------------------------------------------
5921 procedure Process_Conditional_ABE_Instantiation_Ada
5923 Inst_Rep : Scenario_Rep_Id;
5925 Gen_Rep : Target_Rep_Id;
5926 In_State : Processing_In_State)
5928 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep);
5929 Root : constant Node_Id := Root_Scenario;
5930 Unit_Id : constant Entity_Id := Unit (Gen_Rep);
5932 Check_OK : constant Boolean :=
5933 not In_State.Suppress_Checks
5934 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored
5935 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored
5936 and then Elaboration_Checks_OK (Inst_Rep)
5937 and then Elaboration_Checks_OK (Gen_Rep);
5938 -- A run-time ABE check may be installed only when both the instance
5939 -- and the generic have active elaboration checks and both are not
5940 -- ignored Ghost constructs.
5942 New_In_State : Processing_In_State := In_State;
5943 -- Each step of the Processing phase constitutes a new state
5946 -- Nothing to do when the instantiation is ABE-safe
5953 -- package body Gen is
5958 -- procedure Main is
5959 -- package Inst is new Gen (ABE); -- safe instantiation
5962 if Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then
5965 -- The instantiation and the generic body are both in the main unit
5967 -- If the root scenario appears prior to the generic body, then this
5968 -- is a possible ABE with respect to the root scenario.
5975 -- function A ... is
5977 -- if Some_Condition then
5979 -- package Inst is new Gen; -- instantiation site
5983 -- X : ... := A; -- root scenario
5985 -- package body Gen is -- generic body
5989 -- Y : ... := A; -- root scenario
5991 -- IMPORTANT: The instantiation of Gen is a possible ABE for X,
5992 -- but not for Y. Installing an unconditional ABE raise prior to
5993 -- the instance site would be wrong as it will fail for Y as well,
5994 -- but in Y's case the instantiation of Gen is never an ABE.
5996 elsif Present (Body_Decl)
5997 and then In_Extended_Main_Code_Unit (Body_Decl)
5999 if Earlier_In_Extended_Unit (Root, Body_Decl) then
6001 -- Do not emit any ABE diagnostics when a previous scenario in
6002 -- this traversal has suppressed elaboration warnings.
6004 if New_In_State.Suppress_Warnings then
6007 -- Do not emit any ABE diagnostics when the instantiation
6008 -- occurs in partial finalization context because this leads
6009 -- to unwanted noise.
6011 elsif New_In_State.Within_Partial_Finalization then
6014 -- Otherwise output the diagnostic
6018 ("??cannot instantiate & before body seen", Inst, Gen_Id);
6020 ("\Program_Error may be raised at run time", Inst);
6022 Output_Active_Scenarios (Inst, New_In_State);
6025 -- Install a conditional run-time ABE check to verify that the
6026 -- generic body has been elaborated prior to the instantiation.
6029 Install_Scenario_ABE_Check
6032 Targ_Rep => Gen_Rep,
6033 Disable => Inst_Rep);
6035 -- Update the state of the Processing phase to indicate that
6036 -- no implicit Elaborate[_All] pragma must be generated from
6044 -- function A ... is
6046 -- if Some_Condition then
6048 -- declare Inst is new Gen;
6054 -- package body Gen is
6056 -- External.Subp; -- imparts Elaborate_All
6059 -- If Some_Condition is True, then the ABE check will fail
6060 -- at runtime and the call to External.Subp will never take
6061 -- place, rendering the implicit Elaborate_All useless.
6063 -- If the value of Some_Condition is False, then the call
6064 -- to External.Subp will never take place, rendering the
6065 -- implicit Elaborate_All useless.
6067 New_In_State.Suppress_Implicit_Pragmas := True;
6071 -- Otherwise the generic body is not available in this compilation
6072 -- or it resides in an external unit. Install a run-time ABE check
6073 -- to verify that the generic body has been elaborated prior to the
6074 -- instantiation when the dynamic model is in effect.
6077 and then New_In_State.Processing = Dynamic_Model_Processing
6079 Install_Unit_ABE_Check
6082 Disable => Inst_Rep);
6085 -- Ensure that the unit with the generic body is elaborated prior
6086 -- to the main unit. No implicit pragma has to be generated if the
6087 -- instantiation has elaboration checks suppressed. This behaviour
6088 -- parallels that of the old ABE mechanism.
6090 if Elaboration_Checks_OK (Inst_Rep) then
6091 Ensure_Prior_Elaboration
6094 Prag_Nam => Name_Elaborate,
6095 In_State => New_In_State);
6097 end Process_Conditional_ABE_Instantiation_Ada;
6099 -------------------------------------------------
6100 -- Process_Conditional_ABE_Instantiation_SPARK --
6101 -------------------------------------------------
6103 procedure Process_Conditional_ABE_Instantiation_SPARK
6105 Inst_Rep : Scenario_Rep_Id;
6107 Gen_Rep : Target_Rep_Id;
6108 In_State : Processing_In_State)
6110 pragma Unreferenced (Inst_Rep);
6115 -- Ensure that a suitable elaboration model is in effect for SPARK
6116 -- rule verification.
6118 Check_SPARK_Model_In_Effect;
6120 -- A source instantiation imposes an Elaborate[_All] requirement
6121 -- on the context of the main unit. Determine whether the context
6122 -- has a pragma strong enough to meet the requirement. The check
6123 -- is orthogonal to the ABE ramifications of the instantiation.
6125 -- IMPORTANT: This check must be performed only when switch -gnatd.v
6126 -- (enforce SPARK elaboration rules in SPARK code) is active because
6127 -- the static model can ensure the prior elaboration of the unit
6128 -- which contains a body by installing an implicit Elaborate[_All]
6131 if Debug_Flag_Dot_V then
6132 if Nkind (Inst) = N_Package_Instantiation then
6133 Req_Nam := Name_Elaborate_All;
6135 Req_Nam := Name_Elaborate;
6138 Meet_Elaboration_Requirement
6142 In_State => In_State);
6144 -- Otherwise ensure that the unit with the target body is elaborated
6145 -- prior to the main unit.
6148 Ensure_Prior_Elaboration
6150 Unit_Id => Unit (Gen_Rep),
6151 Prag_Nam => Name_Elaborate,
6152 In_State => In_State);
6154 end Process_Conditional_ABE_Instantiation_SPARK;
6156 -------------------------------------------------
6157 -- Process_Conditional_ABE_Variable_Assignment --
6158 -------------------------------------------------
6160 procedure Process_Conditional_ABE_Variable_Assignment
6162 Asmt_Rep : Scenario_Rep_Id;
6163 In_State : Processing_In_State)
6166 Var_Id : constant Entity_Id := Target (Asmt_Rep);
6167 Var_Rep : constant Target_Rep_Id :=
6168 Target_Representation_Of (Var_Id, In_State);
6170 SPARK_Rules_On : constant Boolean :=
6171 SPARK_Mode_Of (Asmt_Rep) = Is_On
6172 and then SPARK_Mode_Of (Var_Rep) = Is_On;
6175 -- Output relevant information when switch -gnatel (info messages on
6176 -- implicit Elaborate[_All] pragmas) is in effect.
6178 if Elab_Info_Messages
6179 and then not In_State.Suppress_Info_Messages
6182 (Msg => "assignment to & during elaboration",
6186 In_SPARK => SPARK_Rules_On);
6189 -- The SPARK rules are in effect. These rules are applied regardless
6190 -- of whether switch -gnatd.v (enforce SPARK elaboration rules in
6191 -- SPARK code) is in effect because the static model cannot ensure
6192 -- safe assignment of variables.
6194 if SPARK_Rules_On then
6195 Process_Conditional_ABE_Variable_Assignment_SPARK
6197 Asmt_Rep => Asmt_Rep,
6200 In_State => In_State);
6202 -- Otherwise the Ada rules are in effect
6205 Process_Conditional_ABE_Variable_Assignment_Ada
6207 Asmt_Rep => Asmt_Rep,
6210 In_State => In_State);
6212 end Process_Conditional_ABE_Variable_Assignment;
6214 -----------------------------------------------------
6215 -- Process_Conditional_ABE_Variable_Assignment_Ada --
6216 -----------------------------------------------------
6218 procedure Process_Conditional_ABE_Variable_Assignment_Ada
6220 Asmt_Rep : Scenario_Rep_Id;
6222 Var_Rep : Target_Rep_Id;
6223 In_State : Processing_In_State)
6225 pragma Unreferenced (Asmt_Rep);
6227 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep);
6228 Unit_Id : constant Entity_Id := Unit (Var_Rep);
6231 -- Emit a warning when an uninitialized variable declared in a
6232 -- package spec without a pragma Elaborate_Body is initialized
6233 -- by elaboration code within the corresponding body.
6235 if Is_Elaboration_Warnings_OK_Id (Var_Id)
6236 and then not Is_Initialized (Var_Decl)
6237 and then not Has_Pragma_Elaborate_Body (Unit_Id)
6239 -- Do not emit any ABE diagnostics when a previous scenario in
6240 -- this traversal has suppressed elaboration warnings.
6242 if not In_State.Suppress_Warnings then
6244 ("??variable & can be accessed by clients before this "
6245 & "initialization", Asmt, Var_Id);
6248 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
6249 & "initialization", Asmt, Unit_Id);
6251 Output_Active_Scenarios (Asmt, In_State);
6254 -- Generate an implicit Elaborate_Body in the spec
6256 Set_Elaborate_Body_Desirable (Unit_Id);
6258 end Process_Conditional_ABE_Variable_Assignment_Ada;
6260 -------------------------------------------------------
6261 -- Process_Conditional_ABE_Variable_Assignment_SPARK --
6262 -------------------------------------------------------
6264 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
6266 Asmt_Rep : Scenario_Rep_Id;
6268 Var_Rep : Target_Rep_Id;
6269 In_State : Processing_In_State)
6271 pragma Unreferenced (Asmt_Rep);
6273 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep);
6274 Unit_Id : constant Entity_Id := Unit (Var_Rep);
6277 -- Ensure that a suitable elaboration model is in effect for SPARK
6278 -- rule verification.
6280 Check_SPARK_Model_In_Effect;
6282 -- Do not emit any ABE diagnostics when a previous scenario in this
6283 -- traversal has suppressed elaboration warnings.
6285 if In_State.Suppress_Warnings then
6288 -- Emit an error when an initialized variable declared in a package
6289 -- spec that is missing pragma Elaborate_Body is further modified by
6290 -- elaboration code within the corresponding body.
6292 elsif Is_Elaboration_Warnings_OK_Id (Var_Id)
6293 and then Is_Initialized (Var_Decl)
6294 and then not Has_Pragma_Elaborate_Body (Unit_Id)
6297 ("variable & modified by elaboration code in package body",
6301 ("\add pragma ""Elaborate_Body"" to spec & to ensure full "
6302 & "initialization", Asmt, Unit_Id);
6304 Output_Active_Scenarios (Asmt, In_State);
6306 end Process_Conditional_ABE_Variable_Assignment_SPARK;
6308 ------------------------------------------------
6309 -- Process_Conditional_ABE_Variable_Reference --
6310 ------------------------------------------------
6312 procedure Process_Conditional_ABE_Variable_Reference
6314 Ref_Rep : Scenario_Rep_Id;
6315 In_State : Processing_In_State)
6317 Var_Id : constant Entity_Id := Target (Ref);
6318 Var_Rep : Target_Rep_Id;
6319 Unit_Id : Entity_Id;
6322 -- Nothing to do when the variable reference is not a read
6324 if not Is_Read_Reference (Ref_Rep) then
6328 Var_Rep := Target_Representation_Of (Var_Id, In_State);
6329 Unit_Id := Unit (Var_Rep);
6331 -- Output relevant information when switch -gnatel (info messages on
6332 -- implicit Elaborate[_All] pragmas) is in effect.
6334 if Elab_Info_Messages
6335 and then not In_State.Suppress_Info_Messages
6338 (Msg => "read of variable & during elaboration",
6345 -- Nothing to do when the variable appears within the main unit
6346 -- because diagnostics on reads are relevant only for external
6349 if Is_Same_Unit (Unit_Id, Main_Unit_Entity) then
6352 -- Nothing to do when the variable is already initialized. Note that
6353 -- the variable may be further modified by the external unit.
6355 elsif Is_Initialized (Variable_Declaration (Var_Rep)) then
6358 -- Nothing to do when the external unit guarantees the initialization
6359 -- of the variable by means of pragma Elaborate_Body.
6361 elsif Has_Pragma_Elaborate_Body (Unit_Id) then
6364 -- A variable read imposes an Elaborate requirement on the context of
6365 -- the main unit. Determine whether the context has a pragma strong
6366 -- enough to meet the requirement.
6369 Meet_Elaboration_Requirement
6372 Req_Nam => Name_Elaborate,
6373 In_State => In_State);
6375 end Process_Conditional_ABE_Variable_Reference;
6377 -----------------------------------
6378 -- Traverse_Conditional_ABE_Body --
6379 -----------------------------------
6381 procedure Traverse_Conditional_ABE_Body
6383 In_State : Processing_In_State)
6388 Requires_Processing => Is_Conditional_ABE_Scenario'Access,
6389 Processor => Process_Conditional_ABE'Access,
6390 In_State => In_State);
6391 end Traverse_Conditional_ABE_Body;
6392 end Conditional_ABE_Processor;
6398 procedure Destroy (NE : in out Node_Or_Entity_Id) is
6399 pragma Unreferenced (NE);
6408 package body Diagnostics is
6414 procedure Elab_Msg_NE
6421 function Prefix return String;
6422 pragma Inline (Prefix);
6423 -- Obtain the prefix of the message
6425 function Suffix return String;
6426 pragma Inline (Suffix);
6427 -- Obtain the suffix of the message
6433 function Prefix return String is
6446 function Suffix return String is
6455 -- Start of processing for Elab_Msg_NE
6458 Error_Msg_NE (Prefix & Msg & Suffix, N, Id);
6467 Subp_Id : Entity_Id;
6471 procedure Info_Accept_Alternative;
6472 pragma Inline (Info_Accept_Alternative);
6473 -- Output information concerning an accept alternative
6475 procedure Info_Simple_Call;
6476 pragma Inline (Info_Simple_Call);
6477 -- Output information concerning the call
6479 procedure Info_Type_Actions (Action : String);
6480 pragma Inline (Info_Type_Actions);
6481 -- Output information concerning action Action of a type
6483 procedure Info_Verification_Call
6487 pragma Inline (Info_Verification_Call);
6488 -- Output information concerning the verification of predicate Pred
6489 -- applied to related entity Id with kind Id_Kind.
6491 -----------------------------
6492 -- Info_Accept_Alternative --
6493 -----------------------------
6495 procedure Info_Accept_Alternative is
6496 Entry_Id : constant Entity_Id := Receiving_Entry (Subp_Id);
6497 pragma Assert (Present (Entry_Id));
6501 (Msg => "accept for entry & during elaboration",
6504 Info_Msg => Info_Msg,
6505 In_SPARK => In_SPARK);
6506 end Info_Accept_Alternative;
6508 ----------------------
6509 -- Info_Simple_Call --
6510 ----------------------
6512 procedure Info_Simple_Call is
6515 (Msg => "call to & during elaboration",
6518 Info_Msg => Info_Msg,
6519 In_SPARK => In_SPARK);
6520 end Info_Simple_Call;
6522 -----------------------
6523 -- Info_Type_Actions --
6524 -----------------------
6526 procedure Info_Type_Actions (Action : String) is
6527 Typ : constant Entity_Id := First_Formal_Type (Subp_Id);
6528 pragma Assert (Present (Typ));
6532 (Msg => Action & " actions for type & during elaboration",
6535 Info_Msg => Info_Msg,
6536 In_SPARK => In_SPARK);
6537 end Info_Type_Actions;
6539 ----------------------------
6540 -- Info_Verification_Call --
6541 ----------------------------
6543 procedure Info_Verification_Call
6548 pragma Assert (Present (Id));
6553 "verification of " & Pred & " of " & Id_Kind & " & during "
6557 Info_Msg => Info_Msg,
6558 In_SPARK => In_SPARK);
6559 end Info_Verification_Call;
6561 -- Start of processing for Info_Call
6564 -- Do not output anything for targets defined in internal units
6565 -- because this creates noise.
6567 if not In_Internal_Unit (Subp_Id) then
6569 -- Accept alternative
6571 if Is_Accept_Alternative_Proc (Subp_Id) then
6572 Info_Accept_Alternative;
6576 elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then
6577 Info_Type_Actions ("adjustment");
6579 -- Default_Initial_Condition
6581 elsif Is_Default_Initial_Condition_Proc (Subp_Id) then
6582 Info_Verification_Call
6583 (Pred => "Default_Initial_Condition",
6584 Id => First_Formal_Type (Subp_Id),
6589 elsif Is_Protected_Entry (Subp_Id) then
6592 -- Task entry calls are never processed because the entry being
6593 -- invoked does not have a corresponding "body", it has a select.
6595 elsif Is_Task_Entry (Subp_Id) then
6600 elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then
6601 Info_Type_Actions ("finalization");
6603 -- Calls to _Finalizer procedures must not appear in the output
6604 -- because this creates confusing noise.
6606 elsif Is_Finalizer_Proc (Subp_Id) then
6609 -- Initial_Condition
6611 elsif Is_Initial_Condition_Proc (Subp_Id) then
6612 Info_Verification_Call
6613 (Pred => "Initial_Condition",
6614 Id => Find_Enclosing_Scope (Call),
6615 Id_Kind => "package");
6619 elsif Is_Init_Proc (Subp_Id)
6620 or else Is_TSS (Subp_Id, TSS_Deep_Initialize)
6622 Info_Type_Actions ("initialization");
6626 elsif Is_Invariant_Proc (Subp_Id) then
6627 Info_Verification_Call
6628 (Pred => "invariants",
6629 Id => First_Formal_Type (Subp_Id),
6632 -- Partial invariant calls must not appear in the output because
6633 -- this creates confusing noise.
6635 elsif Is_Partial_Invariant_Proc (Subp_Id) then
6640 elsif Is_Postconditions_Proc (Subp_Id) then
6641 Info_Verification_Call
6642 (Pred => "postconditions",
6643 Id => Find_Enclosing_Scope (Call),
6644 Id_Kind => "subprogram");
6646 -- Subprograms must come last because some of the previous cases
6647 -- fall under this category.
6649 elsif Ekind (Subp_Id) = E_Function then
6652 elsif Ekind (Subp_Id) = E_Procedure then
6656 pragma Assert (False);
6662 ------------------------
6663 -- Info_Instantiation --
6664 ------------------------
6666 procedure Info_Instantiation
6674 (Msg => "instantiation of & during elaboration",
6677 Info_Msg => Info_Msg,
6678 In_SPARK => In_SPARK);
6679 end Info_Instantiation;
6681 -----------------------------
6682 -- Info_Variable_Reference --
6683 -----------------------------
6685 procedure Info_Variable_Reference
6692 if Is_Read (Ref) then
6694 (Msg => "read of variable & during elaboration",
6697 Info_Msg => Info_Msg,
6698 In_SPARK => In_SPARK);
6700 end Info_Variable_Reference;
6703 ---------------------------------
6704 -- Early_Call_Region_Processor --
6705 ---------------------------------
6707 package body Early_Call_Region_Processor is
6709 ---------------------
6710 -- Data structures --
6711 ---------------------
6713 -- The following map relates early call regions to subprogram bodies
6715 procedure Destroy (N : in out Node_Id);
6718 package ECR_Map is new Dynamic_Hash_Tables
6719 (Key_Type => Entity_Id,
6720 Value_Type => Node_Id,
6722 Expansion_Threshold => 1.5,
6723 Expansion_Factor => 2,
6724 Compression_Threshold => 0.3,
6725 Compression_Factor => 2,
6727 Destroy_Value => Destroy,
6730 Early_Call_Regions_Map : ECR_Map.Dynamic_Hash_Table := ECR_Map.Nil;
6732 -----------------------
6733 -- Local subprograms --
6734 -----------------------
6736 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id;
6737 pragma Inline (Early_Call_Region);
6738 -- Obtain the early call region associated with entry or subprogram body
6741 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id);
6742 pragma Inline (Set_Early_Call_Region);
6743 -- Associate an early call region with begins at construct Start with
6744 -- entry or subprogram body Body_Id.
6750 procedure Destroy (N : in out Node_Id) is
6751 pragma Unreferenced (N);
6756 -----------------------
6757 -- Early_Call_Region --
6758 -----------------------
6760 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is
6761 pragma Assert (Present (Body_Id));
6763 return ECR_Map.Get (Early_Call_Regions_Map, Body_Id);
6764 end Early_Call_Region;
6766 ------------------------------------------
6767 -- Finalize_Early_Call_Region_Processor --
6768 ------------------------------------------
6770 procedure Finalize_Early_Call_Region_Processor is
6772 ECR_Map.Destroy (Early_Call_Regions_Map);
6773 end Finalize_Early_Call_Region_Processor;
6775 ----------------------------
6776 -- Find_Early_Call_Region --
6777 ----------------------------
6779 function Find_Early_Call_Region
6780 (Body_Decl : Node_Id;
6781 Assume_Elab_Body : Boolean := False;
6782 Skip_Memoization : Boolean := False) return Node_Id
6784 -- NOTE: The routines within Find_Early_Call_Region are intentionally
6785 -- unnested to avoid deep indentation of code.
6787 ECR_Found : exception;
6788 -- This exception is raised when the early call region has been found
6790 Start : Node_Id := Empty;
6791 -- The start of the early call region. This variable is updated by
6792 -- the various nested routines. Due to the use of exceptions, the
6793 -- variable must be global to the nested routines.
6795 -- The algorithm implemented in this routine attempts to find the
6796 -- early call region of a subprogram body by inspecting constructs
6797 -- in reverse declarative order, while navigating the tree. The
6798 -- algorithm consists of an Inspection phase and Advancement phase.
6799 -- The pseudocode is as follows:
6803 -- advancement phase
6806 -- The infinite loop is terminated by raising exception ECR_Found.
6807 -- The algorithm utilizes two pointers, Curr and Start, to represent
6808 -- the current construct to inspect and the start of the early call
6811 -- IMPORTANT: The algorithm must maintain the following invariant at
6812 -- all time for it to function properly:
6814 -- A nested construct is entered only when it contains suitable
6817 -- This guarantees that leaving a nested or encapsulating construct
6818 -- functions properly.
6820 -- The Inspection phase determines whether the current construct is
6821 -- non-preelaborable, and if it is, the algorithm terminates.
6823 -- The Advancement phase walks the tree in reverse declarative order,
6824 -- while entering and leaving nested and encapsulating constructs. It
6825 -- may also terminate the elaborithm. There are several special cases
6832 -- <construct N-1> <- Curr
6833 -- <construct N> <- Start
6834 -- <subprogram body>
6836 -- In the general case, a declarative or statement list is traversed
6837 -- in reverse order where Curr is the lead pointer, and Start is the
6838 -- last preelaborable construct.
6840 -- 2) Entering handled bodies
6842 -- package body Nested is <- Curr (2.3)
6843 -- <declarations> <- Curr (2.2)
6845 -- <statements> <- Curr (2.1)
6847 -- <construct> <- Start
6849 -- In this case, the algorithm enters a handled body by starting from
6850 -- the last statement (2.1), or the last declaration (2.2), or the
6851 -- body is consumed (2.3) because it is empty and thus preelaborable.
6853 -- 3) Entering package declarations
6855 -- package Nested is <- Curr (2.3)
6856 -- <visible declarations> <- Curr (2.2)
6858 -- <private declarations> <- Curr (2.1)
6860 -- <construct> <- Start
6862 -- In this case, the algorithm enters a package declaration by
6863 -- starting from the last private declaration (2.1), the last visible
6864 -- declaration (2.2), or the package is consumed (2.3) because it is
6865 -- empty and thus preelaborable.
6867 -- 4) Transitioning from list to list of the same construct
6869 -- Certain constructs have two eligible lists. The algorithm must
6870 -- thus transition from the second to the first list when the second
6871 -- list is exhausted.
6873 -- declare <- Curr (4.2)
6874 -- <declarations> <- Curr (4.1)
6876 -- <statements> <- Start
6879 -- In this case, the algorithm has exhausted the second list (the
6880 -- statements in the example above), and continues with the last
6881 -- declaration (4.1) or the construct is consumed (4.2) because it
6882 -- contains only preelaborable code.
6884 -- 5) Transitioning from list to construct
6886 -- tack body Task is <- Curr (5.1)
6888 -- <construct 1> <- Start
6890 -- In this case, the algorithm has exhausted a list, Curr is Empty,
6891 -- and the owner of the list is consumed (5.1).
6893 -- 6) Transitioning from unit to unit
6895 -- A package body with a spec subject to pragma Elaborate_Body
6896 -- extends the possible range of the early call region to the package
6899 -- package Pack is <- Curr (6.3)
6900 -- pragma Elaborate_Body; <- Curr (6.2)
6901 -- <visible declarations> <- Curr (6.2)
6903 -- <private declarations> <- Curr (6.1)
6906 -- package body Pack is <- Curr, Start
6908 -- In this case, the algorithm has reached a package body compilation
6909 -- unit whose spec is subject to pragma Elaborate_Body, or the caller
6910 -- of the algorithm has specified this behavior. This transition is
6911 -- equivalent to 3).
6913 -- 7) Transitioning from unit to termination
6915 -- Reaching a compilation unit always terminates the algorithm as
6916 -- there are no more lists to examine. This must take case 6) into
6919 -- 8) Transitioning from subunit to stub
6921 -- package body Pack is separate; <- Curr (8.1)
6924 -- package body Pack is <- Curr, Start
6926 -- Reaching a subunit continues the search from the corresponding
6929 procedure Advance (Curr : in out Node_Id);
6930 pragma Inline (Advance);
6931 -- Update the Curr and Start pointers depending on their location
6932 -- in the tree to the next eligible construct. This routine raises
6935 procedure Enter_Handled_Body (Curr : in out Node_Id);
6936 pragma Inline (Enter_Handled_Body);
6937 -- Update the Curr and Start pointers to enter a nested handled body
6938 -- if applicable. This routine raises ECR_Found.
6940 procedure Enter_Package_Declaration (Curr : in out Node_Id);
6941 pragma Inline (Enter_Package_Declaration);
6942 -- Update the Curr and Start pointers to enter a nested package spec
6943 -- if applicable. This routine raises ECR_Found.
6945 function Find_ECR (N : Node_Id) return Node_Id;
6946 pragma Inline (Find_ECR);
6947 -- Find an early call region starting from arbitrary node N
6949 function Has_Suitable_Construct (List : List_Id) return Boolean;
6950 pragma Inline (Has_Suitable_Construct);
6951 -- Determine whether list List contains a suitable construct for
6952 -- inclusion into an early call region.
6954 procedure Include (N : Node_Id; Curr : out Node_Id);
6955 pragma Inline (Include);
6956 -- Update the Curr and Start pointers to include arbitrary construct
6957 -- N in the early call region. This routine raises ECR_Found.
6959 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean;
6960 pragma Inline (Is_OK_Preelaborable_Construct);
6961 -- Determine whether arbitrary node N denotes a preelaboration-safe
6964 function Is_Suitable_Construct (N : Node_Id) return Boolean;
6965 pragma Inline (Is_Suitable_Construct);
6966 -- Determine whether arbitrary node N denotes a suitable construct
6967 -- for inclusion into the early call region.
6969 procedure Transition_Body_Declarations
6971 Curr : out Node_Id);
6972 pragma Inline (Transition_Body_Declarations);
6973 -- Update the Curr and Start pointers when construct Bod denotes a
6974 -- block statement or a suitable body. This routine raises ECR_Found.
6976 procedure Transition_Handled_Statements
6978 Curr : out Node_Id);
6979 pragma Inline (Transition_Handled_Statements);
6980 -- Update the Curr and Start pointers when node HSS denotes a handled
6981 -- sequence of statements. This routine raises ECR_Found.
6983 procedure Transition_Spec_Declarations
6985 Curr : out Node_Id);
6986 pragma Inline (Transition_Spec_Declarations);
6987 -- Update the Curr and Start pointers when construct Spec denotes
6988 -- a concurrent definition or a package spec. This routine raises
6991 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id);
6992 pragma Inline (Transition_Unit);
6993 -- Update the Curr and Start pointers when node Unit denotes a
6994 -- potential compilation unit. This routine raises ECR_Found.
7000 procedure Advance (Curr : in out Node_Id) is
7004 -- Curr denotes one of the following cases upon entry into this
7007 -- * Empty - There is no current construct when a declarative or
7008 -- a statement list has been exhausted. This does not indicate
7009 -- that the early call region has been computed as it is still
7010 -- possible to transition to another list.
7012 -- * Encapsulator - The current construct wraps declarations
7013 -- and/or statements. This indicates that the early call
7014 -- region may extend within the nested construct.
7016 -- * Preelaborable - The current construct is preelaborable
7017 -- because Find_ECR would not invoke Advance if this was not
7020 -- The current construct is an encapsulator or is preelaborable
7022 if Present (Curr) then
7024 -- Enter encapsulators by inspecting their declarations and/or
7027 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then
7028 Enter_Handled_Body (Curr);
7030 elsif Nkind (Curr) = N_Package_Declaration then
7031 Enter_Package_Declaration (Curr);
7033 -- Early call regions have a property which can be exploited to
7034 -- optimize the algorithm.
7036 -- <preceding subprogram body>
7037 -- <preelaborable construct 1>
7039 -- <preelaborable construct N>
7040 -- <initiating subprogram body>
7042 -- If a traversal initiated from a subprogram body reaches a
7043 -- preceding subprogram body, then both bodies share the same
7044 -- early call region.
7046 -- The property results in the following desirable effects:
7048 -- * If the preceding body already has an early call region,
7049 -- then the initiating body can reuse it. This minimizes the
7050 -- amount of processing performed by the algorithm.
7052 -- * If the preceding body lack an early call region, then the
7053 -- algorithm can compute the early call region, and reuse it
7054 -- for the initiating body. This processing performs the same
7055 -- amount of work, but has the beneficial effect of computing
7056 -- the early call regions of all preceding bodies.
7058 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then
7060 Find_Early_Call_Region
7062 Assume_Elab_Body => Assume_Elab_Body,
7063 Skip_Memoization => Skip_Memoization);
7067 -- Otherwise current construct is preelaborable. Unpdate the
7068 -- early call region to include it.
7071 Include (Curr, Curr);
7074 -- Otherwise the current construct is missing, indicating that the
7075 -- current list has been exhausted. Depending on the context of
7076 -- the list, several transitions are possible.
7079 -- The invariant of the algorithm ensures that Curr and Start
7080 -- are at the same level of nesting at the point of transition.
7081 -- The algorithm can determine which list the traversal came
7082 -- from by examining Start.
7084 Context := Parent (Start);
7086 -- Attempt the following transitions:
7088 -- private declarations -> visible declarations
7089 -- private declarations -> upper level
7090 -- private declarations -> terminate
7091 -- visible declarations -> upper level
7092 -- visible declarations -> terminate
7094 if Nkind_In (Context, N_Package_Specification,
7095 N_Protected_Definition,
7098 Transition_Spec_Declarations (Context, Curr);
7100 -- Attempt the following transitions:
7102 -- statements -> declarations
7103 -- statements -> upper level
7104 -- statements -> corresponding package spec (Elab_Body)
7105 -- statements -> terminate
7107 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
7108 Transition_Handled_Statements (Context, Curr);
7110 -- Attempt the following transitions:
7112 -- declarations -> upper level
7113 -- declarations -> corresponding package spec (Elab_Body)
7114 -- declarations -> terminate
7116 elsif Nkind_In (Context, N_Block_Statement,
7123 Transition_Body_Declarations (Context, Curr);
7125 -- Otherwise it is not possible to transition. Stop the search
7126 -- because there are no more declarations or statements to
7135 --------------------------
7136 -- Enter_Handled_Body --
7137 --------------------------
7139 procedure Enter_Handled_Body (Curr : in out Node_Id) is
7140 Decls : constant List_Id := Declarations (Curr);
7141 HSS : constant Node_Id := Handled_Statement_Sequence (Curr);
7142 Stmts : List_Id := No_List;
7145 if Present (HSS) then
7146 Stmts := Statements (HSS);
7149 -- The handled body has a non-empty statement sequence. The
7150 -- construct to inspect is the last statement.
7152 if Has_Suitable_Construct (Stmts) then
7153 Curr := Last (Stmts);
7155 -- The handled body lacks statements, but has non-empty
7156 -- declarations. The construct to inspect is the last declaration.
7158 elsif Has_Suitable_Construct (Decls) then
7159 Curr := Last (Decls);
7161 -- Otherwise the handled body lacks both declarations and
7162 -- statements. The construct to inspect is the node which precedes
7163 -- the handled body. Update the early call region to include the
7167 Include (Curr, Curr);
7169 end Enter_Handled_Body;
7171 -------------------------------
7172 -- Enter_Package_Declaration --
7173 -------------------------------
7175 procedure Enter_Package_Declaration (Curr : in out Node_Id) is
7176 Pack_Spec : constant Node_Id := Specification (Curr);
7177 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec);
7178 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec);
7181 -- The package has a non-empty private declarations. The construct
7182 -- to inspect is the last private declaration.
7184 if Has_Suitable_Construct (Prv_Decls) then
7185 Curr := Last (Prv_Decls);
7187 -- The package lacks private declarations, but has non-empty
7188 -- visible declarations. In this case the construct to inspect
7189 -- is the last visible declaration.
7191 elsif Has_Suitable_Construct (Vis_Decls) then
7192 Curr := Last (Vis_Decls);
7194 -- Otherwise the package lacks any declarations. The construct
7195 -- to inspect is the node which precedes the package. Update the
7196 -- early call region to include the package declaration.
7199 Include (Curr, Curr);
7201 end Enter_Package_Declaration;
7207 function Find_ECR (N : Node_Id) return Node_Id is
7211 -- The early call region starts at N
7216 -- Inspect each node in reverse declarative order while going in
7217 -- and out of nested and enclosing constructs. Note that the only
7218 -- way to terminate this infinite loop is to raise ECR_Found.
7221 -- The current construct is not preelaboration-safe. Terminate
7225 and then not Is_OK_Preelaborable_Construct (Curr)
7230 -- Advance to the next suitable construct. This may terminate
7231 -- the traversal by raising ECR_Found.
7241 ----------------------------
7242 -- Has_Suitable_Construct --
7243 ----------------------------
7245 function Has_Suitable_Construct (List : List_Id) return Boolean is
7249 -- Examine the list in reverse declarative order, looking for a
7250 -- suitable construct.
7252 if Present (List) then
7253 Item := Last (List);
7254 while Present (Item) loop
7255 if Is_Suitable_Construct (Item) then
7264 end Has_Suitable_Construct;
7270 procedure Include (N : Node_Id; Curr : out Node_Id) is
7274 -- The input node is a compilation unit. This terminates the
7275 -- search because there are no more lists to inspect and there are
7276 -- no more enclosing constructs to climb up to. The transitions
7279 -- private declarations -> terminate
7280 -- visible declarations -> terminate
7281 -- statements -> terminate
7282 -- declarations -> terminate
7284 if Nkind (Parent (Start)) = N_Compilation_Unit then
7287 -- Otherwise the input node is still within some list
7290 Curr := Prev (Start);
7294 -----------------------------------
7295 -- Is_OK_Preelaborable_Construct --
7296 -----------------------------------
7298 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is
7300 -- Assignment statements are acceptable as long as they were
7301 -- produced by the ABE mechanism to update elaboration flags.
7303 if Nkind (N) = N_Assignment_Statement then
7304 return Is_Elaboration_Code (N);
7306 -- Block statements are acceptable even though they directly
7307 -- violate preelaborability. The intention is not to penalize
7308 -- the early call region when a block contains only preelaborable
7312 -- Val : constant Integer := 1;
7314 -- pragma Assert (Val = 1);
7318 -- Note that the Advancement phase does enter blocks, and will
7319 -- detect any non-preelaborable declarations or statements within.
7321 elsif Nkind (N) = N_Block_Statement then
7325 -- Otherwise the construct must be preelaborable. The check must
7326 -- take the syntactic and semantic structure of the construct. DO
7327 -- NOT use Is_Preelaborable_Construct here.
7329 return not Is_Non_Preelaborable_Construct (N);
7330 end Is_OK_Preelaborable_Construct;
7332 ---------------------------
7333 -- Is_Suitable_Construct --
7334 ---------------------------
7336 function Is_Suitable_Construct (N : Node_Id) return Boolean is
7337 Context : constant Node_Id := Parent (N);
7340 -- An internally-generated statement sequence which contains only
7341 -- a single null statement is not a suitable construct because it
7342 -- is a byproduct of the parser. Such a null statement should be
7343 -- excluded from the early call region because it carries the
7344 -- source location of the "end" keyword, and may lead to confusing
7347 if Nkind (N) = N_Null_Statement
7348 and then not Comes_From_Source (N)
7349 and then Present (Context)
7350 and then Nkind (Context) = N_Handled_Sequence_Of_Statements
7355 -- Otherwise only constructs which correspond to pure Ada
7356 -- constructs are considered suitable.
7361 | N_Freeze_Generic_Entity
7362 | N_Implicit_Label_Declaration
7364 | N_Pop_Constraint_Error_Label
7365 | N_Pop_Program_Error_Label
7366 | N_Pop_Storage_Error_Label
7367 | N_Push_Constraint_Error_Label
7368 | N_Push_Program_Error_Label
7369 | N_Push_Storage_Error_Label
7370 | N_SCIL_Dispatch_Table_Tag_Init
7371 | N_SCIL_Dispatching_Call
7372 | N_SCIL_Membership_Test
7373 | N_Variable_Reference_Marker
7380 end Is_Suitable_Construct;
7382 ----------------------------------
7383 -- Transition_Body_Declarations --
7384 ----------------------------------
7386 procedure Transition_Body_Declarations
7390 Decls : constant List_Id := Declarations (Bod);
7393 -- The search must come from the declarations of the body
7396 (Is_Non_Empty_List (Decls)
7397 and then List_Containing (Start) = Decls);
7399 -- The search finished inspecting the declarations. The construct
7400 -- to inspect is the node which precedes the handled body, unless
7401 -- the body is a compilation unit. The transitions are:
7403 -- declarations -> upper level
7404 -- declarations -> corresponding package spec (Elab_Body)
7405 -- declarations -> terminate
7407 Transition_Unit (Bod, Curr);
7408 end Transition_Body_Declarations;
7410 -----------------------------------
7411 -- Transition_Handled_Statements --
7412 -----------------------------------
7414 procedure Transition_Handled_Statements
7418 Bod : constant Node_Id := Parent (HSS);
7419 Decls : constant List_Id := Declarations (Bod);
7420 Stmts : constant List_Id := Statements (HSS);
7423 -- The search must come from the statements of certain bodies or
7426 pragma Assert (Nkind_In (Bod, N_Block_Statement,
7433 -- The search must come from the statements of the handled
7437 (Is_Non_Empty_List (Stmts)
7438 and then List_Containing (Start) = Stmts);
7440 -- The search finished inspecting the statements. The handled body
7441 -- has non-empty declarations. The construct to inspect is the
7442 -- last declaration. The transitions are:
7444 -- statements -> declarations
7446 if Has_Suitable_Construct (Decls) then
7447 Curr := Last (Decls);
7449 -- Otherwise the handled body lacks declarations. The construct to
7450 -- inspect is the node which precedes the handled body, unless the
7451 -- body is a compilation unit. The transitions are:
7453 -- statements -> upper level
7454 -- statements -> corresponding package spec (Elab_Body)
7455 -- statements -> terminate
7458 Transition_Unit (Bod, Curr);
7460 end Transition_Handled_Statements;
7462 ----------------------------------
7463 -- Transition_Spec_Declarations --
7464 ----------------------------------
7466 procedure Transition_Spec_Declarations
7470 Prv_Decls : constant List_Id := Private_Declarations (Spec);
7471 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
7474 pragma Assert (Present (Start) and then Is_List_Member (Start));
7476 -- The search came from the private declarations and finished
7477 -- their inspection.
7479 if Has_Suitable_Construct (Prv_Decls)
7480 and then List_Containing (Start) = Prv_Decls
7482 -- The context has non-empty visible declarations. The node to
7483 -- inspect is the last visible declaration. The transitions
7486 -- private declarations -> visible declarations
7488 if Has_Suitable_Construct (Vis_Decls) then
7489 Curr := Last (Vis_Decls);
7491 -- Otherwise the context lacks visible declarations. The
7492 -- construct to inspect is the node which precedes the context
7493 -- unless the context is a compilation unit. The transitions
7496 -- private declarations -> upper level
7497 -- private declarations -> terminate
7500 Transition_Unit (Parent (Spec), Curr);
7503 -- The search came from the visible declarations and finished
7504 -- their inspections. The construct to inspect is the node which
7505 -- precedes the context, unless the context is a compilaton unit.
7506 -- The transitions are:
7508 -- visible declarations -> upper level
7509 -- visible declarations -> terminate
7511 elsif Has_Suitable_Construct (Vis_Decls)
7512 and then List_Containing (Start) = Vis_Decls
7514 Transition_Unit (Parent (Spec), Curr);
7516 -- At this point both declarative lists are empty, but the
7517 -- traversal still came from within the spec. This indicates
7518 -- that the invariant of the algorithm has been violated.
7521 pragma Assert (False);
7524 end Transition_Spec_Declarations;
7526 ---------------------
7527 -- Transition_Unit --
7528 ---------------------
7530 procedure Transition_Unit
7534 Context : constant Node_Id := Parent (Unit);
7537 -- The unit is a compilation unit. This terminates the search
7538 -- because there are no more lists to inspect and there are no
7539 -- more enclosing constructs to climb up to.
7541 if Nkind (Context) = N_Compilation_Unit then
7543 -- A package body with a corresponding spec subject to pragma
7544 -- Elaborate_Body is an exception to the above. The annotation
7545 -- allows the search to continue into the package declaration.
7546 -- The transitions are:
7548 -- statements -> corresponding package spec (Elab_Body)
7549 -- declarations -> corresponding package spec (Elab_Body)
7551 if Nkind (Unit) = N_Package_Body
7552 and then (Assume_Elab_Body
7553 or else Has_Pragma_Elaborate_Body
7554 (Corresponding_Spec (Unit)))
7556 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit));
7557 Enter_Package_Declaration (Curr);
7559 -- Otherwise terminate the search. The transitions are:
7561 -- private declarations -> terminate
7562 -- visible declarations -> terminate
7563 -- statements -> terminate
7564 -- declarations -> terminate
7570 -- The unit is a subunit. The construct to inspect is the node
7571 -- which precedes the corresponding stub. Update the early call
7572 -- region to include the unit.
7574 elsif Nkind (Context) = N_Subunit then
7576 Curr := Corresponding_Stub (Context);
7578 -- Otherwise the unit is nested. The construct to inspect is the
7579 -- node which precedes the unit. Update the early call region to
7580 -- include the unit.
7583 Include (Unit, Curr);
7585 end Transition_Unit;
7589 Body_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl);
7592 -- Start of processing for Find_Early_Call_Region
7595 -- The caller demands the start of the early call region without
7596 -- saving or retrieving it to/from internal data structures.
7598 if Skip_Memoization then
7599 Region := Find_ECR (Body_Decl);
7604 -- Check whether the early call region of the subprogram body is
7607 Region := Early_Call_Region (Body_Id);
7610 Region := Find_ECR (Body_Decl);
7612 -- Associate the early call region with the subprogram body in
7613 -- case other scenarios need it.
7615 Set_Early_Call_Region (Body_Id, Region);
7619 -- A subprogram body must always have an early call region
7621 pragma Assert (Present (Region));
7624 end Find_Early_Call_Region;
7626 --------------------------------------------
7627 -- Initialize_Early_Call_Region_Processor --
7628 --------------------------------------------
7630 procedure Initialize_Early_Call_Region_Processor is
7632 Early_Call_Regions_Map := ECR_Map.Create (100);
7633 end Initialize_Early_Call_Region_Processor;
7635 ---------------------------
7636 -- Set_Early_Call_Region --
7637 ---------------------------
7639 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is
7640 pragma Assert (Present (Body_Id));
7641 pragma Assert (Present (Start));
7644 ECR_Map.Put (Early_Call_Regions_Map, Body_Id, Start);
7645 end Set_Early_Call_Region;
7646 end Early_Call_Region_Processor;
7648 ----------------------
7649 -- Elaborated_Units --
7650 ----------------------
7652 package body Elaborated_Units is
7658 -- The following type idenfities the elaboration attributes of a unit
7660 type Elaboration_Attributes_Id is new Natural;
7662 No_Elaboration_Attributes : constant Elaboration_Attributes_Id :=
7663 Elaboration_Attributes_Id'First;
7664 First_Elaboration_Attributes : constant Elaboration_Attributes_Id :=
7665 No_Elaboration_Attributes + 1;
7667 -- The following type represents the elaboration attributes of a unit
7669 type Elaboration_Attributes_Record is record
7670 Elab_Pragma : Node_Id := Empty;
7671 -- This attribute denotes a source Elaborate or Elaborate_All pragma
7672 -- which guarantees the prior elaboration of some unit with respect
7673 -- to the main unit. The pragma may come from the following contexts:
7676 -- * The spec of the main unit (if applicable)
7677 -- * Any parent spec of the main unit (if applicable)
7678 -- * Any parent subunit of the main unit (if applicable)
7680 -- The attribute remains Empty if no such pragma is available. Source
7681 -- pragmas play a role in satisfying SPARK elaboration requirements.
7683 With_Clause : Node_Id := Empty;
7684 -- This attribute denotes an internally-generated or a source with
7685 -- clause for some unit withed by the main unit. With clauses carry
7686 -- flags which represent implicit Elaborate or Elaborate_All pragmas.
7687 -- These clauses play a role in supplying elaboration dependencies to
7691 ---------------------
7692 -- Data structures --
7693 ---------------------
7695 -- The following table stores all elaboration attributes
7697 package Elaboration_Attributes is new Table.Table
7698 (Table_Index_Type => Elaboration_Attributes_Id,
7699 Table_Component_Type => Elaboration_Attributes_Record,
7700 Table_Low_Bound => First_Elaboration_Attributes,
7701 Table_Initial => 250,
7702 Table_Increment => 200,
7703 Table_Name => "Elaboration_Attributes");
7705 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id);
7706 -- Destroy elaboration attributes EA_Id
7708 package UA_Map is new Dynamic_Hash_Tables
7709 (Key_Type => Entity_Id,
7710 Value_Type => Elaboration_Attributes_Id,
7711 No_Value => No_Elaboration_Attributes,
7712 Expansion_Threshold => 1.5,
7713 Expansion_Factor => 2,
7714 Compression_Threshold => 0.3,
7715 Compression_Factor => 2,
7717 Destroy_Value => Destroy,
7720 -- The following map relates an elaboration attributes of a unit to the
7723 Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := UA_Map.Nil;
7729 function Elaboration_Attributes_Of
7730 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id;
7731 pragma Inline (Elaboration_Attributes_Of);
7732 -- Obtain the elaboration attributes of unit Unit_Id
7734 -----------------------
7735 -- Local subprograms --
7736 -----------------------
7738 function Elab_Pragma (EA_Id : Elaboration_Attributes_Id) return Node_Id;
7739 pragma Inline (Elab_Pragma);
7740 -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id
7742 procedure Ensure_Prior_Elaboration_Dynamic
7744 Unit_Id : Entity_Id;
7746 In_State : Processing_In_State);
7747 pragma Inline (Ensure_Prior_Elaboration_Dynamic);
7748 -- Guarantee the elaboration of unit Unit_Id with respect to the main
7749 -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N
7750 -- denotes the related scenario. In_State is the current state of the
7751 -- Processing phase.
7753 procedure Ensure_Prior_Elaboration_Static
7755 Unit_Id : Entity_Id;
7757 In_State : Processing_In_State);
7758 pragma Inline (Ensure_Prior_Elaboration_Static);
7759 -- Guarantee the elaboration of unit Unit_Id with respect to the main
7760 -- unit by installing an implicit Elaborate[_All] pragma with name
7761 -- Prag_Nam. N denotes the related scenario. In_State is the current
7762 -- state of the Processing phase.
7764 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean;
7765 pragma Inline (Present);
7766 -- Determine whether elaboration attributes UA_Id exist
7768 procedure Set_Elab_Pragma
7769 (EA_Id : Elaboration_Attributes_Id;
7771 pragma Inline (Set_Elab_Pragma);
7772 -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to
7775 procedure Set_With_Clause
7776 (EA_Id : Elaboration_Attributes_Id;
7778 pragma Inline (Set_With_Clause);
7779 -- Set the with clause of elaboration attributes EA_Id to Clause
7781 function With_Clause (EA_Id : Elaboration_Attributes_Id) return Node_Id;
7782 pragma Inline (With_Clause);
7783 -- Obtain the implicit or source with clause of elaboration attributes
7786 ------------------------------
7787 -- Collect_Elaborated_Units --
7788 ------------------------------
7790 procedure Collect_Elaborated_Units is
7791 procedure Add_Pragma (Prag : Node_Id);
7792 pragma Inline (Add_Pragma);
7793 -- Determine whether pragma Prag denotes a legal Elaborate[_All]
7794 -- pragma. If this is the case, add the related unit to the context.
7795 -- For pragma Elaborate_All, include recursively all units withed by
7796 -- the related unit.
7799 (Unit_Id : Entity_Id;
7801 Full_Context : Boolean);
7802 pragma Inline (Add_Unit);
7803 -- Add unit Unit_Id to the elaboration context. Prag denotes the
7804 -- pragma which prompted the inclusion of the unit to the context.
7805 -- If flag Full_Context is set, examine the nonlimited clauses of
7806 -- unit Unit_Id and add each withed unit to the context.
7808 procedure Find_Elaboration_Context (Comp_Unit : Node_Id);
7809 pragma Inline (Find_Elaboration_Context);
7810 -- Examine the context items of compilation unit Comp_Unit for
7811 -- suitable elaboration-related pragmas and add all related units
7818 procedure Add_Pragma (Prag : Node_Id) is
7819 Prag_Args : constant List_Id :=
7820 Pragma_Argument_Associations (Prag);
7821 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
7825 -- Nothing to do if the pragma is not related to elaboration
7827 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then
7830 -- Nothing to do when the pragma is illegal
7832 elsif Error_Posted (Prag) then
7836 Unit_Arg := Get_Pragma_Arg (First (Prag_Args));
7838 -- The argument of the pragma may appear in package.package form
7840 if Nkind (Unit_Arg) = N_Selected_Component then
7841 Unit_Arg := Selector_Name (Unit_Arg);
7845 (Unit_Id => Entity (Unit_Arg),
7847 Full_Context => Prag_Nam = Name_Elaborate_All);
7855 (Unit_Id : Entity_Id;
7857 Full_Context : Boolean)
7860 EA_Id : Elaboration_Attributes_Id;
7861 Unit_Prag : Node_Id;
7864 -- Nothing to do when some previous error left a with clause or a
7865 -- pragma in a bad state.
7867 if No (Unit_Id) then
7871 EA_Id := Elaboration_Attributes_Of (Unit_Id);
7872 Unit_Prag := Elab_Pragma (EA_Id);
7874 -- The unit is already included in the context by means of pragma
7877 if Present (Unit_Prag) then
7879 -- Upgrade an existing pragma Elaborate when the unit is
7880 -- subject to Elaborate_All because the new pragma covers a
7881 -- larger set of units.
7883 if Pragma_Name (Unit_Prag) = Name_Elaborate
7884 and then Pragma_Name (Prag) = Name_Elaborate_All
7886 Set_Elab_Pragma (EA_Id, Prag);
7888 -- Otherwise the unit retains its existing pragma and does not
7889 -- need to be included in the context again.
7895 -- Otherwise the current unit is not included in the context
7898 Set_Elab_Pragma (EA_Id, Prag);
7901 -- Includes all units withed by the current one when computing the
7904 if Full_Context then
7906 -- Process all nonlimited with clauses found in the context of
7907 -- the current unit. Note that limited clauses do not impose an
7908 -- elaboration order.
7910 Clause := First (Context_Items (Compilation_Unit (Unit_Id)));
7911 while Present (Clause) loop
7912 if Nkind (Clause) = N_With_Clause
7913 and then not Error_Posted (Clause)
7914 and then not Limited_Present (Clause)
7917 (Unit_Id => Entity (Name (Clause)),
7919 Full_Context => Full_Context);
7927 ------------------------------
7928 -- Find_Elaboration_Context --
7929 ------------------------------
7931 procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is
7932 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
7937 -- Process all elaboration-related pragmas found in the context of
7938 -- the compilation unit.
7940 Prag := First (Context_Items (Comp_Unit));
7941 while Present (Prag) loop
7942 if Nkind (Prag) = N_Pragma then
7948 end Find_Elaboration_Context;
7955 -- Start of processing for Collect_Elaborated_Units
7958 -- Perform a traversal to examines the context of the main unit. The
7959 -- traversal performs the following jumps:
7961 -- subunit -> parent subunit
7962 -- parent subunit -> body
7964 -- spec -> parent spec
7965 -- parent spec -> grandparent spec and so on
7967 -- The traversal relies on units rather than scopes because the scope
7968 -- of a subunit is some spec, while this traversal must process the
7969 -- body as well. Given that protected and task bodies can also be
7970 -- subunits, this complicates the scope approach even further.
7972 Unit_Id := Unit (Cunit (Main_Unit));
7974 -- Perform the following traversals when the main unit is a subunit
7976 -- subunit -> parent subunit
7977 -- parent subunit -> body
7979 while Present (Unit_Id) and then Nkind (Unit_Id) = N_Subunit loop
7980 Find_Elaboration_Context (Parent (Unit_Id));
7982 -- Continue the traversal by going to the unit which contains the
7983 -- corresponding stub.
7985 if Present (Corresponding_Stub (Unit_Id)) then
7987 Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unit_Id))));
7989 -- Otherwise the subunit may be erroneous or left in a bad state
7996 -- Perform the following traversal now that subunits have been taken
7997 -- care of, or the main unit is a body.
8001 if Present (Unit_Id)
8002 and then Nkind_In (Unit_Id, N_Package_Body, N_Subprogram_Body)
8004 Find_Elaboration_Context (Parent (Unit_Id));
8006 -- Continue the traversal by going to the unit which contains the
8007 -- corresponding spec.
8009 if Present (Corresponding_Spec (Unit_Id)) then
8011 Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unit_Id))));
8015 -- Perform the following traversals now that the body has been taken
8016 -- care of, or the main unit is a spec.
8018 -- spec -> parent spec
8019 -- parent spec -> grandparent spec and so on
8021 if Present (Unit_Id)
8022 and then Nkind_In (Unit_Id, N_Generic_Package_Declaration,
8023 N_Generic_Subprogram_Declaration,
8024 N_Package_Declaration,
8025 N_Subprogram_Declaration)
8027 Find_Elaboration_Context (Parent (Unit_Id));
8029 -- Process a potential chain of parent units which ends with the
8030 -- main unit spec. The traversal can now safely rely on the scope
8033 Par_Id := Scope (Defining_Entity (Unit_Id));
8034 while Present (Par_Id) and then Par_Id /= Standard_Standard loop
8035 Find_Elaboration_Context (Compilation_Unit (Par_Id));
8037 Par_Id := Scope (Par_Id);
8040 end Collect_Elaborated_Units;
8046 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id) is
8047 pragma Unreferenced (EA_Id);
8056 function Elab_Pragma
8057 (EA_Id : Elaboration_Attributes_Id) return Node_Id
8059 pragma Assert (Present (EA_Id));
8061 return Elaboration_Attributes.Table (EA_Id).Elab_Pragma;
8064 -------------------------------
8065 -- Elaboration_Attributes_Of --
8066 -------------------------------
8068 function Elaboration_Attributes_Of
8069 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id
8071 EA_Id : Elaboration_Attributes_Id;
8074 EA_Id := UA_Map.Get (Unit_To_Attributes_Map, Unit_Id);
8076 -- The unit lacks elaboration attributes. This indicates that the
8077 -- unit is encountered for the first time. Create the elaboration
8078 -- attributes for it.
8080 if not Present (EA_Id) then
8081 Elaboration_Attributes.Append
8082 ((Elab_Pragma => Empty,
8083 With_Clause => Empty));
8084 EA_Id := Elaboration_Attributes.Last;
8086 -- Associate the elaboration attributes with the unit
8088 UA_Map.Put (Unit_To_Attributes_Map, Unit_Id, EA_Id);
8091 pragma Assert (Present (EA_Id));
8094 end Elaboration_Attributes_Of;
8096 ------------------------------
8097 -- Ensure_Prior_Elaboration --
8098 ------------------------------
8100 procedure Ensure_Prior_Elaboration
8102 Unit_Id : Entity_Id;
8104 In_State : Processing_In_State)
8106 pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All));
8109 -- Nothing to do when the need for prior elaboration came from a
8110 -- partial finalization routine which occurs in an initialization
8111 -- context. This behaviour parallels that of the old ABE mechanism.
8113 if In_State.Within_Partial_Finalization then
8116 -- Nothing to do when the need for prior elaboration came from a task
8117 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on
8118 -- task bodies) is in effect.
8120 elsif Debug_Flag_Dot_Y and then In_State.Within_Task_Body then
8123 -- Nothing to do when the unit is elaborated prior to the main unit.
8124 -- This check must also consider the following cases:
8126 -- * No check is made against the context of the main unit because
8127 -- this is specific to the elaboration model in effect and requires
8128 -- custom handling (see Ensure_xxx_Prior_Elaboration).
8130 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
8131 -- Elaborate[_All] MUST be generated even though Unit_Id is always
8132 -- elaborated prior to the main unit. This conservative strategy
8133 -- ensures that other units withed by Unit_Id will not lead to an
8136 -- package A is package body A is
8137 -- procedure ABE; procedure ABE is ... end ABE;
8141 -- package B is package body B is
8142 -- pragma Elaborate_Body; procedure Proc is
8144 -- procedure Proc; A.ABE;
8145 -- package B; end Proc;
8149 -- package C is package body C is
8155 -- In the example above, the elaboration of C invokes B.Proc. B is
8156 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All]
8157 -- is gnerated for B in C, then the following elaboratio order will
8160 -- spec of A elaborated
8161 -- spec of B elaborated
8162 -- body of B elaborated
8163 -- spec of C elaborated
8164 -- body of C elaborated <-- calls B.Proc which calls A.ABE
8165 -- body of A elaborated <-- problem
8167 -- The generation of an implicit pragma Elaborate_All (B) ensures
8168 -- that the elaboration-order mechanism will not pick the above
8171 -- An implicit Elaborate is NOT generated when the unit is subject
8172 -- to Elaborate_Body because both pragmas have the same effect.
8174 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All]
8175 -- MUST NOT be generated in this case because a unit cannot depend
8176 -- on its own elaboration. This case is therefore treated as valid
8177 -- prior elaboration.
8179 elsif Has_Prior_Elaboration
8180 (Unit_Id => Unit_Id,
8181 Same_Unit_OK => True,
8182 Elab_Body_OK => Prag_Nam = Name_Elaborate)
8187 -- Suggest the use of pragma Prag_Nam when the dynamic model is in
8190 if Dynamic_Elaboration_Checks then
8191 Ensure_Prior_Elaboration_Dynamic
8194 Prag_Nam => Prag_Nam,
8195 In_State => In_State);
8197 -- Install an implicit pragma Prag_Nam when the static model is in
8201 pragma Assert (Static_Elaboration_Checks);
8203 Ensure_Prior_Elaboration_Static
8206 Prag_Nam => Prag_Nam,
8207 In_State => In_State);
8209 end Ensure_Prior_Elaboration;
8211 --------------------------------------
8212 -- Ensure_Prior_Elaboration_Dynamic --
8213 --------------------------------------
8215 procedure Ensure_Prior_Elaboration_Dynamic
8217 Unit_Id : Entity_Id;
8219 In_State : Processing_In_State)
8221 procedure Info_Missing_Pragma;
8222 pragma Inline (Info_Missing_Pragma);
8223 -- Output information concerning missing Elaborate or Elaborate_All
8224 -- pragma with name Prag_Nam for scenario N, which would ensure the
8225 -- prior elaboration of Unit_Id.
8227 -------------------------
8228 -- Info_Missing_Pragma --
8229 -------------------------
8231 procedure Info_Missing_Pragma is
8233 -- Internal units are ignored as they cause unnecessary noise
8235 if not In_Internal_Unit (Unit_Id) then
8237 -- The name of the unit subjected to the elaboration pragma is
8238 -- fully qualified to improve the clarity of the info message.
8240 Error_Msg_Name_1 := Prag_Nam;
8241 Error_Msg_Qual_Level := Nat'Last;
8243 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id);
8244 Error_Msg_Qual_Level := 0;
8246 end Info_Missing_Pragma;
8250 EA_Id : constant Elaboration_Attributes_Id :=
8251 Elaboration_Attributes_Of (Unit_Id);
8252 N_Lvl : Enclosing_Level_Kind;
8253 N_Rep : Scenario_Rep_Id;
8255 -- Start of processing for Ensure_Prior_Elaboration_Dynamic
8258 -- Nothing to do when the unit is guaranteed prior elaboration by
8259 -- means of a source Elaborate[_All] pragma.
8261 if Present (Elab_Pragma (EA_Id)) then
8265 -- Output extra information on a missing Elaborate[_All] pragma when
8266 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
8269 if Elab_Info_Messages
8270 and then not In_State.Suppress_Info_Messages
8272 N_Rep := Scenario_Representation_Of (N, In_State);
8273 N_Lvl := Level (N_Rep);
8275 -- Declaration-level scenario
8277 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N))
8278 and then N_Lvl = Declaration_Level
8282 -- Library-level scenario
8284 elsif N_Lvl in Library_Level then
8287 -- Instantiation library-level scenario
8289 elsif N_Lvl = Instantiation_Level then
8292 -- Otherwise the scenario does not appear at the proper level
8298 Info_Missing_Pragma;
8300 end Ensure_Prior_Elaboration_Dynamic;
8302 -------------------------------------
8303 -- Ensure_Prior_Elaboration_Static --
8304 -------------------------------------
8306 procedure Ensure_Prior_Elaboration_Static
8308 Unit_Id : Entity_Id;
8310 In_State : Processing_In_State)
8312 function Find_With_Clause
8314 Withed_Id : Entity_Id) return Node_Id;
8315 pragma Inline (Find_With_Clause);
8316 -- Find a nonlimited with clause in the list of context items Items
8317 -- that withs unit Withed_Id. Return Empty if no such clause exists.
8319 procedure Info_Implicit_Pragma;
8320 pragma Inline (Info_Implicit_Pragma);
8321 -- Output information concerning an implicitly generated Elaborate
8322 -- or Elaborate_All pragma with name Prag_Nam for scenario N which
8323 -- ensures the prior elaboration of unit Unit_Id.
8325 ----------------------
8326 -- Find_With_Clause --
8327 ----------------------
8329 function Find_With_Clause
8331 Withed_Id : Entity_Id) return Node_Id
8336 -- Examine the context clauses looking for a suitable with. Note
8337 -- that limited clauses do not affect the elaboration order.
8339 Item := First (Items);
8340 while Present (Item) loop
8341 if Nkind (Item) = N_With_Clause
8342 and then not Error_Posted (Item)
8343 and then not Limited_Present (Item)
8344 and then Entity (Name (Item)) = Withed_Id
8353 end Find_With_Clause;
8355 --------------------------
8356 -- Info_Implicit_Pragma --
8357 --------------------------
8359 procedure Info_Implicit_Pragma is
8361 -- Internal units are ignored as they cause unnecessary noise
8363 if not In_Internal_Unit (Unit_Id) then
8365 -- The name of the unit subjected to the elaboration pragma is
8366 -- fully qualified to improve the clarity of the info message.
8368 Error_Msg_Name_1 := Prag_Nam;
8369 Error_Msg_Qual_Level := Nat'Last;
8372 ("info: implicit pragma % generated for unit &", N, Unit_Id);
8374 Error_Msg_Qual_Level := 0;
8375 Output_Active_Scenarios (N, In_State);
8377 end Info_Implicit_Pragma;
8381 EA_Id : constant Elaboration_Attributes_Id :=
8382 Elaboration_Attributes_Of (Unit_Id);
8384 Main_Cunit : constant Node_Id := Cunit (Main_Unit);
8385 Loc : constant Source_Ptr := Sloc (Main_Cunit);
8386 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id);
8387 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id);
8388 Unit_With : constant Node_Id := With_Clause (EA_Id);
8393 -- Start of processing for Ensure_Prior_Elaboration_Static
8396 -- Nothing to do when the caller has suppressed the generation of
8397 -- implicit Elaborate[_All] pragmas.
8399 if In_State.Suppress_Implicit_Pragmas then
8402 -- Nothing to do when the unit is guaranteed prior elaboration by
8403 -- means of a source Elaborate[_All] pragma.
8405 elsif Present (Unit_Prag) then
8408 -- Nothing to do when the unit has an existing implicit Elaborate or
8409 -- Elaborate_All pragma installed by a previous scenario.
8411 elsif Present (Unit_With) then
8413 -- The unit is already guaranteed prior elaboration by means of an
8414 -- implicit Elaborate pragma, however the current scenario imposes
8415 -- a stronger requirement of Elaborate_All. "Upgrade" the existing
8416 -- pragma to match this new requirement.
8418 if Elaborate_Desirable (Unit_With)
8419 and then Prag_Nam = Name_Elaborate_All
8421 Set_Elaborate_All_Desirable (Unit_With);
8422 Set_Elaborate_Desirable (Unit_With, False);
8428 -- At this point it is known that the unit has no prior elaboration
8429 -- according to pragmas and hierarchical relationships.
8431 Items := Context_Items (Main_Cunit);
8435 Set_Context_Items (Main_Cunit, Items);
8438 -- Locate the with clause for the unit. Note that there may not be a
8439 -- clause if the unit is visible through a subunit-body, body-spec,
8440 -- or spec-parent relationship.
8445 Withed_Id => Unit_Id);
8450 -- Note that adding implicit with clauses is safe because analysis,
8451 -- resolution, and expansion have already taken place and it is not
8452 -- possible to interfere with visibility.
8456 Make_With_Clause (Loc,
8457 Name => New_Occurrence_Of (Unit_Id, Loc));
8459 Set_Implicit_With (Clause);
8460 Set_Library_Unit (Clause, Unit_Cunit);
8462 Append_To (Items, Clause);
8465 -- Mark the with clause depending on the pragma required
8467 if Prag_Nam = Name_Elaborate then
8468 Set_Elaborate_Desirable (Clause);
8470 Set_Elaborate_All_Desirable (Clause);
8473 -- The implicit Elaborate[_All] ensures the prior elaboration of
8474 -- the unit. Include the unit in the elaboration context of the
8477 Set_With_Clause (EA_Id, Clause);
8479 -- Output extra information on an implicit Elaborate[_All] pragma
8480 -- when switch -gnatel (info messages on implicit Elaborate[_All]
8481 -- pragmas is in effect.
8483 if Elab_Info_Messages then
8484 Info_Implicit_Pragma;
8486 end Ensure_Prior_Elaboration_Static;
8488 -------------------------------
8489 -- Finalize_Elaborated_Units --
8490 -------------------------------
8492 procedure Finalize_Elaborated_Units is
8494 UA_Map.Destroy (Unit_To_Attributes_Map);
8495 end Finalize_Elaborated_Units;
8497 ---------------------------
8498 -- Has_Prior_Elaboration --
8499 ---------------------------
8501 function Has_Prior_Elaboration
8502 (Unit_Id : Entity_Id;
8503 Context_OK : Boolean := False;
8504 Elab_Body_OK : Boolean := False;
8505 Same_Unit_OK : Boolean := False) return Boolean
8507 EA_Id : constant Elaboration_Attributes_Id :=
8508 Elaboration_Attributes_Of (Unit_Id);
8509 Main_Id : constant Entity_Id := Main_Unit_Entity;
8510 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id);
8511 Unit_With : constant Node_Id := With_Clause (EA_Id);
8514 -- A preelaborated unit is always elaborated prior to the main unit
8516 if Is_Preelaborated_Unit (Unit_Id) then
8519 -- An internal unit is always elaborated prior to a non-internal main
8522 elsif In_Internal_Unit (Unit_Id)
8523 and then not In_Internal_Unit (Main_Id)
8527 -- A unit has prior elaboration if it appears within the context
8528 -- of the main unit. Consider this case only when requested by the
8532 and then (Present (Unit_Prag) or else Present (Unit_With))
8536 -- A unit whose body is elaborated together with its spec has prior
8537 -- elaboration except with respect to itself. Consider this case only
8538 -- when requested by the caller.
8541 and then Has_Pragma_Elaborate_Body (Unit_Id)
8542 and then not Is_Same_Unit (Unit_Id, Main_Id)
8546 -- A unit has no prior elaboration with respect to itself, but does
8547 -- not require any means of ensuring its own elaboration either.
8548 -- Treat this case as valid prior elaboration only when requested by
8551 elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then
8556 end Has_Prior_Elaboration;
8558 ---------------------------------
8559 -- Initialize_Elaborated_Units --
8560 ---------------------------------
8562 procedure Initialize_Elaborated_Units is
8564 Unit_To_Attributes_Map := UA_Map.Create (250);
8565 end Initialize_Elaborated_Units;
8567 ----------------------------------
8568 -- Meet_Elaboration_Requirement --
8569 ----------------------------------
8571 procedure Meet_Elaboration_Requirement
8573 Targ_Id : Entity_Id;
8575 In_State : Processing_In_State)
8577 pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All));
8579 Main_Id : constant Entity_Id := Main_Unit_Entity;
8580 Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id);
8582 procedure Elaboration_Requirement_Error;
8583 pragma Inline (Elaboration_Requirement_Error);
8584 -- Emit an error concerning scenario N which has failed to meet the
8585 -- elaboration requirement.
8587 function Find_Preelaboration_Pragma
8588 (Prag_Nam : Name_Id) return Node_Id;
8589 pragma Inline (Find_Preelaboration_Pragma);
8590 -- Traverse the visible declarations of unit Unit_Id and locate a
8591 -- source preelaboration-related pragma with name Prag_Nam.
8593 procedure Info_Requirement_Met (Prag : Node_Id);
8594 pragma Inline (Info_Requirement_Met);
8595 -- Output information concerning pragma Prag which meets requirement
8598 -----------------------------------
8599 -- Elaboration_Requirement_Error --
8600 -----------------------------------
8602 procedure Elaboration_Requirement_Error is
8604 if Is_Suitable_Call (N) then
8611 elsif Is_Suitable_Instantiation (N) then
8618 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then
8620 ("read of refinement constituents during elaboration in "
8623 elsif Is_Suitable_Variable_Reference (N) then
8624 Info_Variable_Reference
8630 -- No other scenario may impose a requirement on the context of
8634 pragma Assert (False);
8638 Error_Msg_Name_1 := Req_Nam;
8639 Error_Msg_Node_2 := Unit_Id;
8640 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id);
8642 Output_Active_Scenarios (N, In_State);
8643 end Elaboration_Requirement_Error;
8645 --------------------------------
8646 -- Find_Preelaboration_Pragma --
8647 --------------------------------
8649 function Find_Preelaboration_Pragma
8650 (Prag_Nam : Name_Id) return Node_Id
8652 Spec : constant Node_Id := Parent (Unit_Id);
8656 -- A preelaboration-related pragma comes from source and appears
8657 -- at the top of the visible declarations of a package.
8659 if Nkind (Spec) = N_Package_Specification then
8660 Decl := First (Visible_Declarations (Spec));
8661 while Present (Decl) loop
8662 if Comes_From_Source (Decl) then
8663 if Nkind (Decl) = N_Pragma
8664 and then Pragma_Name (Decl) = Prag_Nam
8668 -- Otherwise the construct terminates the region where
8669 -- the preelaboration-related pragma may appear.
8681 end Find_Preelaboration_Pragma;
8683 --------------------------
8684 -- Info_Requirement_Met --
8685 --------------------------
8687 procedure Info_Requirement_Met (Prag : Node_Id) is
8688 pragma Assert (Present (Prag));
8691 Error_Msg_Name_1 := Req_Nam;
8692 Error_Msg_Sloc := Sloc (Prag);
8694 ("\\% requirement for unit & met by pragma #", N, Unit_Id);
8695 end Info_Requirement_Met;
8699 EA_Id : Elaboration_Attributes_Id;
8702 Unit_Prag : Node_Id;
8704 -- Start of processing for Meet_Elaboration_Requirement
8707 -- Assume that the requirement has not been met
8711 -- If the target is within the main unit, either at the source level
8712 -- or through an instantiation, then there is no real requirement to
8713 -- meet because the main unit cannot force its own elaboration by
8714 -- means of an Elaborate[_All] pragma. Treat this case as valid
8717 if In_Extended_Main_Code_Unit (Targ_Id) then
8720 -- Otherwise the target resides in an external unit
8722 -- The requirement is met when the target comes from an internal unit
8723 -- because such a unit is elaborated prior to a non-internal unit.
8725 elsif In_Internal_Unit (Unit_Id)
8726 and then not In_Internal_Unit (Main_Id)
8730 -- The requirement is met when the target comes from a preelaborated
8731 -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
8733 elsif Is_Preelaborated_Unit (Unit_Id) then
8736 -- Output extra information when switch -gnatel (info messages on
8737 -- implicit Elaborate[_All] pragmas.
8739 if Elab_Info_Messages
8740 and then not In_State.Suppress_Info_Messages
8742 if Is_Preelaborated (Unit_Id) then
8743 Elab_Nam := Name_Preelaborate;
8745 elsif Is_Pure (Unit_Id) then
8746 Elab_Nam := Name_Pure;
8748 elsif Is_Remote_Call_Interface (Unit_Id) then
8749 Elab_Nam := Name_Remote_Call_Interface;
8751 elsif Is_Remote_Types (Unit_Id) then
8752 Elab_Nam := Name_Remote_Types;
8755 pragma Assert (Is_Shared_Passive (Unit_Id));
8756 Elab_Nam := Name_Shared_Passive;
8759 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam));
8762 -- Determine whether the context of the main unit has a pragma strong
8763 -- enough to meet the requirement.
8766 EA_Id := Elaboration_Attributes_Of (Unit_Id);
8767 Unit_Prag := Elab_Pragma (EA_Id);
8769 -- The pragma must be either Elaborate_All or be as strong as the
8772 if Present (Unit_Prag)
8773 and then Nam_In (Pragma_Name (Unit_Prag), Name_Elaborate_All,
8778 -- Output extra information when switch -gnatel (info messages
8779 -- on implicit Elaborate[_All] pragmas.
8781 if Elab_Info_Messages
8782 and then not In_State.Suppress_Info_Messages
8784 Info_Requirement_Met (Unit_Prag);
8789 -- The requirement was not met by the context of the main unit, issue
8793 Elaboration_Requirement_Error;
8795 end Meet_Elaboration_Requirement;
8801 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean is
8803 return EA_Id /= No_Elaboration_Attributes;
8806 ---------------------
8807 -- Set_Elab_Pragma --
8808 ---------------------
8810 procedure Set_Elab_Pragma
8811 (EA_Id : Elaboration_Attributes_Id;
8814 pragma Assert (Present (EA_Id));
8816 Elaboration_Attributes.Table (EA_Id).Elab_Pragma := Prag;
8817 end Set_Elab_Pragma;
8819 ---------------------
8820 -- Set_With_Clause --
8821 ---------------------
8823 procedure Set_With_Clause
8824 (EA_Id : Elaboration_Attributes_Id;
8827 pragma Assert (Present (EA_Id));
8829 Elaboration_Attributes.Table (EA_Id).With_Clause := Clause;
8830 end Set_With_Clause;
8836 function With_Clause
8837 (EA_Id : Elaboration_Attributes_Id) return Node_Id
8839 pragma Assert (Present (EA_Id));
8841 return Elaboration_Attributes.Table (EA_Id).With_Clause;
8843 end Elaborated_Units;
8845 ------------------------------
8846 -- Elaboration_Phase_Active --
8847 ------------------------------
8849 function Elaboration_Phase_Active return Boolean is
8851 return Elaboration_Phase = Active;
8852 end Elaboration_Phase_Active;
8854 ----------------------------------
8855 -- Finalize_All_Data_Structures --
8856 ----------------------------------
8858 procedure Finalize_All_Data_Structures is
8860 Finalize_Body_Processor;
8861 Finalize_Early_Call_Region_Processor;
8862 Finalize_Elaborated_Units;
8863 Finalize_Internal_Representation;
8864 Finalize_Invocation_Graph;
8865 Finalize_Scenario_Storage;
8866 end Finalize_All_Data_Structures;
8868 -----------------------------
8869 -- Find_Enclosing_Instance --
8870 -----------------------------
8872 function Find_Enclosing_Instance (N : Node_Id) return Node_Id is
8876 -- Climb the parent chain looking for an enclosing instance spec or body
8879 while Present (Par) loop
8880 if Nkind_In (Par, N_Package_Body,
8881 N_Package_Declaration,
8883 N_Subprogram_Declaration)
8884 and then Is_Generic_Instance (Unique_Defining_Entity (Par))
8889 Par := Parent (Par);
8893 end Find_Enclosing_Instance;
8895 --------------------------
8896 -- Find_Enclosing_Level --
8897 --------------------------
8899 function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is
8900 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind;
8901 pragma Inline (Level_Of);
8902 -- Obtain the corresponding level of unit Unit
8908 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is
8909 Spec_Id : Entity_Id;
8912 if Nkind (Unit) in N_Generic_Instantiation then
8913 return Instantiation_Level;
8915 elsif Nkind (Unit) = N_Generic_Package_Declaration then
8916 return Generic_Spec_Level;
8918 elsif Nkind (Unit) = N_Package_Declaration then
8919 return Library_Spec_Level;
8921 elsif Nkind (Unit) = N_Package_Body then
8922 Spec_Id := Corresponding_Spec (Unit);
8924 -- The body belongs to a generic package
8926 if Present (Spec_Id)
8927 and then Ekind (Spec_Id) = E_Generic_Package
8929 return Generic_Body_Level;
8931 -- Otherwise the body belongs to a non-generic package. This also
8932 -- treats an illegal package body without a corresponding spec as
8933 -- a non-generic package body.
8936 return Library_Body_Level;
8949 -- Start of processing for Find_Enclosing_Level
8952 -- Call markers and instantiations which appear at the declaration level
8953 -- but are later relocated in a different context retain their original
8954 -- declaration level.
8956 if Nkind_In (N, N_Call_Marker,
8957 N_Function_Instantiation,
8958 N_Package_Instantiation,
8959 N_Procedure_Instantiation)
8960 and then Is_Declaration_Level_Node (N)
8962 return Declaration_Level;
8965 -- Climb the parent chain looking at the enclosing levels
8968 Curr := Parent (Prev);
8969 while Present (Curr) loop
8971 -- A traversal from a subunit continues via the corresponding stub
8973 if Nkind (Curr) = N_Subunit then
8974 Curr := Corresponding_Stub (Curr);
8976 -- The current construct is a package. Packages are ignored because
8977 -- they are always elaborated when the enclosing context is invoked
8980 elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then
8983 -- The current construct is a block statement
8985 elsif Nkind (Curr) = N_Block_Statement then
8987 -- Ignore internally generated blocks created by the expander for
8988 -- various purposes such as abort defer/undefer.
8990 if not Comes_From_Source (Curr) then
8993 -- If the traversal came from the handled sequence of statments,
8994 -- then the node appears at the level of the enclosing construct.
8995 -- This is a more reliable test because transients scopes within
8996 -- the declarative region of the encapsulator are hard to detect.
8998 elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements
8999 and then Handled_Statement_Sequence (Curr) = Prev
9001 return Find_Enclosing_Level (Parent (Curr));
9003 -- Otherwise the traversal came from the declarations, the node is
9004 -- at the declaration level.
9007 return Declaration_Level;
9010 -- The current construct is a declaration-level encapsulator
9012 elsif Nkind_In (Curr, N_Entry_Body,
9016 -- If the traversal came from the handled sequence of statments,
9017 -- then the node cannot possibly appear at any level. This is
9018 -- a more reliable test because transients scopes within the
9019 -- declarative region of the encapsulator are hard to detect.
9021 if Nkind (Prev) = N_Handled_Sequence_Of_Statements
9022 and then Handled_Statement_Sequence (Curr) = Prev
9026 -- Otherwise the traversal came from the declarations, the node is
9027 -- at the declaration level.
9030 return Declaration_Level;
9033 -- The current construct is a non-library-level encapsulator which
9034 -- indicates that the node cannot possibly appear at any level. Note
9035 -- that the check must come after the declaration-level check because
9036 -- both predicates share certain nodes.
9038 elsif Is_Non_Library_Level_Encapsulator (Curr) then
9039 Context := Parent (Curr);
9041 -- The sole exception is when the encapsulator is the compilation
9042 -- utit itself because the compilation unit node requires special
9043 -- processing (see below).
9045 if Present (Context)
9046 and then Nkind (Context) = N_Compilation_Unit
9050 -- Otherwise the node is not at any level
9056 -- The current construct is a compilation unit. The node appears at
9057 -- the [generic] library level when the unit is a [generic] package.
9059 elsif Nkind (Curr) = N_Compilation_Unit then
9060 return Level_Of (Unit (Curr));
9064 Curr := Parent (Prev);
9068 end Find_Enclosing_Level;
9074 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is
9076 return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N))));
9079 ----------------------
9080 -- Find_Unit_Entity --
9081 ----------------------
9083 function Find_Unit_Entity (N : Node_Id) return Entity_Id is
9084 Context : constant Node_Id := Parent (N);
9085 Orig_N : constant Node_Id := Original_Node (N);
9088 -- The unit denotes a package body of an instantiation which acts as
9089 -- a compilation unit. The proper entity is that of the package spec.
9091 if Nkind (N) = N_Package_Body
9092 and then Nkind (Orig_N) = N_Package_Instantiation
9093 and then Nkind (Context) = N_Compilation_Unit
9095 return Corresponding_Spec (N);
9097 -- The unit denotes an anonymous package created to wrap a subprogram
9098 -- instantiation which acts as a compilation unit. The proper entity is
9099 -- that of the "related instance".
9101 elsif Nkind (N) = N_Package_Declaration
9102 and then Nkind_In (Orig_N, N_Function_Instantiation,
9103 N_Procedure_Instantiation)
9104 and then Nkind (Context) = N_Compilation_Unit
9107 Related_Instance (Defining_Entity (N, Concurrent_Subunit => True));
9109 -- Otherwise the proper entity is the defining entity
9112 return Defining_Entity (N, Concurrent_Subunit => True);
9114 end Find_Unit_Entity;
9116 -----------------------
9117 -- First_Formal_Type --
9118 -----------------------
9120 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is
9121 Formal_Id : constant Entity_Id := First_Formal (Subp_Id);
9125 if Present (Formal_Id) then
9126 Typ := Etype (Formal_Id);
9128 -- Handle various combinations of concurrent and private types
9131 if Ekind_In (Typ, E_Protected_Type, E_Task_Type)
9132 and then Present (Anonymous_Object (Typ))
9134 Typ := Anonymous_Object (Typ);
9136 elsif Is_Concurrent_Record_Type (Typ) then
9137 Typ := Corresponding_Concurrent_Type (Typ);
9139 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
9140 Typ := Full_View (Typ);
9151 end First_Formal_Type;
9153 ------------------------------
9154 -- Guaranteed_ABE_Processor --
9155 ------------------------------
9157 package body Guaranteed_ABE_Processor is
9158 function Is_Guaranteed_ABE
9160 Target_Decl : Node_Id;
9161 Target_Body : Node_Id) return Boolean;
9162 pragma Inline (Is_Guaranteed_ABE);
9163 -- Determine whether scenario N with a target described by its initial
9164 -- declaration Target_Decl and body Target_Decl results in a guaranteed
9167 procedure Process_Guaranteed_ABE_Activation
9169 Call_Rep : Scenario_Rep_Id;
9171 Obj_Rep : Target_Rep_Id;
9172 Task_Typ : Entity_Id;
9173 Task_Rep : Target_Rep_Id;
9174 In_State : Processing_In_State);
9175 pragma Inline (Process_Guaranteed_ABE_Activation);
9176 -- Perform common guaranteed ABE checks and diagnostics for activation
9177 -- call Call which activates object Obj_Id of task type Task_Typ. Formal
9178 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the
9179 -- representation of the object. Task_Rep denotes the representation of
9180 -- the task type. In_State is the current state of the Processing phase.
9182 procedure Process_Guaranteed_ABE_Call
9184 Call_Rep : Scenario_Rep_Id;
9185 In_State : Processing_In_State);
9186 pragma Inline (Process_Guaranteed_ABE_Call);
9187 -- Perform common guaranteed ABE checks and diagnostics for call Call
9188 -- with representation Call_Rep. In_State denotes the current state of
9189 -- the Processing phase.
9191 procedure Process_Guaranteed_ABE_Instantiation
9193 Inst_Rep : Scenario_Rep_Id;
9194 In_State : Processing_In_State);
9195 pragma Inline (Process_Guaranteed_ABE_Instantiation);
9196 -- Perform common guaranteed ABE checks and diagnostics for instance
9197 -- Inst with representation Inst_Rep. In_State is the current state of
9198 -- the Processing phase.
9200 -----------------------
9201 -- Is_Guaranteed_ABE --
9202 -----------------------
9204 function Is_Guaranteed_ABE
9206 Target_Decl : Node_Id;
9207 Target_Body : Node_Id) return Boolean
9210 -- Avoid cascaded errors if there were previous serious infractions.
9211 -- As a result the scenario will not be treated as a guaranteed ABE.
9212 -- This behaviour parallels that of the old ABE mechanism.
9214 if Serious_Errors_Detected > 0 then
9217 -- The scenario and the target appear in the same context ignoring
9218 -- enclosing library levels.
9220 elsif In_Same_Context (N, Target_Decl) then
9222 -- The target body has already been encountered. The scenario
9223 -- results in a guaranteed ABE if it appears prior to the body.
9225 if Present (Target_Body) then
9226 return Earlier_In_Extended_Unit (N, Target_Body);
9228 -- Otherwise the body has not been encountered yet. The scenario
9229 -- is a guaranteed ABE since the body will appear later. It is
9230 -- assumed that the caller has already ensured that the scenario
9231 -- is ABE-safe because optional bodies are not considered here.
9239 end Is_Guaranteed_ABE;
9241 ----------------------------
9242 -- Process_Guaranteed_ABE --
9243 ----------------------------
9245 procedure Process_Guaranteed_ABE
9247 In_State : Processing_In_State)
9249 Scen : constant Node_Id := Scenario (N);
9250 Scen_Rep : Scenario_Rep_Id;
9253 -- Add the current scenario to the stack of active scenarios
9255 Push_Active_Scenario (Scen);
9257 -- Only calls, instantiations, and task activations may result in a
9260 -- Call or task activation
9262 if Is_Suitable_Call (Scen) then
9263 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
9265 if Kind (Scen_Rep) = Call_Scenario then
9266 Process_Guaranteed_ABE_Call
9268 Call_Rep => Scen_Rep,
9269 In_State => In_State);
9272 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario);
9276 Call_Rep => Scenario_Representation_Of (Scen, In_State),
9277 Processor => Process_Guaranteed_ABE_Activation'Access,
9278 In_State => In_State);
9283 elsif Is_Suitable_Instantiation (Scen) then
9284 Process_Guaranteed_ABE_Instantiation
9286 Inst_Rep => Scenario_Representation_Of (Scen, In_State),
9287 In_State => In_State);
9290 -- Remove the current scenario from the stack of active scenarios
9291 -- once all ABE diagnostics and checks have been performed.
9293 Pop_Active_Scenario (Scen);
9294 end Process_Guaranteed_ABE;
9296 ---------------------------------------
9297 -- Process_Guaranteed_ABE_Activation --
9298 ---------------------------------------
9300 procedure Process_Guaranteed_ABE_Activation
9302 Call_Rep : Scenario_Rep_Id;
9304 Obj_Rep : Target_Rep_Id;
9305 Task_Typ : Entity_Id;
9306 Task_Rep : Target_Rep_Id;
9307 In_State : Processing_In_State)
9309 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep);
9311 Check_OK : constant Boolean :=
9312 not In_State.Suppress_Checks
9313 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored
9314 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored
9315 and then Elaboration_Checks_OK (Obj_Rep)
9316 and then Elaboration_Checks_OK (Task_Rep);
9317 -- A run-time ABE check may be installed only when the object and the
9318 -- task type have active elaboration checks, and both are not ignored
9319 -- Ghost constructs.
9322 -- Nothing to do when the root scenario appears at the declaration
9323 -- level and the task is in the same unit, but outside this context.
9325 -- task type Task_Typ; -- task declaration
9327 -- procedure Proc is
9328 -- function A ... is
9330 -- if Some_Condition then
9334 -- <activation call> -- activation site
9339 -- X : ... := A; -- root scenario
9342 -- task body Task_Typ is
9346 -- In the example above, the context of X is the declarative list
9347 -- of Proc. The "elaboration" of X may reach the activation of T
9348 -- whose body is defined outside of X's context. The task body is
9349 -- relevant only when Proc is invoked, but this happens only in
9350 -- "normal" elaboration, therefore the task body must not be
9351 -- considered if this is not the case.
9353 if Is_Up_Level_Target
9354 (Targ_Decl => Spec_Decl,
9355 In_State => In_State)
9359 -- Nothing to do when the activation is ABE-safe
9363 -- task type Task_Typ;
9366 -- package body Gen is
9367 -- task body Task_Typ is
9374 -- procedure Main is
9375 -- package Nested is
9376 -- package Inst is new Gen;
9377 -- T : Inst.Task_Typ;
9378 -- end Nested; -- safe activation
9381 elsif Is_Safe_Activation (Call, Task_Rep) then
9384 -- An activation call leads to a guaranteed ABE when the activation
9385 -- call and the task appear within the same context ignoring library
9386 -- levels, and the body of the task has not been seen yet or appears
9387 -- after the activation call.
9389 -- procedure Guaranteed_ABE is
9390 -- task type Task_Typ;
9392 -- package Nested is
9394 -- <activation call> -- guaranteed ABE
9397 -- task body Task_Typ is
9402 elsif Is_Guaranteed_ABE
9404 Target_Decl => Spec_Decl,
9405 Target_Body => Body_Declaration (Task_Rep))
9407 if Elaboration_Warnings_OK (Call_Rep) then
9408 Error_Msg_Sloc := Sloc (Call);
9410 ("??task & will be activated # before elaboration of its "
9413 ("\Program_Error will be raised at run time", Obj_Id);
9416 -- Mark the activation call as a guaranteed ABE
9418 Set_Is_Known_Guaranteed_ABE (Call);
9420 -- Install a run-time ABE failue because this activation call will
9421 -- always result in an ABE.
9424 Install_Scenario_ABE_Failure
9426 Targ_Id => Task_Typ,
9427 Targ_Rep => Task_Rep,
9428 Disable => Obj_Rep);
9431 end Process_Guaranteed_ABE_Activation;
9433 ---------------------------------
9434 -- Process_Guaranteed_ABE_Call --
9435 ---------------------------------
9437 procedure Process_Guaranteed_ABE_Call
9439 Call_Rep : Scenario_Rep_Id;
9440 In_State : Processing_In_State)
9442 Subp_Id : constant Entity_Id := Target (Call_Rep);
9443 Subp_Rep : constant Target_Rep_Id :=
9444 Target_Representation_Of (Subp_Id, In_State);
9445 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep);
9447 Check_OK : constant Boolean :=
9448 not In_State.Suppress_Checks
9449 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored
9450 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored
9451 and then Elaboration_Checks_OK (Call_Rep)
9452 and then Elaboration_Checks_OK (Subp_Rep);
9453 -- A run-time ABE check may be installed only when both the call
9454 -- and the target have active elaboration checks, and both are not
9455 -- ignored Ghost constructs.
9458 -- Nothing to do when the root scenario appears at the declaration
9459 -- level and the target is in the same unit but outside this context.
9461 -- function B ...; -- target declaration
9463 -- procedure Proc is
9464 -- function A ... is
9466 -- if Some_Condition then
9467 -- return B; -- call site
9471 -- X : ... := A; -- root scenario
9474 -- function B ... is
9478 -- In the example above, the context of X is the declarative region
9479 -- of Proc. The "elaboration" of X may eventually reach B which is
9480 -- defined outside of X's context. B is relevant only when Proc is
9481 -- invoked, but this happens only by means of "normal" elaboration,
9482 -- therefore B must not be considered if this is not the case.
9484 if Is_Up_Level_Target
9485 (Targ_Decl => Spec_Decl,
9486 In_State => In_State)
9490 -- Nothing to do when the call is ABE-safe
9493 -- function Gen ...;
9495 -- function Gen ... is
9501 -- procedure Main is
9502 -- function Inst is new Gen;
9503 -- X : ... := Inst; -- safe call
9506 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then
9509 -- A call leads to a guaranteed ABE when the call and the target
9510 -- appear within the same context ignoring library levels, and the
9511 -- body of the target has not been seen yet or appears after the
9514 -- procedure Guaranteed_ABE is
9515 -- function Func ...;
9517 -- package Nested is
9518 -- Obj : ... := Func; -- guaranteed ABE
9521 -- function Func ... is
9526 elsif Is_Guaranteed_ABE
9528 Target_Decl => Spec_Decl,
9529 Target_Body => Body_Declaration (Subp_Rep))
9531 if Elaboration_Warnings_OK (Call_Rep) then
9533 ("??cannot call & before body seen", Call, Subp_Id);
9534 Error_Msg_N ("\Program_Error will be raised at run time", Call);
9537 -- Mark the call as a guarnateed ABE
9539 Set_Is_Known_Guaranteed_ABE (Call);
9541 -- Install a run-time ABE failure because the call will always
9542 -- result in an ABE.
9545 Install_Scenario_ABE_Failure
9548 Targ_Rep => Subp_Rep,
9549 Disable => Call_Rep);
9552 end Process_Guaranteed_ABE_Call;
9554 ------------------------------------------
9555 -- Process_Guaranteed_ABE_Instantiation --
9556 ------------------------------------------
9558 procedure Process_Guaranteed_ABE_Instantiation
9560 Inst_Rep : Scenario_Rep_Id;
9561 In_State : Processing_In_State)
9563 Gen_Id : constant Entity_Id := Target (Inst_Rep);
9564 Gen_Rep : constant Target_Rep_Id :=
9565 Target_Representation_Of (Gen_Id, In_State);
9566 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep);
9568 Check_OK : constant Boolean :=
9569 not In_State.Suppress_Checks
9570 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored
9571 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored
9572 and then Elaboration_Checks_OK (Inst_Rep)
9573 and then Elaboration_Checks_OK (Gen_Rep);
9574 -- A run-time ABE check may be installed only when both the instance
9575 -- and the generic have active elaboration checks and both are not
9576 -- ignored Ghost constructs.
9579 -- Nothing to do when the root scenario appears at the declaration
9580 -- level and the generic is in the same unit, but outside this
9584 -- procedure Gen is ...; -- generic declaration
9586 -- procedure Proc is
9587 -- function A ... is
9589 -- if Some_Condition then
9591 -- procedure I is new Gen; -- instantiation site
9596 -- X : ... := A; -- root scenario
9603 -- In the example above, the context of X is the declarative region
9604 -- of Proc. The "elaboration" of X may eventually reach Gen which
9605 -- appears outside of X's context. Gen is relevant only when Proc is
9606 -- invoked, but this happens only by means of "normal" elaboration,
9607 -- therefore Gen must not be considered if this is not the case.
9609 if Is_Up_Level_Target
9610 (Targ_Decl => Spec_Decl,
9611 In_State => In_State)
9615 -- Nothing to do when the instantiation is ABE-safe
9622 -- package body Gen is
9627 -- procedure Main is
9628 -- package Inst is new Gen (ABE); -- safe instantiation
9631 elsif Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then
9634 -- An instantiation leads to a guaranteed ABE when the instantiation
9635 -- and the generic appear within the same context ignoring library
9636 -- levels, and the body of the generic has not been seen yet or
9637 -- appears after the instantiation.
9639 -- procedure Guaranteed_ABE is
9643 -- package Nested is
9644 -- procedure Inst is new Gen; -- guaranteed ABE
9652 elsif Is_Guaranteed_ABE
9654 Target_Decl => Spec_Decl,
9655 Target_Body => Body_Declaration (Gen_Rep))
9657 if Elaboration_Warnings_OK (Inst_Rep) then
9659 ("??cannot instantiate & before body seen", Inst, Gen_Id);
9660 Error_Msg_N ("\Program_Error will be raised at run time", Inst);
9663 -- Mark the instantiation as a guarantee ABE. This automatically
9664 -- suppresses the instantiation of the generic body.
9666 Set_Is_Known_Guaranteed_ABE (Inst);
9668 -- Install a run-time ABE failure because the instantiation will
9669 -- always result in an ABE.
9672 Install_Scenario_ABE_Failure
9675 Targ_Rep => Gen_Rep,
9676 Disable => Inst_Rep);
9679 end Process_Guaranteed_ABE_Instantiation;
9680 end Guaranteed_ABE_Processor;
9686 function Has_Body (Pack_Decl : Node_Id) return Boolean is
9687 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id;
9688 pragma Inline (Find_Corresponding_Body);
9689 -- Try to locate the corresponding body of spec Spec_Id. If no body is
9690 -- found, return Empty.
9693 (Spec_Id : Entity_Id;
9694 From : Node_Id) return Node_Id;
9695 pragma Inline (Find_Body);
9696 -- Try to locate the corresponding body of spec Spec_Id in the node list
9697 -- which follows arbitrary node From. If no body is found, return Empty.
9699 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id;
9700 pragma Inline (Load_Package_Body);
9701 -- Attempt to load the body of unit Unit_Nam. If the load failed, return
9702 -- Empty. If the compilation will not generate code, return Empty.
9704 -----------------------------
9705 -- Find_Corresponding_Body --
9706 -----------------------------
9708 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is
9709 Context : constant Entity_Id := Scope (Spec_Id);
9710 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9711 Body_Decl : Node_Id;
9712 Body_Id : Entity_Id;
9715 if Is_Compilation_Unit (Spec_Id) then
9716 Body_Id := Corresponding_Body (Spec_Decl);
9718 if Present (Body_Id) then
9719 return Unit_Declaration_Node (Body_Id);
9721 -- The package is at the library and requires a body. Load the
9722 -- corresponding body because the optional body may be declared
9725 elsif Unit_Requires_Body (Spec_Id) then
9728 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl))));
9730 -- Otherwise there is no optional body
9736 -- The immediate context is a package. The optional body may be
9737 -- within the body of that package.
9739 -- procedure Proc is
9740 -- package Nested_1 is
9741 -- package Nested_2 is
9748 -- package body Nested_1 is
9749 -- package body Nested_2 is separate;
9752 -- separate (Proc.Nested_1.Nested_2)
9753 -- package body Nested_2 is
9754 -- package body Pack is -- optional body
9759 elsif Is_Package_Or_Generic_Package (Context) then
9760 Body_Decl := Find_Corresponding_Body (Context);
9762 -- The optional body is within the body of the enclosing package
9764 if Present (Body_Decl) then
9767 (Spec_Id => Spec_Id,
9768 From => First (Declarations (Body_Decl)));
9770 -- Otherwise the enclosing package does not have a body. This may
9771 -- be the result of an error or a genuine lack of a body.
9777 -- Otherwise the immediate context is a body. The optional body may
9778 -- be within the same list as the spec.
9780 -- procedure Proc is
9785 -- package body Pack is -- optional body
9792 (Spec_Id => Spec_Id,
9793 From => Next (Spec_Decl));
9795 end Find_Corresponding_Body;
9802 (Spec_Id : Entity_Id;
9803 From : Node_Id) return Node_Id
9805 Spec_Nam : constant Name_Id := Chars (Spec_Id);
9811 while Present (Item) loop
9813 -- The current item denotes the optional body
9815 if Nkind (Item) = N_Package_Body
9816 and then Chars (Defining_Entity (Item)) = Spec_Nam
9820 -- The current item denotes a stub, the optional body may be in
9823 elsif Nkind (Item) = N_Package_Body_Stub
9824 and then Chars (Defining_Entity (Item)) = Spec_Nam
9826 Lib_Unit := Library_Unit (Item);
9828 -- The corresponding subunit was previously loaded
9830 if Present (Lib_Unit) then
9833 -- Otherwise attempt to load the corresponding subunit
9836 return Load_Package_Body (Get_Unit_Name (Item));
9846 -----------------------
9847 -- Load_Package_Body --
9848 -----------------------
9850 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is
9851 Body_Decl : Node_Id;
9852 Unit_Num : Unit_Number_Type;
9855 -- The load is performed only when the compilation will generate code
9857 if Operating_Mode = Generate_Code then
9860 (Load_Name => Unit_Nam,
9863 Error_Node => Pack_Decl);
9865 -- The load failed most likely because the physical file is
9868 if Unit_Num = No_Unit then
9871 -- Otherwise the load was successful, return the body of the unit
9874 Body_Decl := Unit (Cunit (Unit_Num));
9876 -- If the unit is a subunit with an available proper body,
9877 -- return the proper body.
9879 if Nkind (Body_Decl) = N_Subunit
9880 and then Present (Proper_Body (Body_Decl))
9882 Body_Decl := Proper_Body (Body_Decl);
9890 end Load_Package_Body;
9894 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
9896 -- Start of processing for Has_Body
9899 -- The body is available
9901 if Present (Corresponding_Body (Pack_Decl)) then
9904 -- The body is required if the package spec contains a construct which
9905 -- requires a completion in a body.
9907 elsif Unit_Requires_Body (Pack_Id) then
9910 -- The body may be optional
9913 return Present (Find_Corresponding_Body (Pack_Id));
9921 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type is
9922 pragma Assert (Present (NE));
9924 return Bucket_Range_Type (NE);
9927 --------------------------
9928 -- In_External_Instance --
9929 --------------------------
9931 function In_External_Instance
9933 Target_Decl : Node_Id) return Boolean
9936 Inst_Body : Node_Id;
9937 Inst_Spec : Node_Id;
9940 Inst := Find_Enclosing_Instance (Target_Decl);
9942 -- The target declaration appears within an instance spec. Visibility is
9943 -- ignored because internally generated primitives for private types may
9944 -- reside in the private declarations and still be invoked from outside.
9946 if Present (Inst) and then Nkind (Inst) = N_Package_Declaration then
9948 -- The scenario comes from the main unit and the instance does not
9950 if In_Extended_Main_Code_Unit (N)
9951 and then not In_Extended_Main_Code_Unit (Inst)
9955 -- Otherwise the scenario must not appear within the instance spec or
9959 Spec_And_Body_From_Node
9961 Spec_Decl => Inst_Spec,
9962 Body_Decl => Inst_Body);
9964 return not In_Subtree
9967 Root2 => Inst_Body);
9972 end In_External_Instance;
9974 ---------------------
9975 -- In_Main_Context --
9976 ---------------------
9978 function In_Main_Context (N : Node_Id) return Boolean is
9980 -- Scenarios outside the main unit are not considered because the ALI
9981 -- information supplied to binde is for the main unit only.
9983 if not In_Extended_Main_Code_Unit (N) then
9986 -- Scenarios within internal units are not considered unless switch
9987 -- -gnatdE (elaboration checks on predefined units) is in effect.
9989 elsif not Debug_Flag_EE and then In_Internal_Unit (N) then
9994 end In_Main_Context;
9996 ---------------------
9997 -- In_Same_Context --
9998 ---------------------
10000 function In_Same_Context
10003 Nested_OK : Boolean := False) return Boolean
10005 function Find_Enclosing_Context (N : Node_Id) return Node_Id;
10006 pragma Inline (Find_Enclosing_Context);
10007 -- Return the nearest enclosing non-library-level or compilation unit
10008 -- node which which encapsulates arbitrary node N. Return Empty is no
10009 -- such context is available.
10011 function In_Nested_Context
10013 Inner : Node_Id) return Boolean;
10014 pragma Inline (In_Nested_Context);
10015 -- Determine whether arbitrary node Outer encapsulates arbitrary node
10018 ----------------------------
10019 -- Find_Enclosing_Context --
10020 ----------------------------
10022 function Find_Enclosing_Context (N : Node_Id) return Node_Id is
10028 while Present (Par) loop
10030 -- A traversal from a subunit continues via the corresponding stub
10032 if Nkind (Par) = N_Subunit then
10033 Par := Corresponding_Stub (Par);
10035 -- Stop the traversal when the nearest enclosing non-library-level
10036 -- encapsulator has been reached.
10038 elsif Is_Non_Library_Level_Encapsulator (Par) then
10039 Context := Parent (Par);
10041 -- The sole exception is when the encapsulator is the unit of
10042 -- compilation because this case requires special processing
10045 if Present (Context)
10046 and then Nkind (Context) = N_Compilation_Unit
10054 -- Reaching a compilation unit node without hitting a non-library-
10055 -- level encapsulator indicates that N is at the library level in
10056 -- which case the compilation unit is the context.
10058 elsif Nkind (Par) = N_Compilation_Unit then
10062 Par := Parent (Par);
10066 end Find_Enclosing_Context;
10068 -----------------------
10069 -- In_Nested_Context --
10070 -----------------------
10072 function In_Nested_Context
10074 Inner : Node_Id) return Boolean
10080 while Present (Par) loop
10082 -- A traversal from a subunit continues via the corresponding stub
10084 if Nkind (Par) = N_Subunit then
10085 Par := Corresponding_Stub (Par);
10087 elsif Par = Outer then
10091 Par := Parent (Par);
10095 end In_Nested_Context;
10099 Context_1 : constant Node_Id := Find_Enclosing_Context (N1);
10100 Context_2 : constant Node_Id := Find_Enclosing_Context (N2);
10102 -- Start of processing for In_Same_Context
10105 -- Both nodes appear within the same context
10107 if Context_1 = Context_2 then
10110 -- Both nodes appear in compilation units. Determine whether one unit
10111 -- is the body of the other.
10113 elsif Nkind (Context_1) = N_Compilation_Unit
10114 and then Nkind (Context_2) = N_Compilation_Unit
10118 (Unit_1 => Defining_Entity (Unit (Context_1)),
10119 Unit_2 => Defining_Entity (Unit (Context_2)));
10121 -- The context of N1 encloses the context of N2
10123 elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then
10128 end In_Same_Context;
10134 procedure Initialize is
10136 -- Set the soft link which enables Atree.Rewrite to update a scenario
10137 -- each time it is transformed into another node.
10139 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access);
10141 -- Create all internal data structures and activate the elaboration
10142 -- phase of the compiler.
10144 Initialize_All_Data_Structures;
10145 Set_Elaboration_Phase (Active);
10148 ------------------------------------
10149 -- Initialize_All_Data_Structures --
10150 ------------------------------------
10152 procedure Initialize_All_Data_Structures is
10154 Initialize_Body_Processor;
10155 Initialize_Early_Call_Region_Processor;
10156 Initialize_Elaborated_Units;
10157 Initialize_Internal_Representation;
10158 Initialize_Invocation_Graph;
10159 Initialize_Scenario_Storage;
10160 end Initialize_All_Data_Structures;
10162 --------------------------
10163 -- Instantiated_Generic --
10164 --------------------------
10166 function Instantiated_Generic (Inst : Node_Id) return Entity_Id is
10168 -- Traverse a possible chain of renamings to obtain the original generic
10169 -- being instantiatied.
10171 return Get_Renamed_Entity (Entity (Name (Inst)));
10172 end Instantiated_Generic;
10174 -----------------------------
10175 -- Internal_Representation --
10176 -----------------------------
10178 package body Internal_Representation is
10184 -- The following type represents the contents of a scenario
10186 type Scenario_Rep_Record is record
10187 Elab_Checks_OK : Boolean := False;
10188 -- The status of elaboration checks for the scenario
10190 Elab_Warnings_OK : Boolean := False;
10191 -- The status of elaboration warnings for the scenario
10193 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified;
10194 -- The Ghost mode of the scenario
10196 Kind : Scenario_Kind := No_Scenario;
10197 -- The nature of the scenario
10199 Level : Enclosing_Level_Kind := No_Level;
10200 -- The enclosing level where the scenario resides
10202 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified;
10203 -- The SPARK mode of the scenario
10205 Target : Entity_Id := Empty;
10206 -- The target of the scenario
10208 -- The following attributes are multiplexed and depend on the Kind of
10209 -- the scenario. They are mapped as follows:
10212 -- Is_Dispatching_Call (Flag_1)
10214 -- Task_Activation_Scenario
10215 -- Activated_Task_Objects (List_1)
10216 -- Activated_Task_Type (Field_1)
10218 -- Variable_Reference
10219 -- Is_Read_Reference (Flag_1)
10221 Flag_1 : Boolean := False;
10222 Field_1 : Node_Or_Entity_Id := Empty;
10223 List_1 : NE_List.Doubly_Linked_List := NE_List.Nil;
10226 -- The following type represents the contents of a target
10228 type Target_Rep_Record is record
10229 Body_Decl : Node_Id := Empty;
10230 -- The declaration of the target body
10232 Elab_Checks_OK : Boolean := False;
10233 -- The status of elaboration checks for the target
10235 Elab_Warnings_OK : Boolean := False;
10236 -- The status of elaboration warnings for the target
10238 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified;
10239 -- The Ghost mode of the target
10241 Kind : Target_Kind := No_Target;
10242 -- The nature of the target
10244 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified;
10245 -- The SPARK mode of the target
10247 Spec_Decl : Node_Id := Empty;
10248 -- The declaration of the target spec
10250 Unit : Entity_Id := Empty;
10251 -- The top unit where the target is declared
10253 Version : Representation_Kind := No_Representation;
10254 -- The version of the target representation
10256 -- The following attributes are multiplexed and depend on the Kind of
10257 -- the target. They are mapped as follows:
10259 -- Subprogram_Target
10260 -- Barrier_Body_Declaration (Field_1)
10263 -- Variable_Declaration (Field_1)
10265 Field_1 : Node_Or_Entity_Id := Empty;
10268 ---------------------
10269 -- Data structures --
10270 ---------------------
10272 procedure Destroy (T_Id : in out Target_Rep_Id);
10273 -- Destroy a target representation T_Id
10275 package ETT_Map is new Dynamic_Hash_Tables
10276 (Key_Type => Entity_Id,
10277 Value_Type => Target_Rep_Id,
10278 No_Value => No_Target_Rep,
10279 Expansion_Threshold => 1.5,
10280 Expansion_Factor => 2,
10281 Compression_Threshold => 0.3,
10282 Compression_Factor => 2,
10284 Destroy_Value => Destroy,
10287 -- The following map relates target representations to entities
10289 Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := ETT_Map.Nil;
10291 procedure Destroy (S_Id : in out Scenario_Rep_Id);
10292 -- Destroy a scenario representation S_Id
10294 package NTS_Map is new Dynamic_Hash_Tables
10295 (Key_Type => Node_Id,
10296 Value_Type => Scenario_Rep_Id,
10297 No_Value => No_Scenario_Rep,
10298 Expansion_Threshold => 1.5,
10299 Expansion_Factor => 2,
10300 Compression_Threshold => 0.3,
10301 Compression_Factor => 2,
10303 Destroy_Value => Destroy,
10306 -- The following map relates scenario representations to nodes
10308 Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := NTS_Map.Nil;
10310 -- The following table stores all scenario representations
10312 package Scenario_Reps is new Table.Table
10313 (Table_Index_Type => Scenario_Rep_Id,
10314 Table_Component_Type => Scenario_Rep_Record,
10315 Table_Low_Bound => First_Scenario_Rep,
10316 Table_Initial => 1000,
10317 Table_Increment => 200,
10318 Table_Name => "Scenario_Reps");
10320 -- The following table stores all target representations
10322 package Target_Reps is new Table.Table
10323 (Table_Index_Type => Target_Rep_Id,
10324 Table_Component_Type => Target_Rep_Record,
10325 Table_Low_Bound => First_Target_Rep,
10326 Table_Initial => 1000,
10327 Table_Increment => 200,
10328 Table_Name => "Target_Reps");
10334 function Create_Access_Taken_Rep
10335 (Attr : Node_Id) return Scenario_Rep_Record;
10336 pragma Inline (Create_Access_Taken_Rep);
10337 -- Create the representation of 'Access attribute Attr
10339 function Create_Call_Or_Task_Activation_Rep
10340 (Call : Node_Id) return Scenario_Rep_Record;
10341 pragma Inline (Create_Call_Or_Task_Activation_Rep);
10342 -- Create the representation of call or task activation Call
10344 function Create_Derived_Type_Rep
10345 (Typ_Decl : Node_Id) return Scenario_Rep_Record;
10346 pragma Inline (Create_Derived_Type_Rep);
10347 -- Create the representation of a derived type described by declaration
10350 function Create_Generic_Rep
10351 (Gen_Id : Entity_Id) return Target_Rep_Record;
10352 pragma Inline (Create_Generic_Rep);
10353 -- Create the representation of generic Gen_Id
10355 function Create_Instantiation_Rep
10356 (Inst : Node_Id) return Scenario_Rep_Record;
10357 pragma Inline (Create_Instantiation_Rep);
10358 -- Create the representation of instantiation Inst
10360 function Create_Package_Rep
10361 (Pack_Id : Entity_Id) return Target_Rep_Record;
10362 pragma Inline (Create_Package_Rep);
10363 -- Create the representation of package Pack_Id
10365 function Create_Protected_Entry_Rep
10366 (PE_Id : Entity_Id) return Target_Rep_Record;
10367 pragma Inline (Create_Protected_Entry_Rep);
10368 -- Create the representation of protected entry PE_Id
10370 function Create_Protected_Subprogram_Rep
10371 (PS_Id : Entity_Id) return Target_Rep_Record;
10372 pragma Inline (Create_Protected_Subprogram_Rep);
10373 -- Create the representation of protected subprogram PS_Id
10375 function Create_Refined_State_Pragma_Rep
10376 (Prag : Node_Id) return Scenario_Rep_Record;
10377 pragma Inline (Create_Refined_State_Pragma_Rep);
10378 -- Create the representation of Refined_State pragma Prag
10380 function Create_Scenario_Rep
10382 In_State : Processing_In_State) return Scenario_Rep_Record;
10383 pragma Inline (Create_Scenario_Rep);
10384 -- Top level dispatcher. Create the representation of elaboration
10385 -- scenario N. In_State is the current state of the Processing phase.
10387 function Create_Subprogram_Rep
10388 (Subp_Id : Entity_Id) return Target_Rep_Record;
10389 pragma Inline (Create_Subprogram_Rep);
10390 -- Create the representation of entry, operator, or subprogram Subp_Id
10392 function Create_Target_Rep
10394 In_State : Processing_In_State) return Target_Rep_Record;
10395 pragma Inline (Create_Target_Rep);
10396 -- Top level dispatcher. Create the representation of elaboration target
10397 -- Id. In_State is the current state of the Processing phase.
10399 function Create_Task_Entry_Rep
10400 (TE_Id : Entity_Id) return Target_Rep_Record;
10401 pragma Inline (Create_Task_Entry_Rep);
10402 -- Create the representation of task entry TE_Id
10404 function Create_Task_Rep (Task_Typ : Entity_Id) return Target_Rep_Record;
10405 pragma Inline (Create_Task_Rep);
10406 -- Create the representation of task type Typ
10408 function Create_Variable_Assignment_Rep
10409 (Asmt : Node_Id) return Scenario_Rep_Record;
10410 pragma Inline (Create_Variable_Assignment_Rep);
10411 -- Create the representation of variable assignment Asmt
10413 function Create_Variable_Reference_Rep
10414 (Ref : Node_Id) return Scenario_Rep_Record;
10415 pragma Inline (Create_Variable_Reference_Rep);
10416 -- Create the representation of variable reference Ref
10418 function Create_Variable_Rep
10419 (Var_Id : Entity_Id) return Target_Rep_Record;
10420 pragma Inline (Create_Variable_Rep);
10421 -- Create the representation of variable Var_Id
10423 -----------------------
10424 -- Local subprograms --
10425 -----------------------
10427 function Ghost_Mode_Of_Entity
10428 (Id : Entity_Id) return Extended_Ghost_Mode;
10429 pragma Inline (Ghost_Mode_Of_Entity);
10430 -- Obtain the extended Ghost mode of arbitrary entity Id
10432 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode;
10433 pragma Inline (Ghost_Mode_Of_Node);
10434 -- Obtain the extended Ghost mode of arbitrary node N
10436 function Present (S_Id : Scenario_Rep_Id) return Boolean;
10437 pragma Inline (Present);
10438 -- Determine whether scenario representation S_Id exists
10440 function Present (T_Id : Target_Rep_Id) return Boolean;
10441 pragma Inline (Present);
10442 -- Determine whether target representation T_Id exists
10444 function SPARK_Mode_Of_Entity
10445 (Id : Entity_Id) return Extended_SPARK_Mode;
10446 pragma Inline (SPARK_Mode_Of_Entity);
10447 -- Obtain the extended SPARK mode of arbitrary entity Id
10449 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode;
10450 pragma Inline (SPARK_Mode_Of_Node);
10451 -- Obtain the extended SPARK mode of arbitrary node N
10453 function To_Ghost_Mode
10454 (Ignored_Status : Boolean) return Extended_Ghost_Mode;
10455 pragma Inline (To_Ghost_Mode);
10456 -- Convert a Ghost mode indicated by Ignored_Status into its extended
10459 function To_SPARK_Mode (On_Status : Boolean) return Extended_SPARK_Mode;
10460 pragma Inline (To_SPARK_Mode);
10461 -- Convert a SPARK mode indicated by On_Status into its extended
10464 function Version (T_Id : Target_Rep_Id) return Representation_Kind;
10465 pragma Inline (Version);
10466 -- Obtain the version of target representation T_Id
10468 ----------------------------
10469 -- Activated_Task_Objects --
10470 ----------------------------
10472 function Activated_Task_Objects
10473 (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List
10475 pragma Assert (Present (S_Id));
10476 pragma Assert (Kind (S_Id) = Task_Activation_Scenario);
10479 return Scenario_Reps.Table (S_Id).List_1;
10480 end Activated_Task_Objects;
10482 -------------------------
10483 -- Activated_Task_Type --
10484 -------------------------
10486 function Activated_Task_Type
10487 (S_Id : Scenario_Rep_Id) return Entity_Id
10489 pragma Assert (Present (S_Id));
10490 pragma Assert (Kind (S_Id) = Task_Activation_Scenario);
10493 return Scenario_Reps.Table (S_Id).Field_1;
10494 end Activated_Task_Type;
10496 ------------------------------
10497 -- Barrier_Body_Declaration --
10498 ------------------------------
10500 function Barrier_Body_Declaration
10501 (T_Id : Target_Rep_Id) return Node_Id
10503 pragma Assert (Present (T_Id));
10504 pragma Assert (Kind (T_Id) = Subprogram_Target);
10507 return Target_Reps.Table (T_Id).Field_1;
10508 end Barrier_Body_Declaration;
10510 ----------------------
10511 -- Body_Declaration --
10512 ----------------------
10514 function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id is
10515 pragma Assert (Present (T_Id));
10517 return Target_Reps.Table (T_Id).Body_Decl;
10518 end Body_Declaration;
10520 -----------------------------
10521 -- Create_Access_Taken_Rep --
10522 -----------------------------
10524 function Create_Access_Taken_Rep
10525 (Attr : Node_Id) return Scenario_Rep_Record
10527 Rec : Scenario_Rep_Record;
10530 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Attr);
10531 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Attr);
10532 Rec.GM := Is_Checked_Or_Not_Specified;
10533 Rec.SM := SPARK_Mode_Of_Node (Attr);
10534 Rec.Kind := Access_Taken_Scenario;
10535 Rec.Target := Canonical_Subprogram (Entity (Prefix (Attr)));
10538 end Create_Access_Taken_Rep;
10540 ----------------------------------------
10541 -- Create_Call_Or_Task_Activation_Rep --
10542 ----------------------------------------
10544 function Create_Call_Or_Task_Activation_Rep
10545 (Call : Node_Id) return Scenario_Rep_Record
10547 Subp_Id : constant Entity_Id := Canonical_Subprogram (Target (Call));
10548 Kind : Scenario_Kind;
10549 Rec : Scenario_Rep_Record;
10552 if Is_Activation_Proc (Subp_Id) then
10553 Kind := Task_Activation_Scenario;
10555 Kind := Call_Scenario;
10558 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call);
10559 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call);
10560 Rec.GM := Ghost_Mode_Of_Node (Call);
10561 Rec.SM := SPARK_Mode_Of_Node (Call);
10563 Rec.Target := Subp_Id;
10565 -- Scenario-specific attributes
10567 Rec.Flag_1 := Is_Dispatching_Call (Call); -- Dispatching_Call
10570 end Create_Call_Or_Task_Activation_Rep;
10572 -----------------------------
10573 -- Create_Derived_Type_Rep --
10574 -----------------------------
10576 function Create_Derived_Type_Rep
10577 (Typ_Decl : Node_Id) return Scenario_Rep_Record
10579 Typ : constant Entity_Id := Defining_Entity (Typ_Decl);
10580 Rec : Scenario_Rep_Record;
10583 Rec.Elab_Checks_OK := False; -- not relevant
10584 Rec.Elab_Warnings_OK := False; -- not relevant
10585 Rec.GM := Ghost_Mode_Of_Entity (Typ);
10586 Rec.SM := SPARK_Mode_Of_Entity (Typ);
10587 Rec.Kind := Derived_Type_Scenario;
10591 end Create_Derived_Type_Rep;
10593 ------------------------
10594 -- Create_Generic_Rep --
10595 ------------------------
10597 function Create_Generic_Rep
10598 (Gen_Id : Entity_Id) return Target_Rep_Record
10600 Rec : Target_Rep_Record;
10603 Rec.Kind := Generic_Target;
10605 Spec_And_Body_From_Entity
10607 Body_Decl => Rec.Body_Decl,
10608 Spec_Decl => Rec.Spec_Decl);
10611 end Create_Generic_Rep;
10613 ------------------------------
10614 -- Create_Instantiation_Rep --
10615 ------------------------------
10617 function Create_Instantiation_Rep
10618 (Inst : Node_Id) return Scenario_Rep_Record
10620 Rec : Scenario_Rep_Record;
10623 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst);
10624 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst);
10625 Rec.GM := Ghost_Mode_Of_Node (Inst);
10626 Rec.SM := SPARK_Mode_Of_Node (Inst);
10627 Rec.Kind := Instantiation_Scenario;
10628 Rec.Target := Instantiated_Generic (Inst);
10631 end Create_Instantiation_Rep;
10633 ------------------------
10634 -- Create_Package_Rep --
10635 ------------------------
10637 function Create_Package_Rep
10638 (Pack_Id : Entity_Id) return Target_Rep_Record
10640 Rec : Target_Rep_Record;
10643 Rec.Kind := Package_Target;
10645 Spec_And_Body_From_Entity
10647 Body_Decl => Rec.Body_Decl,
10648 Spec_Decl => Rec.Spec_Decl);
10651 end Create_Package_Rep;
10653 --------------------------------
10654 -- Create_Protected_Entry_Rep --
10655 --------------------------------
10657 function Create_Protected_Entry_Rep
10658 (PE_Id : Entity_Id) return Target_Rep_Record
10660 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PE_Id);
10662 Barf_Id : Entity_Id;
10664 Rec : Target_Rep_Record;
10665 Spec_Id : Entity_Id;
10668 -- When the entry [family] has already been expanded, it carries both
10669 -- the procedure which emulates the behavior of the entry [family] as
10670 -- well as the barrier function.
10672 if Present (Prot_Id) then
10673 Barf_Id := Barrier_Function (PE_Id);
10674 Spec_Id := Prot_Id;
10676 -- Otherwise no expansion took place
10683 Rec.Kind := Subprogram_Target;
10685 Spec_And_Body_From_Entity
10687 Body_Decl => Rec.Body_Decl,
10688 Spec_Decl => Rec.Spec_Decl);
10690 -- Target-specific attributes
10692 if Present (Barf_Id) then
10693 Spec_And_Body_From_Entity
10695 Body_Decl => Rec.Field_1, -- Barrier_Body_Declaration
10696 Spec_Decl => Dummy);
10700 end Create_Protected_Entry_Rep;
10702 -------------------------------------
10703 -- Create_Protected_Subprogram_Rep --
10704 -------------------------------------
10706 function Create_Protected_Subprogram_Rep
10707 (PS_Id : Entity_Id) return Target_Rep_Record
10709 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PS_Id);
10710 Rec : Target_Rep_Record;
10711 Spec_Id : Entity_Id;
10714 -- When the protected subprogram has already been expanded, it
10715 -- carries the subprogram which seizes the lock and invokes the
10716 -- original statements.
10718 if Present (Prot_Id) then
10719 Spec_Id := Prot_Id;
10721 -- Otherwise no expansion took place
10727 Rec.Kind := Subprogram_Target;
10729 Spec_And_Body_From_Entity
10731 Body_Decl => Rec.Body_Decl,
10732 Spec_Decl => Rec.Spec_Decl);
10735 end Create_Protected_Subprogram_Rep;
10737 -------------------------------------
10738 -- Create_Refined_State_Pragma_Rep --
10739 -------------------------------------
10741 function Create_Refined_State_Pragma_Rep
10742 (Prag : Node_Id) return Scenario_Rep_Record
10744 Rec : Scenario_Rep_Record;
10747 Rec.Elab_Checks_OK := False; -- not relevant
10748 Rec.Elab_Warnings_OK := False; -- not relevant
10750 To_Ghost_Mode (Is_Ignored_Ghost_Pragma (Prag));
10751 Rec.SM := Is_Off_Or_Not_Specified;
10752 Rec.Kind := Refined_State_Pragma_Scenario;
10753 Rec.Target := Empty;
10756 end Create_Refined_State_Pragma_Rep;
10758 -------------------------
10759 -- Create_Scenario_Rep --
10760 -------------------------
10762 function Create_Scenario_Rep
10764 In_State : Processing_In_State) return Scenario_Rep_Record
10766 pragma Unreferenced (In_State);
10768 Rec : Scenario_Rep_Record;
10771 if Is_Suitable_Access_Taken (N) then
10772 Rec := Create_Access_Taken_Rep (N);
10774 elsif Is_Suitable_Call (N) then
10775 Rec := Create_Call_Or_Task_Activation_Rep (N);
10777 elsif Is_Suitable_Instantiation (N) then
10778 Rec := Create_Instantiation_Rep (N);
10780 elsif Is_Suitable_SPARK_Derived_Type (N) then
10781 Rec := Create_Derived_Type_Rep (N);
10783 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then
10784 Rec := Create_Refined_State_Pragma_Rep (N);
10786 elsif Is_Suitable_Variable_Assignment (N) then
10787 Rec := Create_Variable_Assignment_Rep (N);
10789 elsif Is_Suitable_Variable_Reference (N) then
10790 Rec := Create_Variable_Reference_Rep (N);
10793 pragma Assert (False);
10797 -- Common scenario attributes
10799 Rec.Level := Find_Enclosing_Level (N);
10802 end Create_Scenario_Rep;
10804 ---------------------------
10805 -- Create_Subprogram_Rep --
10806 ---------------------------
10808 function Create_Subprogram_Rep
10809 (Subp_Id : Entity_Id) return Target_Rep_Record
10811 Rec : Target_Rep_Record;
10812 Spec_Id : Entity_Id;
10815 Spec_Id := Subp_Id;
10817 -- The elaboration target denotes an internal function that returns a
10818 -- constrained array type in a SPARK-to-C compilation. In this case
10819 -- the function receives a corresponding procedure which has an out
10820 -- parameter. The proper body for ABE checks and diagnostics is that
10821 -- of the procedure.
10823 if Ekind (Spec_Id) = E_Function
10824 and then Rewritten_For_C (Spec_Id)
10826 Spec_Id := Corresponding_Procedure (Spec_Id);
10829 Rec.Kind := Subprogram_Target;
10831 Spec_And_Body_From_Entity
10833 Body_Decl => Rec.Body_Decl,
10834 Spec_Decl => Rec.Spec_Decl);
10837 end Create_Subprogram_Rep;
10839 -----------------------
10840 -- Create_Target_Rep --
10841 -----------------------
10843 function Create_Target_Rep
10845 In_State : Processing_In_State) return Target_Rep_Record
10847 Rec : Target_Rep_Record;
10850 if Is_Generic_Unit (Id) then
10851 Rec := Create_Generic_Rep (Id);
10853 elsif Is_Protected_Entry (Id) then
10854 Rec := Create_Protected_Entry_Rep (Id);
10856 elsif Is_Protected_Subp (Id) then
10857 Rec := Create_Protected_Subprogram_Rep (Id);
10859 elsif Is_Task_Entry (Id) then
10860 Rec := Create_Task_Entry_Rep (Id);
10862 elsif Is_Task_Type (Id) then
10863 Rec := Create_Task_Rep (Id);
10865 elsif Ekind_In (Id, E_Constant, E_Variable) then
10866 Rec := Create_Variable_Rep (Id);
10868 elsif Ekind_In (Id, E_Entry,
10873 Rec := Create_Subprogram_Rep (Id);
10875 elsif Ekind (Id) = E_Package then
10876 Rec := Create_Package_Rep (Id);
10879 pragma Assert (False);
10883 -- Common target attributes
10885 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Id);
10886 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Id);
10887 Rec.GM := Ghost_Mode_Of_Entity (Id);
10888 Rec.SM := SPARK_Mode_Of_Entity (Id);
10889 Rec.Unit := Find_Top_Unit (Id);
10890 Rec.Version := In_State.Representation;
10893 end Create_Target_Rep;
10895 ---------------------------
10896 -- Create_Task_Entry_Rep --
10897 ---------------------------
10899 function Create_Task_Entry_Rep
10900 (TE_Id : Entity_Id) return Target_Rep_Record
10902 Task_Typ : constant Entity_Id := Non_Private_View (Scope (TE_Id));
10903 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ);
10905 Rec : Target_Rep_Record;
10906 Spec_Id : Entity_Id;
10909 -- The the task type has already been expanded, it carries the
10910 -- procedure which emulates the behavior of the task body.
10912 if Present (Task_Body_Id) then
10913 Spec_Id := Task_Body_Id;
10915 -- Otherwise no expansion took place
10921 Rec.Kind := Subprogram_Target;
10923 Spec_And_Body_From_Entity
10925 Body_Decl => Rec.Body_Decl,
10926 Spec_Decl => Rec.Spec_Decl);
10929 end Create_Task_Entry_Rep;
10931 ---------------------
10932 -- Create_Task_Rep --
10933 ---------------------
10935 function Create_Task_Rep
10936 (Task_Typ : Entity_Id) return Target_Rep_Record
10938 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ);
10940 Rec : Target_Rep_Record;
10941 Spec_Id : Entity_Id;
10944 -- The the task type has already been expanded, it carries the
10945 -- procedure which emulates the behavior of the task body.
10947 if Present (Task_Body_Id) then
10948 Spec_Id := Task_Body_Id;
10950 -- Otherwise no expansion took place
10953 Spec_Id := Task_Typ;
10956 Rec.Kind := Task_Target;
10958 Spec_And_Body_From_Entity
10960 Body_Decl => Rec.Body_Decl,
10961 Spec_Decl => Rec.Spec_Decl);
10964 end Create_Task_Rep;
10966 ------------------------------------
10967 -- Create_Variable_Assignment_Rep --
10968 ------------------------------------
10970 function Create_Variable_Assignment_Rep
10971 (Asmt : Node_Id) return Scenario_Rep_Record
10973 Var_Id : constant Entity_Id := Entity (Assignment_Target (Asmt));
10974 Rec : Scenario_Rep_Record;
10977 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Asmt);
10978 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Var_Id);
10979 Rec.GM := Ghost_Mode_Of_Node (Asmt);
10980 Rec.SM := SPARK_Mode_Of_Node (Asmt);
10981 Rec.Kind := Variable_Assignment_Scenario;
10982 Rec.Target := Var_Id;
10985 end Create_Variable_Assignment_Rep;
10987 -----------------------------------
10988 -- Create_Variable_Reference_Rep --
10989 -----------------------------------
10991 function Create_Variable_Reference_Rep
10992 (Ref : Node_Id) return Scenario_Rep_Record
10994 Rec : Scenario_Rep_Record;
10997 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Ref);
10998 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Ref);
10999 Rec.GM := Ghost_Mode_Of_Node (Ref);
11000 Rec.SM := SPARK_Mode_Of_Node (Ref);
11001 Rec.Kind := Variable_Reference_Scenario;
11002 Rec.Target := Target (Ref);
11004 -- Scenario-specific attributes
11006 Rec.Flag_1 := Is_Read (Ref); -- Is_Read_Reference
11009 end Create_Variable_Reference_Rep;
11011 -------------------------
11012 -- Create_Variable_Rep --
11013 -------------------------
11015 function Create_Variable_Rep
11016 (Var_Id : Entity_Id) return Target_Rep_Record
11018 Rec : Target_Rep_Record;
11021 Rec.Kind := Variable_Target;
11023 -- Target-specific attributes
11025 Rec.Field_1 := Declaration_Node (Var_Id); -- Variable_Declaration
11028 end Create_Variable_Rep;
11034 procedure Destroy (S_Id : in out Scenario_Rep_Id) is
11035 pragma Unreferenced (S_Id);
11044 procedure Destroy (T_Id : in out Target_Rep_Id) is
11045 pragma Unreferenced (T_Id);
11050 --------------------------------
11051 -- Disable_Elaboration_Checks --
11052 --------------------------------
11054 procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id) is
11055 pragma Assert (Present (S_Id));
11057 Scenario_Reps.Table (S_Id).Elab_Checks_OK := False;
11058 end Disable_Elaboration_Checks;
11060 --------------------------------
11061 -- Disable_Elaboration_Checks --
11062 --------------------------------
11064 procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id) is
11065 pragma Assert (Present (T_Id));
11067 Target_Reps.Table (T_Id).Elab_Checks_OK := False;
11068 end Disable_Elaboration_Checks;
11070 ---------------------------
11071 -- Elaboration_Checks_OK --
11072 ---------------------------
11074 function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean is
11075 pragma Assert (Present (S_Id));
11077 return Scenario_Reps.Table (S_Id).Elab_Checks_OK;
11078 end Elaboration_Checks_OK;
11080 ---------------------------
11081 -- Elaboration_Checks_OK --
11082 ---------------------------
11084 function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean is
11085 pragma Assert (Present (T_Id));
11087 return Target_Reps.Table (T_Id).Elab_Checks_OK;
11088 end Elaboration_Checks_OK;
11090 -----------------------------
11091 -- Elaboration_Warnings_OK --
11092 -----------------------------
11094 function Elaboration_Warnings_OK
11095 (S_Id : Scenario_Rep_Id) return Boolean
11097 pragma Assert (Present (S_Id));
11099 return Scenario_Reps.Table (S_Id).Elab_Warnings_OK;
11100 end Elaboration_Warnings_OK;
11102 -----------------------------
11103 -- Elaboration_Warnings_OK --
11104 -----------------------------
11106 function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean is
11107 pragma Assert (Present (T_Id));
11109 return Target_Reps.Table (T_Id).Elab_Warnings_OK;
11110 end Elaboration_Warnings_OK;
11112 --------------------------------------
11113 -- Finalize_Internal_Representation --
11114 --------------------------------------
11116 procedure Finalize_Internal_Representation is
11118 ETT_Map.Destroy (Entity_To_Target_Map);
11119 NTS_Map.Destroy (Node_To_Scenario_Map);
11120 end Finalize_Internal_Representation;
11122 -------------------
11123 -- Ghost_Mode_Of --
11124 -------------------
11126 function Ghost_Mode_Of
11127 (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode
11129 pragma Assert (Present (S_Id));
11131 return Scenario_Reps.Table (S_Id).GM;
11134 -------------------
11135 -- Ghost_Mode_Of --
11136 -------------------
11138 function Ghost_Mode_Of
11139 (T_Id : Target_Rep_Id) return Extended_Ghost_Mode
11141 pragma Assert (Present (T_Id));
11143 return Target_Reps.Table (T_Id).GM;
11146 --------------------------
11147 -- Ghost_Mode_Of_Entity --
11148 --------------------------
11150 function Ghost_Mode_Of_Entity
11151 (Id : Entity_Id) return Extended_Ghost_Mode
11154 return To_Ghost_Mode (Is_Ignored_Ghost_Entity (Id));
11155 end Ghost_Mode_Of_Entity;
11157 ------------------------
11158 -- Ghost_Mode_Of_Node --
11159 ------------------------
11161 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode is
11163 return To_Ghost_Mode (Is_Ignored_Ghost_Node (N));
11164 end Ghost_Mode_Of_Node;
11166 ----------------------------------------
11167 -- Initialize_Internal_Representation --
11168 ----------------------------------------
11170 procedure Initialize_Internal_Representation is
11172 Entity_To_Target_Map := ETT_Map.Create (500);
11173 Node_To_Scenario_Map := NTS_Map.Create (500);
11174 end Initialize_Internal_Representation;
11176 -------------------------
11177 -- Is_Dispatching_Call --
11178 -------------------------
11180 function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean is
11181 pragma Assert (Present (S_Id));
11182 pragma Assert (Kind (S_Id) = Call_Scenario);
11185 return Scenario_Reps.Table (S_Id).Flag_1;
11186 end Is_Dispatching_Call;
11188 -----------------------
11189 -- Is_Read_Reference --
11190 -----------------------
11192 function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean is
11193 pragma Assert (Present (S_Id));
11194 pragma Assert (Kind (S_Id) = Variable_Reference_Scenario);
11197 return Scenario_Reps.Table (S_Id).Flag_1;
11198 end Is_Read_Reference;
11204 function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind is
11205 pragma Assert (Present (S_Id));
11207 return Scenario_Reps.Table (S_Id).Kind;
11214 function Kind (T_Id : Target_Rep_Id) return Target_Kind is
11215 pragma Assert (Present (T_Id));
11217 return Target_Reps.Table (T_Id).Kind;
11224 function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind is
11225 pragma Assert (Present (S_Id));
11227 return Scenario_Reps.Table (S_Id).Level;
11234 function Present (S_Id : Scenario_Rep_Id) return Boolean is
11236 return S_Id /= No_Scenario_Rep;
11243 function Present (T_Id : Target_Rep_Id) return Boolean is
11245 return T_Id /= No_Target_Rep;
11248 --------------------------------
11249 -- Scenario_Representation_Of --
11250 --------------------------------
11252 function Scenario_Representation_Of
11254 In_State : Processing_In_State) return Scenario_Rep_Id
11256 S_Id : Scenario_Rep_Id;
11259 S_Id := NTS_Map.Get (Node_To_Scenario_Map, N);
11261 -- The elaboration scenario lacks a representation. This indicates
11262 -- that the scenario is encountered for the first time. Create the
11263 -- representation of it.
11265 if not Present (S_Id) then
11266 Scenario_Reps.Append (Create_Scenario_Rep (N, In_State));
11267 S_Id := Scenario_Reps.Last;
11269 -- Associate the internal representation with the elaboration
11272 NTS_Map.Put (Node_To_Scenario_Map, N, S_Id);
11275 pragma Assert (Present (S_Id));
11278 end Scenario_Representation_Of;
11280 --------------------------------
11281 -- Set_Activated_Task_Objects --
11282 --------------------------------
11284 procedure Set_Activated_Task_Objects
11285 (S_Id : Scenario_Rep_Id;
11286 Task_Objs : NE_List.Doubly_Linked_List)
11288 pragma Assert (Present (S_Id));
11289 pragma Assert (Kind (S_Id) = Task_Activation_Scenario);
11292 Scenario_Reps.Table (S_Id).List_1 := Task_Objs;
11293 end Set_Activated_Task_Objects;
11295 -----------------------------
11296 -- Set_Activated_Task_Type --
11297 -----------------------------
11299 procedure Set_Activated_Task_Type
11300 (S_Id : Scenario_Rep_Id;
11301 Task_Typ : Entity_Id)
11303 pragma Assert (Present (S_Id));
11304 pragma Assert (Kind (S_Id) = Task_Activation_Scenario);
11307 Scenario_Reps.Table (S_Id).Field_1 := Task_Typ;
11308 end Set_Activated_Task_Type;
11310 -------------------
11311 -- SPARK_Mode_Of --
11312 -------------------
11314 function SPARK_Mode_Of
11315 (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode
11317 pragma Assert (Present (S_Id));
11319 return Scenario_Reps.Table (S_Id).SM;
11322 -------------------
11323 -- SPARK_Mode_Of --
11324 -------------------
11326 function SPARK_Mode_Of
11327 (T_Id : Target_Rep_Id) return Extended_SPARK_Mode
11329 pragma Assert (Present (T_Id));
11331 return Target_Reps.Table (T_Id).SM;
11334 --------------------------
11335 -- SPARK_Mode_Of_Entity --
11336 --------------------------
11338 function SPARK_Mode_Of_Entity
11339 (Id : Entity_Id) return Extended_SPARK_Mode
11341 Prag : constant Node_Id := SPARK_Pragma (Id);
11347 and then Get_SPARK_Mode_From_Annotation (Prag) = On);
11348 end SPARK_Mode_Of_Entity;
11350 ------------------------
11351 -- SPARK_Mode_Of_Node --
11352 ------------------------
11354 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode is
11356 return To_SPARK_Mode (Is_SPARK_Mode_On_Node (N));
11357 end SPARK_Mode_Of_Node;
11359 ----------------------
11360 -- Spec_Declaration --
11361 ----------------------
11363 function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id is
11364 pragma Assert (Present (T_Id));
11366 return Target_Reps.Table (T_Id).Spec_Decl;
11367 end Spec_Declaration;
11373 function Target (S_Id : Scenario_Rep_Id) return Entity_Id is
11374 pragma Assert (Present (S_Id));
11376 return Scenario_Reps.Table (S_Id).Target;
11379 ------------------------------
11380 -- Target_Representation_Of --
11381 ------------------------------
11383 function Target_Representation_Of
11385 In_State : Processing_In_State) return Target_Rep_Id
11387 T_Id : Target_Rep_Id;
11390 T_Id := ETT_Map.Get (Entity_To_Target_Map, Id);
11392 -- The elaboration target lacks an internal representation. This
11393 -- indicates that the target is encountered for the first time.
11394 -- Create the internal representation of it.
11396 if not Present (T_Id) then
11397 Target_Reps.Append (Create_Target_Rep (Id, In_State));
11398 T_Id := Target_Reps.Last;
11400 -- Associate the internal representation with the elaboration
11403 ETT_Map.Put (Entity_To_Target_Map, Id, T_Id);
11405 -- The Processing phase is working with a partially analyzed tree,
11406 -- where various attributes become available as analysis continues.
11407 -- This case arrises in the context of guaranteed ABE processing.
11408 -- Update the existing representation by including new attributes.
11410 elsif In_State.Representation = Inconsistent_Representation then
11411 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State);
11413 -- Otherwise the Processing phase imposes a particular representation
11414 -- version which is not satisfied by the target. This case arrises
11415 -- when the Processing phase switches from guaranteed ABE checks and
11416 -- diagnostics to some other mode of operation. Update the existing
11417 -- representation to include all attributes.
11419 elsif In_State.Representation /= Version (T_Id) then
11420 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State);
11423 pragma Assert (Present (T_Id));
11426 end Target_Representation_Of;
11428 -------------------
11429 -- To_Ghost_Mode --
11430 -------------------
11432 function To_Ghost_Mode
11433 (Ignored_Status : Boolean) return Extended_Ghost_Mode
11436 if Ignored_Status then
11439 return Is_Checked_Or_Not_Specified;
11443 -------------------
11444 -- To_SPARK_Mode --
11445 -------------------
11447 function To_SPARK_Mode
11448 (On_Status : Boolean) return Extended_SPARK_Mode
11454 return Is_Off_Or_Not_Specified;
11462 function Unit (T_Id : Target_Rep_Id) return Entity_Id is
11463 pragma Assert (Present (T_Id));
11465 return Target_Reps.Table (T_Id).Unit;
11468 --------------------------
11469 -- Variable_Declaration --
11470 --------------------------
11472 function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id is
11473 pragma Assert (Present (T_Id));
11474 pragma Assert (Kind (T_Id) = Variable_Target);
11477 return Target_Reps.Table (T_Id).Field_1;
11478 end Variable_Declaration;
11484 function Version (T_Id : Target_Rep_Id) return Representation_Kind is
11485 pragma Assert (Present (T_Id));
11487 return Target_Reps.Table (T_Id).Version;
11489 end Internal_Representation;
11491 ----------------------
11492 -- Invocation_Graph --
11493 ----------------------
11495 package body Invocation_Graph is
11501 -- The following type represents simplified version of an invocation
11504 type Invoker_Target_Relation is record
11505 Invoker : Entity_Id := Empty;
11506 Target : Entity_Id := Empty;
11509 -- The following variables define the entities of the dummy elaboration
11510 -- procedures used as origins of library level paths.
11512 Elab_Body_Id : Entity_Id := Empty;
11513 Elab_Spec_Id : Entity_Id := Empty;
11515 ---------------------
11516 -- Data structures --
11517 ---------------------
11519 -- The following set contains all declared invocation constructs. It
11520 -- ensures that the same construct is not declared multiple times in
11521 -- the ALI file of the main unit.
11523 Saved_Constructs_Set : NE_Set.Membership_Set := NE_Set.Nil;
11525 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type;
11526 -- Obtain the hash value of pair Key
11528 package IR_Set is new Membership_Sets
11529 (Element_Type => Invoker_Target_Relation,
11533 -- The following set contains all recorded simple invocation relations.
11534 -- It ensures that multiple relations involving the same invoker and
11535 -- target do not appear in the ALI file of the main unit.
11537 Saved_Relations_Set : IR_Set.Membership_Set := IR_Set.Nil;
11543 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id;
11544 pragma Inline (Signature_Of);
11545 -- Obtain the invication signature id of arbitrary entity Id
11547 -----------------------
11548 -- Local subprograms --
11549 -----------------------
11551 procedure Build_Elaborate_Body_Procedure;
11552 pragma Inline (Build_Elaborate_Body_Procedure);
11553 -- Create a dummy elaborate body procedure and store its entity in
11556 procedure Build_Elaborate_Procedure
11557 (Proc_Id : out Entity_Id;
11558 Proc_Nam : Name_Id;
11560 pragma Inline (Build_Elaborate_Procedure);
11561 -- Create a dummy elaborate procedure with name Proc_Nam and source
11562 -- location Loc. The entity is returned in Proc_Id.
11564 procedure Build_Elaborate_Spec_Procedure;
11565 pragma Inline (Build_Elaborate_Spec_Procedure);
11566 -- Create a dummy elaborate spec procedure and store its entity in
11569 function Build_Subprogram_Invocation
11570 (Subp_Id : Entity_Id) return Node_Id;
11571 pragma Inline (Build_Subprogram_Invocation);
11572 -- Create a dummy call marker that invokes subprogram Subp_Id
11574 function Build_Task_Activation
11575 (Task_Typ : Entity_Id;
11576 In_State : Processing_In_State) return Node_Id;
11577 pragma Inline (Build_Task_Activation);
11578 -- Create a dummy call marker that activates an anonymous task object of
11581 procedure Declare_Invocation_Construct
11582 (Constr_Id : Entity_Id;
11583 In_State : Processing_In_State);
11584 pragma Inline (Declare_Invocation_Construct);
11585 -- Declare invocation construct Constr_Id by creating a declaration for
11586 -- it in the ALI file of the main unit. In_State is the current state of
11587 -- the Processing phase.
11589 function Invocation_Graph_Recording_OK return Boolean;
11590 pragma Inline (Invocation_Graph_Recording_OK);
11591 -- Determine whether the invocation graph can be recorded
11593 function Is_Invocation_Scenario (N : Node_Id) return Boolean;
11594 pragma Inline (Is_Invocation_Scenario);
11595 -- Determine whether node N is a suitable scenario for invocation graph
11596 -- recording purposes.
11598 function Is_Invocation_Target (Id : Entity_Id) return Boolean;
11599 pragma Inline (Is_Invocation_Target);
11600 -- Determine whether arbitrary entity Id denotes an invocation target
11602 function Is_Saved_Construct (Constr : Entity_Id) return Boolean;
11603 pragma Inline (Is_Saved_Construct);
11604 -- Determine whether invocation construct Constr has already been
11605 -- declared in the ALI file of the main unit.
11607 function Is_Saved_Relation
11608 (Rel : Invoker_Target_Relation) return Boolean;
11609 pragma Inline (Is_Saved_Relation);
11610 -- Determine whether simple invocation relation Rel has already been
11611 -- recorded in the ALI file of the main unit.
11613 procedure Process_Declarations
11615 In_State : Processing_In_State);
11616 pragma Inline (Process_Declarations);
11617 -- Process declaration list Decls by processing all invocation scenarios
11620 procedure Process_Freeze_Node
11622 In_State : Processing_In_State);
11623 pragma Inline (Process_Freeze_Node);
11624 -- Process freeze node Fnode by processing all invocation scenarios in
11625 -- its Actions list.
11627 procedure Process_Invocation_Activation
11629 Call_Rep : Scenario_Rep_Id;
11630 Obj_Id : Entity_Id;
11631 Obj_Rep : Target_Rep_Id;
11632 Task_Typ : Entity_Id;
11633 Task_Rep : Target_Rep_Id;
11634 In_State : Processing_In_State);
11635 pragma Inline (Process_Invocation_Activation);
11636 -- Process activation call Call which activates object Obj_Id of task
11637 -- type Task_Typ by processing all invocation scenarios within the task
11638 -- body. Call_Rep is the representation of the call. Obj_Rep denotes the
11639 -- representation of the object. Task_Rep is the representation of the
11640 -- task type. In_State is the current state of the Processing phase.
11642 procedure Process_Invocation_Body_Scenarios;
11643 pragma Inline (Process_Invocation_Body_Scenarios);
11644 -- Process all library level body scenarios
11646 procedure Process_Invocation_Call
11648 Call_Rep : Scenario_Rep_Id;
11649 In_State : Processing_In_State);
11650 pragma Inline (Process_Invocation_Call);
11651 -- Process invocation call scenario Call with representation Call_Rep.
11652 -- In_State is the current state of the Processing phase.
11654 procedure Process_Invocation_Instantiation
11656 Inst_Rep : Scenario_Rep_Id;
11657 In_State : Processing_In_State);
11658 pragma Inline (Process_Invocation_Instantiation);
11659 -- Process invocation instantiation scenario Inst with representation
11660 -- Inst_Rep. In_State is the current state of the Processing phase.
11662 procedure Process_Invocation_Scenario
11664 In_State : Processing_In_State);
11665 pragma Inline (Process_Invocation_Scenario);
11666 -- Process single invocation scenario N. In_State is the current state
11667 -- of the Processing phase.
11669 procedure Process_Invocation_Scenarios
11670 (Iter : in out NE_Set.Iterator;
11671 In_State : Processing_In_State);
11672 pragma Inline (Process_Invocation_Scenarios);
11673 -- Process all invocation scenarios obtained via iterator Iter. In_State
11674 -- is the current state of the Processing phase.
11676 procedure Process_Invocation_Spec_Scenarios;
11677 pragma Inline (Process_Invocation_Spec_Scenarios);
11678 -- Process all library level spec scenarios
11680 procedure Process_Main_Unit;
11681 pragma Inline (Process_Main_Unit);
11682 -- Process all invocation scenarios within the main unit
11684 procedure Process_Package_Declaration
11685 (Pack_Decl : Node_Id;
11686 In_State : Processing_In_State);
11687 pragma Inline (Process_Package_Declaration);
11688 -- Process package declaration Pack_Decl by processing all invocation
11689 -- scenarios in its visible and private declarations. If the main unit
11690 -- contains a generic, the declarations of the body are also examined.
11691 -- In_State is the current state of the Processing phase.
11693 procedure Process_Protected_Type_Declaration
11694 (Prot_Decl : Node_Id;
11695 In_State : Processing_In_State);
11696 pragma Inline (Process_Protected_Type_Declaration);
11697 -- Process the declarations of protected type Prot_Decl. In_State is the
11698 -- current state of the Processing phase.
11700 procedure Process_Subprogram_Declaration
11701 (Subp_Decl : Node_Id;
11702 In_State : Processing_In_State);
11703 pragma Inline (Process_Subprogram_Declaration);
11704 -- Process subprogram declaration Subp_Decl by processing all invocation
11705 -- scenarios within its body. In_State denotes the current state of the
11706 -- Processing phase.
11708 procedure Process_Subprogram_Instantiation
11710 In_State : Processing_In_State);
11711 pragma Inline (Process_Subprogram_Instantiation);
11712 -- Process subprogram instantiation Inst. In_State is the current state
11713 -- of the Processing phase.
11715 procedure Process_Task_Type_Declaration
11716 (Task_Decl : Node_Id;
11717 In_State : Processing_In_State);
11718 pragma Inline (Process_Task_Type_Declaration);
11719 -- Process task declaration Task_Decl by processing all invocation
11720 -- scenarios within its body. In_State is the current state of the
11721 -- Processing phase.
11723 procedure Record_Full_Invocation_Path (In_State : Processing_In_State);
11724 pragma Inline (Record_Full_Invocation_Path);
11725 -- Record all relations between scenario pairs found in the stack of
11726 -- active scenarios. In_State is the current state of the Processing
11729 procedure Record_Invocation_Graph_Encoding;
11730 pragma Inline (Record_Invocation_Graph_Encoding);
11731 -- Record the encoding format used to capture information related to
11732 -- invocation constructs and relations.
11734 procedure Record_Invocation_Path (In_State : Processing_In_State);
11735 pragma Inline (Record_Invocation_Path);
11736 -- Record the invocation relations found within the path represented in
11737 -- the active scenario stack. In_State denotes the current state of the
11738 -- Processing phase.
11740 procedure Record_Simple_Invocation_Path (In_State : Processing_In_State);
11741 pragma Inline (Record_Simple_Invocation_Path);
11742 -- Record a single relation from the start to the end of the stack of
11743 -- active scenarios. In_State is the current state of the Processing
11746 procedure Record_Invocation_Relation
11747 (Invk_Id : Entity_Id;
11748 Targ_Id : Entity_Id;
11749 In_State : Processing_In_State);
11750 pragma Inline (Record_Invocation_Relation);
11751 -- Record an invocation relation with invoker Invk_Id and target Targ_Id
11752 -- by creating an entry for it in the ALI file of the main unit. Formal
11753 -- In_State denotes the current state of the Processing phase.
11755 procedure Set_Is_Saved_Construct
11756 (Constr : Entity_Id;
11757 Val : Boolean := True);
11758 pragma Inline (Set_Is_Saved_Construct);
11759 -- Mark invocation construct Constr as declared in the ALI file of the
11760 -- main unit depending on value Val.
11762 procedure Set_Is_Saved_Relation
11763 (Rel : Invoker_Target_Relation;
11764 Val : Boolean := True);
11765 pragma Inline (Set_Is_Saved_Relation);
11766 -- Mark simple invocation relation Rel as recorded in the ALI file of
11767 -- the main unit depending on value Val.
11770 (Pos : Active_Scenario_Pos;
11771 In_State : Processing_In_State) return Entity_Id;
11772 pragma Inline (Target_Of);
11773 -- Given position within the active scenario stack Pos, obtain the
11774 -- target of the indicated scenario. In_State is the current state
11775 -- of the Processing phase.
11777 procedure Traverse_Invocation_Body
11779 In_State : Processing_In_State);
11780 pragma Inline (Traverse_Invocation_Body);
11781 -- Traverse subprogram body N looking for suitable invocation scenarios
11782 -- that need to be processed for invocation graph recording purposes.
11783 -- In_State is the current state of the Processing phase.
11785 procedure Write_Invocation_Path (In_State : Processing_In_State);
11786 pragma Inline (Write_Invocation_Path);
11787 -- Write out a path represented by the active scenario on the stack to
11788 -- standard output. In_State denotes the current state of the Processing
11791 ------------------------------------
11792 -- Build_Elaborate_Body_Procedure --
11793 ------------------------------------
11795 procedure Build_Elaborate_Body_Procedure is
11796 Body_Decl : Node_Id;
11797 Spec_Decl : Node_Id;
11800 -- Nothing to do when a previous call already created the procedure
11802 if Present (Elab_Body_Id) then
11806 Spec_And_Body_From_Entity
11807 (Id => Main_Unit_Entity,
11808 Body_Decl => Body_Decl,
11809 Spec_Decl => Spec_Decl);
11811 pragma Assert (Present (Body_Decl));
11813 Build_Elaborate_Procedure
11814 (Proc_Id => Elab_Body_Id,
11815 Proc_Nam => Name_B,
11816 Loc => Sloc (Body_Decl));
11817 end Build_Elaborate_Body_Procedure;
11819 -------------------------------
11820 -- Build_Elaborate_Procedure --
11821 -------------------------------
11823 procedure Build_Elaborate_Procedure
11824 (Proc_Id : out Entity_Id;
11825 Proc_Nam : Name_Id;
11828 Proc_Decl : Node_Id;
11829 pragma Unreferenced (Proc_Decl);
11832 Proc_Id := Make_Defining_Identifier (Loc, Proc_Nam);
11834 -- Partially decorate the elaboration procedure because it will not
11835 -- be insertred into the tree and analyzed.
11837 Set_Ekind (Proc_Id, E_Procedure);
11838 Set_Etype (Proc_Id, Standard_Void_Type);
11839 Set_Scope (Proc_Id, Unique_Entity (Main_Unit_Entity));
11841 -- Create a dummy declaration for the elaboration procedure. The
11842 -- declaration does not need to be syntactically legal, but must
11843 -- carry an accurate source location.
11846 Make_Subprogram_Body (Loc,
11848 Make_Procedure_Specification (Loc,
11849 Defining_Unit_Name => Proc_Id),
11850 Declarations => No_List,
11851 Handled_Statement_Sequence => Empty);
11852 end Build_Elaborate_Procedure;
11854 ------------------------------------
11855 -- Build_Elaborate_Spec_Procedure --
11856 ------------------------------------
11858 procedure Build_Elaborate_Spec_Procedure is
11859 Body_Decl : Node_Id;
11860 Spec_Decl : Node_Id;
11863 -- Nothing to do when a previous call already created the procedure
11865 if Present (Elab_Spec_Id) then
11869 Spec_And_Body_From_Entity
11870 (Id => Main_Unit_Entity,
11871 Body_Decl => Body_Decl,
11872 Spec_Decl => Spec_Decl);
11874 pragma Assert (Present (Spec_Decl));
11876 Build_Elaborate_Procedure
11877 (Proc_Id => Elab_Spec_Id,
11878 Proc_Nam => Name_S,
11879 Loc => Sloc (Spec_Decl));
11880 end Build_Elaborate_Spec_Procedure;
11882 ---------------------------------
11883 -- Build_Subprogram_Invocation --
11884 ---------------------------------
11886 function Build_Subprogram_Invocation
11887 (Subp_Id : Entity_Id) return Node_Id
11889 Marker : constant Node_Id := Make_Call_Marker (Sloc (Subp_Id));
11890 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
11893 -- Create a dummy call marker which invokes the subprogram
11895 Set_Is_Declaration_Level_Node (Marker, False);
11896 Set_Is_Dispatching_Call (Marker, False);
11897 Set_Is_Elaboration_Checks_OK_Node (Marker, False);
11898 Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
11899 Set_Is_Ignored_Ghost_Node (Marker, False);
11900 Set_Is_Source_Call (Marker, False);
11901 Set_Is_SPARK_Mode_On_Node (Marker, False);
11903 -- Invoke the uniform canonical entity of the subprogram
11905 Set_Target (Marker, Canonical_Subprogram (Subp_Id));
11907 -- Partially insert the marker into the tree
11909 Set_Parent (Marker, Parent (Subp_Decl));
11912 end Build_Subprogram_Invocation;
11914 ---------------------------
11915 -- Build_Task_Activation --
11916 ---------------------------
11918 function Build_Task_Activation
11919 (Task_Typ : Entity_Id;
11920 In_State : Processing_In_State) return Node_Id
11922 Loc : constant Source_Ptr := Sloc (Task_Typ);
11923 Marker : constant Node_Id := Make_Call_Marker (Loc);
11924 Task_Decl : constant Node_Id := Unit_Declaration_Node (Task_Typ);
11926 Activ_Id : Entity_Id;
11927 Marker_Rep_Id : Scenario_Rep_Id;
11928 Task_Obj : Entity_Id;
11929 Task_Objs : NE_List.Doubly_Linked_List;
11932 -- Create a dummy call marker which activates some tasks
11934 Set_Is_Declaration_Level_Node (Marker, False);
11935 Set_Is_Dispatching_Call (Marker, False);
11936 Set_Is_Elaboration_Checks_OK_Node (Marker, False);
11937 Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
11938 Set_Is_Ignored_Ghost_Node (Marker, False);
11939 Set_Is_Source_Call (Marker, False);
11940 Set_Is_SPARK_Mode_On_Node (Marker, False);
11942 -- Invoke the appropriate version of Activate_Tasks
11944 if Restricted_Profile then
11945 Activ_Id := RTE (RE_Activate_Restricted_Tasks);
11947 Activ_Id := RTE (RE_Activate_Tasks);
11950 Set_Target (Marker, Activ_Id);
11952 -- Partially insert the marker into the tree
11954 Set_Parent (Marker, Parent (Task_Decl));
11956 -- Create a dummy task object. Partially decorate the object because
11957 -- it will not be inserted into the tree and analyzed.
11959 Task_Obj := Make_Temporary (Loc, 'T');
11960 Set_Ekind (Task_Obj, E_Variable);
11961 Set_Etype (Task_Obj, Task_Typ);
11963 -- Associate the dummy task object with the activation call
11965 Task_Objs := NE_List.Create;
11966 NE_List.Append (Task_Objs, Task_Obj);
11968 Marker_Rep_Id := Scenario_Representation_Of (Marker, In_State);
11969 Set_Activated_Task_Objects (Marker_Rep_Id, Task_Objs);
11970 Set_Activated_Task_Type (Marker_Rep_Id, Task_Typ);
11973 end Build_Task_Activation;
11975 ----------------------------------
11976 -- Declare_Invocation_Construct --
11977 ----------------------------------
11979 procedure Declare_Invocation_Construct
11980 (Constr_Id : Entity_Id;
11981 In_State : Processing_In_State)
11983 function Body_Placement_Of
11984 (Id : Entity_Id) return Declaration_Placement_Kind;
11985 pragma Inline (Body_Placement_Of);
11986 -- Obtain the placement of arbitrary entity Id's body
11988 function Declaration_Placement_Of_Node
11989 (N : Node_Id) return Declaration_Placement_Kind;
11990 pragma Inline (Declaration_Placement_Of_Node);
11991 -- Obtain the placement of arbitrary node N
11993 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind;
11994 pragma Inline (Kind_Of);
11995 -- Obtain the invocation construct kind of arbitrary entity Id
11997 function Spec_Placement_Of
11998 (Id : Entity_Id) return Declaration_Placement_Kind;
11999 pragma Inline (Spec_Placement_Of);
12000 -- Obtain the placement of arbitrary entity Id's spec
12002 -----------------------
12003 -- Body_Placement_Of --
12004 -----------------------
12006 function Body_Placement_Of
12007 (Id : Entity_Id) return Declaration_Placement_Kind
12009 Id_Rep : constant Target_Rep_Id :=
12010 Target_Representation_Of (Id, In_State);
12011 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep);
12012 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep);
12015 -- The entity has a body
12017 if Present (Body_Decl) then
12018 return Declaration_Placement_Of_Node (Body_Decl);
12020 -- Otherwise the entity must have a spec
12023 pragma Assert (Present (Spec_Decl));
12024 return Declaration_Placement_Of_Node (Spec_Decl);
12026 end Body_Placement_Of;
12028 -----------------------------------
12029 -- Declaration_Placement_Of_Node --
12030 -----------------------------------
12032 function Declaration_Placement_Of_Node
12033 (N : Node_Id) return Declaration_Placement_Kind
12035 Main_Unit_Id : constant Entity_Id := Main_Unit_Entity;
12036 N_Unit_Id : constant Entity_Id := Find_Top_Unit (N);
12039 -- The node is in the main unit, its placement depends on the main
12042 if N_Unit_Id = Main_Unit_Id then
12044 -- The main unit is a body
12046 if Ekind_In (Main_Unit_Id, E_Package_Body,
12051 -- The main unit is a stand-alone subprogram body
12053 elsif Ekind_In (Main_Unit_Id, E_Function, E_Procedure)
12054 and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) =
12059 -- Otherwise the main unit is a spec
12065 -- Otherwise the node is in the complementary unit of the main
12066 -- unit. The main unit is a body, the node is in the spec.
12068 elsif Ekind_In (Main_Unit_Id, E_Package_Body,
12073 -- The main unit is a spec, the node is in the body
12078 end Declaration_Placement_Of_Node;
12084 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is
12086 if Id = Elab_Body_Id then
12087 return Elaborate_Body_Procedure;
12089 elsif Id = Elab_Spec_Id then
12090 return Elaborate_Spec_Procedure;
12093 return Regular_Construct;
12097 -----------------------
12098 -- Spec_Placement_Of --
12099 -----------------------
12101 function Spec_Placement_Of
12102 (Id : Entity_Id) return Declaration_Placement_Kind
12104 Id_Rep : constant Target_Rep_Id :=
12105 Target_Representation_Of (Id, In_State);
12106 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep);
12107 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep);
12110 -- The entity has a spec
12112 if Present (Spec_Decl) then
12113 return Declaration_Placement_Of_Node (Spec_Decl);
12115 -- Otherwise the entity must have a body
12118 pragma Assert (Present (Body_Decl));
12119 return Declaration_Placement_Of_Node (Body_Decl);
12121 end Spec_Placement_Of;
12123 -- Start of processing for Declare_Invocation_Construct
12126 -- Nothing to do when the construct has already been declared in the
12129 if Is_Saved_Construct (Constr_Id) then
12133 -- Mark the construct as declared in the ALI file
12135 Set_Is_Saved_Construct (Constr_Id);
12137 -- Add the construct in the ALI file
12139 Add_Invocation_Construct
12140 (Body_Placement => Body_Placement_Of (Constr_Id),
12141 Kind => Kind_Of (Constr_Id),
12142 Signature => Signature_Of (Constr_Id),
12143 Spec_Placement => Spec_Placement_Of (Constr_Id),
12144 Update_Units => False);
12145 end Declare_Invocation_Construct;
12147 -------------------------------
12148 -- Finalize_Invocation_Graph --
12149 -------------------------------
12151 procedure Finalize_Invocation_Graph is
12153 NE_Set.Destroy (Saved_Constructs_Set);
12154 IR_Set.Destroy (Saved_Relations_Set);
12155 end Finalize_Invocation_Graph;
12161 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type is
12162 pragma Assert (Present (Key.Invoker));
12163 pragma Assert (Present (Key.Target));
12168 (Bucket_Range_Type (Key.Invoker),
12169 Bucket_Range_Type (Key.Target));
12172 ---------------------------------
12173 -- Initialize_Invocation_Graph --
12174 ---------------------------------
12176 procedure Initialize_Invocation_Graph is
12178 Saved_Constructs_Set := NE_Set.Create (100);
12179 Saved_Relations_Set := IR_Set.Create (200);
12180 end Initialize_Invocation_Graph;
12182 -----------------------------------
12183 -- Invocation_Graph_Recording_OK --
12184 -----------------------------------
12186 function Invocation_Graph_Recording_OK return Boolean is
12187 Main_Cunit : constant Node_Id := Cunit (Main_Unit);
12190 -- Nothing to do when compiling for GNATprove because the invocation
12191 -- graph is not needed.
12193 if GNATprove_Mode then
12196 -- Nothing to do when the compilation will not produce an ALI file
12198 elsif Serious_Errors_Detected > 0 then
12201 -- Nothing to do when the main unit requires a body. Processing the
12202 -- completing body will create the ALI file for the unit and record
12203 -- the invocation graph.
12205 elsif Body_Required (Main_Cunit) then
12210 end Invocation_Graph_Recording_OK;
12212 ----------------------------
12213 -- Is_Invocation_Scenario --
12214 ----------------------------
12216 function Is_Invocation_Scenario (N : Node_Id) return Boolean is
12219 Is_Suitable_Access_Taken (N)
12220 or else Is_Suitable_Call (N)
12221 or else Is_Suitable_Instantiation (N);
12222 end Is_Invocation_Scenario;
12224 --------------------------
12225 -- Is_Invocation_Target --
12226 --------------------------
12228 function Is_Invocation_Target (Id : Entity_Id) return Boolean is
12230 -- To qualify, the entity must either come from source, or denote an
12231 -- Ada, bridge, or SPARK target.
12234 Comes_From_Source (Id)
12235 or else Is_Ada_Semantic_Target (Id)
12236 or else Is_Bridge_Target (Id)
12237 or else Is_SPARK_Semantic_Target (Id);
12238 end Is_Invocation_Target;
12240 ------------------------
12241 -- Is_Saved_Construct --
12242 ------------------------
12244 function Is_Saved_Construct (Constr : Entity_Id) return Boolean is
12245 pragma Assert (Present (Constr));
12247 return NE_Set.Contains (Saved_Constructs_Set, Constr);
12248 end Is_Saved_Construct;
12250 -----------------------
12251 -- Is_Saved_Relation --
12252 -----------------------
12254 function Is_Saved_Relation
12255 (Rel : Invoker_Target_Relation) return Boolean
12257 pragma Assert (Present (Rel.Invoker));
12258 pragma Assert (Present (Rel.Target));
12261 return IR_Set.Contains (Saved_Relations_Set, Rel);
12262 end Is_Saved_Relation;
12264 --------------------------
12265 -- Process_Declarations --
12266 --------------------------
12268 procedure Process_Declarations
12270 In_State : Processing_In_State)
12275 Decl := First (Decls);
12276 while Present (Decl) loop
12280 if Nkind (Decl) = N_Freeze_Entity then
12281 Process_Freeze_Node
12283 In_State => In_State);
12285 -- Package (nested)
12287 elsif Nkind (Decl) = N_Package_Declaration then
12288 Process_Package_Declaration
12289 (Pack_Decl => Decl,
12290 In_State => In_State);
12294 elsif Nkind_In (Decl, N_Protected_Type_Declaration,
12295 N_Single_Protected_Declaration)
12297 Process_Protected_Type_Declaration
12298 (Prot_Decl => Decl,
12299 In_State => In_State);
12301 -- Subprogram or entry
12303 elsif Nkind_In (Decl, N_Entry_Declaration,
12304 N_Subprogram_Declaration)
12306 Process_Subprogram_Declaration
12307 (Subp_Decl => Decl,
12308 In_State => In_State);
12310 -- Subprogram body (stand alone)
12312 elsif Nkind (Decl) = N_Subprogram_Body
12313 and then No (Corresponding_Spec (Decl))
12315 Process_Subprogram_Declaration
12316 (Subp_Decl => Decl,
12317 In_State => In_State);
12319 -- Subprogram instantiation
12321 elsif Nkind (Decl) in N_Subprogram_Instantiation then
12322 Process_Subprogram_Instantiation
12324 In_State => In_State);
12328 elsif Nkind_In (Decl, N_Single_Task_Declaration,
12329 N_Task_Type_Declaration)
12331 Process_Task_Type_Declaration
12332 (Task_Decl => Decl,
12333 In_State => In_State);
12335 -- Task type (derived)
12337 elsif Nkind (Decl) = N_Full_Type_Declaration
12338 and then Is_Task_Type (Defining_Entity (Decl))
12340 Process_Task_Type_Declaration
12341 (Task_Decl => Decl,
12342 In_State => In_State);
12347 end Process_Declarations;
12349 -------------------------
12350 -- Process_Freeze_Node --
12351 -------------------------
12353 procedure Process_Freeze_Node
12355 In_State : Processing_In_State)
12358 Process_Declarations
12359 (Decls => Actions (Fnode),
12360 In_State => In_State);
12361 end Process_Freeze_Node;
12363 -----------------------------------
12364 -- Process_Invocation_Activation --
12365 -----------------------------------
12367 procedure Process_Invocation_Activation
12369 Call_Rep : Scenario_Rep_Id;
12370 Obj_Id : Entity_Id;
12371 Obj_Rep : Target_Rep_Id;
12372 Task_Typ : Entity_Id;
12373 Task_Rep : Target_Rep_Id;
12374 In_State : Processing_In_State)
12376 pragma Unreferenced (Call);
12377 pragma Unreferenced (Call_Rep);
12378 pragma Unreferenced (Obj_Id);
12379 pragma Unreferenced (Obj_Rep);
12382 -- Nothing to do when the task type appears within an internal unit
12384 if In_Internal_Unit (Task_Typ) then
12388 -- The task type being activated is within the main unit. Extend the
12389 -- DFS traversal into its body.
12391 if In_Extended_Main_Code_Unit (Task_Typ) then
12392 Traverse_Invocation_Body
12393 (N => Body_Declaration (Task_Rep),
12394 In_State => In_State);
12396 -- The task type being activated resides within an external unit
12398 -- Main unit External unit
12399 -- +-----------+ +-------------+
12401 -- | Start ------------> Task_Typ |
12403 -- +-----------+ +-------------+
12405 -- Record the invocation path which originates from Start and reaches
12409 Record_Invocation_Path (In_State);
12411 end Process_Invocation_Activation;
12413 ---------------------------------------
12414 -- Process_Invocation_Body_Scenarios --
12415 ---------------------------------------
12417 procedure Process_Invocation_Body_Scenarios is
12418 Iter : NE_Set.Iterator := Iterate_Library_Body_Scenarios;
12420 Process_Invocation_Scenarios
12422 In_State => Invocation_Body_State);
12423 end Process_Invocation_Body_Scenarios;
12425 -----------------------------
12426 -- Process_Invocation_Call --
12427 -----------------------------
12429 procedure Process_Invocation_Call
12431 Call_Rep : Scenario_Rep_Id;
12432 In_State : Processing_In_State)
12434 pragma Unreferenced (Call);
12436 Subp_Id : constant Entity_Id := Target (Call_Rep);
12437 Subp_Rep : constant Target_Rep_Id :=
12438 Target_Representation_Of (Subp_Id, In_State);
12441 -- Nothing to do when the subprogram appears within an internal unit
12443 if In_Internal_Unit (Subp_Id) then
12446 -- Nothing to do for an abstract subprogram because it has no body to
12449 elsif Ekind_In (Subp_Id, E_Function, E_Procedure)
12450 and then Is_Abstract_Subprogram (Subp_Id)
12454 -- Nothin to do for a formal subprogram because it has no body to
12457 elsif Is_Formal_Subprogram (Subp_Id) then
12461 -- The subprogram being called is within the main unit. Extend the
12462 -- DFS traversal into its barrier function and body.
12464 if In_Extended_Main_Code_Unit (Subp_Id) then
12465 if Ekind_In (Subp_Id, E_Entry, E_Entry_Family, E_Procedure) then
12466 Traverse_Invocation_Body
12467 (N => Barrier_Body_Declaration (Subp_Rep),
12468 In_State => In_State);
12471 Traverse_Invocation_Body
12472 (N => Body_Declaration (Subp_Rep),
12473 In_State => In_State);
12475 -- The subprogram being called resides within an external unit
12477 -- Main unit External unit
12478 -- +-----------+ +-------------+
12480 -- | Start ------------> Subp_Id |
12482 -- +-----------+ +-------------+
12484 -- Record the invocation path which originates from Start and reaches
12488 Record_Invocation_Path (In_State);
12490 end Process_Invocation_Call;
12492 --------------------------------------
12493 -- Process_Invocation_Instantiation --
12494 --------------------------------------
12496 procedure Process_Invocation_Instantiation
12498 Inst_Rep : Scenario_Rep_Id;
12499 In_State : Processing_In_State)
12501 pragma Unreferenced (Inst);
12503 Gen_Id : constant Entity_Id := Target (Inst_Rep);
12506 -- Nothing to do when the generic appears within an internal unit
12508 if In_Internal_Unit (Gen_Id) then
12512 -- The generic being instantiated resides within an external unit
12514 -- Main unit External unit
12515 -- +-----------+ +-------------+
12517 -- | Start ------------> Generic |
12519 -- +-----------+ +-------------+
12521 -- Record the invocation path which originates from Start and reaches
12524 if not In_Extended_Main_Code_Unit (Gen_Id) then
12525 Record_Invocation_Path (In_State);
12527 end Process_Invocation_Instantiation;
12529 ---------------------------------
12530 -- Process_Invocation_Scenario --
12531 ---------------------------------
12533 procedure Process_Invocation_Scenario
12535 In_State : Processing_In_State)
12537 Scen : constant Node_Id := Scenario (N);
12538 Scen_Rep : Scenario_Rep_Id;
12541 -- Add the current scenario to the stack of active scenarios
12543 Push_Active_Scenario (Scen);
12545 -- Call or task activation
12547 if Is_Suitable_Call (Scen) then
12548 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
12550 -- Routine Build_Call_Marker creates call markers regardless of
12551 -- whether the call occurs within the main unit or not. This way
12552 -- the serialization of internal names is kept consistent. Only
12553 -- call markers found within the main unit must be processed.
12555 if In_Main_Context (Scen) then
12556 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
12558 if Kind (Scen_Rep) = Call_Scenario then
12559 Process_Invocation_Call
12561 Call_Rep => Scen_Rep,
12562 In_State => In_State);
12565 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario);
12569 Call_Rep => Scen_Rep,
12570 Processor => Process_Invocation_Activation'Access,
12571 In_State => In_State);
12577 elsif Is_Suitable_Instantiation (Scen) then
12578 Process_Invocation_Instantiation
12580 Inst_Rep => Scenario_Representation_Of (Scen, In_State),
12581 In_State => In_State);
12584 -- Remove the current scenario from the stack of active scenarios
12585 -- once all invocation constructs and paths have been saved.
12587 Pop_Active_Scenario (Scen);
12588 end Process_Invocation_Scenario;
12590 ----------------------------------
12591 -- Process_Invocation_Scenarios --
12592 ----------------------------------
12594 procedure Process_Invocation_Scenarios
12595 (Iter : in out NE_Set.Iterator;
12596 In_State : Processing_In_State)
12601 while NE_Set.Has_Next (Iter) loop
12602 NE_Set.Next (Iter, N);
12604 -- Reset the traversed status of all subprogram bodies because the
12605 -- current invocation scenario acts as a new DFS traversal root.
12607 Reset_Traversed_Bodies;
12609 Process_Invocation_Scenario (N, In_State);
12611 end Process_Invocation_Scenarios;
12613 ---------------------------------------
12614 -- Process_Invocation_Spec_Scenarios --
12615 ---------------------------------------
12617 procedure Process_Invocation_Spec_Scenarios is
12618 Iter : NE_Set.Iterator := Iterate_Library_Spec_Scenarios;
12620 Process_Invocation_Scenarios
12622 In_State => Invocation_Spec_State);
12623 end Process_Invocation_Spec_Scenarios;
12625 -----------------------
12626 -- Process_Main_Unit --
12627 -----------------------
12629 procedure Process_Main_Unit is
12630 Unit_Decl : constant Node_Id := Unit (Cunit (Main_Unit));
12631 Spec_Id : Entity_Id;
12634 -- The main unit is a [generic] package body
12636 if Nkind (Unit_Decl) = N_Package_Body then
12637 Spec_Id := Corresponding_Spec (Unit_Decl);
12638 pragma Assert (Present (Spec_Id));
12640 Process_Package_Declaration
12641 (Pack_Decl => Unit_Declaration_Node (Spec_Id),
12642 In_State => Invocation_Construct_State);
12644 -- The main unit is a [generic] package declaration
12646 elsif Nkind (Unit_Decl) = N_Package_Declaration then
12647 Process_Package_Declaration
12648 (Pack_Decl => Unit_Decl,
12649 In_State => Invocation_Construct_State);
12651 -- The main unit is a [generic] subprogram body
12653 elsif Nkind (Unit_Decl) = N_Subprogram_Body then
12654 Spec_Id := Corresponding_Spec (Unit_Decl);
12656 -- The body completes a previous declaration
12658 if Present (Spec_Id) then
12659 Process_Subprogram_Declaration
12660 (Subp_Decl => Unit_Declaration_Node (Spec_Id),
12661 In_State => Invocation_Construct_State);
12663 -- Otherwise the body is stand-alone
12666 Process_Subprogram_Declaration
12667 (Subp_Decl => Unit_Decl,
12668 In_State => Invocation_Construct_State);
12671 -- The main unit is a subprogram instantiation
12673 elsif Nkind (Unit_Decl) in N_Subprogram_Instantiation then
12674 Process_Subprogram_Instantiation
12675 (Inst => Unit_Decl,
12676 In_State => Invocation_Construct_State);
12678 -- The main unit is an imported subprogram declaration
12680 elsif Nkind (Unit_Decl) = N_Subprogram_Declaration then
12681 Process_Subprogram_Declaration
12682 (Subp_Decl => Unit_Decl,
12683 In_State => Invocation_Construct_State);
12685 end Process_Main_Unit;
12687 ---------------------------------
12688 -- Process_Package_Declaration --
12689 ---------------------------------
12691 procedure Process_Package_Declaration
12692 (Pack_Decl : Node_Id;
12693 In_State : Processing_In_State)
12695 Body_Id : constant Entity_Id := Corresponding_Body (Pack_Decl);
12696 Spec : constant Node_Id := Specification (Pack_Decl);
12697 Spec_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
12700 -- Add a declaration for the generic package in the ALI of the main
12701 -- unit in case a client unit instantiates it.
12703 if Ekind (Spec_Id) = E_Generic_Package then
12704 Declare_Invocation_Construct
12705 (Constr_Id => Spec_Id,
12706 In_State => In_State);
12708 -- Otherwise inspect the visible and private declarations of the
12709 -- package for invocation constructs.
12712 Process_Declarations
12713 (Decls => Visible_Declarations (Spec),
12714 In_State => In_State);
12716 Process_Declarations
12717 (Decls => Private_Declarations (Spec),
12718 In_State => In_State);
12720 -- The package body containst at least one generic unit or an
12721 -- inlinable subprogram. Such constructs may grant clients of
12722 -- the main unit access to the private enclosing contexts of
12723 -- the constructs. Process the main unit body to discover and
12724 -- encode relevant invocation constructs and relations that
12725 -- may ultimately reach an external unit.
12727 if Present (Body_Id)
12728 and then Save_Invocation_Graph_Of_Body (Cunit (Main_Unit))
12730 Process_Declarations
12731 (Decls => Declarations (Unit_Declaration_Node (Body_Id)),
12732 In_State => In_State);
12735 end Process_Package_Declaration;
12737 ----------------------------------------
12738 -- Process_Protected_Type_Declaration --
12739 ----------------------------------------
12741 procedure Process_Protected_Type_Declaration
12742 (Prot_Decl : Node_Id;
12743 In_State : Processing_In_State)
12745 Prot_Def : constant Node_Id := Protected_Definition (Prot_Decl);
12748 if Present (Prot_Def) then
12749 Process_Declarations
12750 (Decls => Visible_Declarations (Prot_Def),
12751 In_State => In_State);
12753 end Process_Protected_Type_Declaration;
12755 ------------------------------------
12756 -- Process_Subprogram_Declaration --
12757 ------------------------------------
12759 procedure Process_Subprogram_Declaration
12760 (Subp_Decl : Node_Id;
12761 In_State : Processing_In_State)
12763 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
12766 -- Nothing to do when the subprogram is not an invocation target
12768 if not Is_Invocation_Target (Subp_Id) then
12772 -- Add a declaration for the subprogram in the ALI file of the main
12773 -- unit in case a client unit calls or instantiates it.
12775 Declare_Invocation_Construct
12776 (Constr_Id => Subp_Id,
12777 In_State => In_State);
12779 -- Do not process subprograms without a body because they do not
12780 -- contain any invocation scenarios.
12782 if Is_Bodiless_Subprogram (Subp_Id) then
12785 -- Do not process generic subprograms because generics must not be
12788 elsif Is_Generic_Subprogram (Subp_Id) then
12791 -- Otherwise create a dummy scenario which calls the subprogram to
12792 -- act as a root for a DFS traversal.
12795 -- Reset the traversed status of all subprogram bodies because the
12796 -- subprogram acts as a new DFS traversal root.
12798 Reset_Traversed_Bodies;
12800 Process_Invocation_Scenario
12801 (N => Build_Subprogram_Invocation (Subp_Id),
12802 In_State => In_State);
12804 end Process_Subprogram_Declaration;
12806 --------------------------------------
12807 -- Process_Subprogram_Instantiation --
12808 --------------------------------------
12810 procedure Process_Subprogram_Instantiation
12812 In_State : Processing_In_State)
12815 -- Add a declaration for the instantiation in the ALI file of the
12816 -- main unit in case a client unit calls it.
12818 Declare_Invocation_Construct
12819 (Constr_Id => Defining_Entity (Inst),
12820 In_State => In_State);
12821 end Process_Subprogram_Instantiation;
12823 -----------------------------------
12824 -- Process_Task_Type_Declaration --
12825 -----------------------------------
12827 procedure Process_Task_Type_Declaration
12828 (Task_Decl : Node_Id;
12829 In_State : Processing_In_State)
12831 Task_Typ : constant Entity_Id := Defining_Entity (Task_Decl);
12832 Task_Def : Node_Id;
12835 -- Add a declaration for the task type the ALI file of the main unit
12836 -- in case a client unit creates a task object and activates it.
12838 Declare_Invocation_Construct
12839 (Constr_Id => Task_Typ,
12840 In_State => In_State);
12842 -- Process the entries of the task type because they represent valid
12843 -- entry points into the task body.
12845 if Nkind_In (Task_Decl, N_Single_Task_Declaration,
12846 N_Task_Type_Declaration)
12848 Task_Def := Task_Definition (Task_Decl);
12850 if Present (Task_Def) then
12851 Process_Declarations
12852 (Decls => Visible_Declarations (Task_Def),
12853 In_State => In_State);
12857 -- Reset the traversed status of all subprogram bodies because the
12858 -- task type acts as a new DFS traversal root.
12860 Reset_Traversed_Bodies;
12862 -- Create a dummy scenario which activates an anonymous object of the
12863 -- task type to acts as a root of a DFS traversal.
12865 Process_Invocation_Scenario
12866 (N => Build_Task_Activation (Task_Typ, In_State),
12867 In_State => In_State);
12868 end Process_Task_Type_Declaration;
12870 ---------------------------------
12871 -- Record_Full_Invocation_Path --
12872 ---------------------------------
12874 procedure Record_Full_Invocation_Path (In_State : Processing_In_State) is
12875 package Scenarios renames Active_Scenario_Stack;
12878 -- The path originates from the elaboration of the body. Add an extra
12879 -- relation from the elaboration body procedure to the first active
12882 if In_State.Processing = Invocation_Body_Processing then
12883 Build_Elaborate_Body_Procedure;
12885 Record_Invocation_Relation
12886 (Invk_Id => Elab_Body_Id,
12887 Targ_Id => Target_Of (Scenarios.First, In_State),
12888 In_State => In_State);
12890 -- The path originates from the elaboration of the spec. Add an extra
12891 -- relation from the elaboration spec procedure to the first active
12894 elsif In_State.Processing = Invocation_Spec_Processing then
12895 Build_Elaborate_Spec_Procedure;
12897 Record_Invocation_Relation
12898 (Invk_Id => Elab_Spec_Id,
12899 Targ_Id => Target_Of (Scenarios.First, In_State),
12900 In_State => In_State);
12903 -- Record individual relations formed by pairs of scenarios
12905 for Index in Scenarios.First .. Scenarios.Last - 1 loop
12906 Record_Invocation_Relation
12907 (Invk_Id => Target_Of (Index, In_State),
12908 Targ_Id => Target_Of (Index + 1, In_State),
12909 In_State => In_State);
12911 end Record_Full_Invocation_Path;
12913 -----------------------------
12914 -- Record_Invocation_Graph --
12915 -----------------------------
12917 procedure Record_Invocation_Graph is
12919 -- Nothing to do when the invocation graph is not recorded
12921 if not Invocation_Graph_Recording_OK then
12925 -- Save the encoding format used to capture information about the
12926 -- invocation constructs and relations in the ALI file of the main
12929 Record_Invocation_Graph_Encoding;
12931 -- Examine all library level invocation scenarios and perform DFS
12932 -- traversals from each one. Encode a path in the ALI file of the
12933 -- main unit if it reaches into an external unit.
12935 Process_Invocation_Body_Scenarios;
12936 Process_Invocation_Spec_Scenarios;
12938 -- Examine all invocation constructs within the spec and body of the
12939 -- main unit and perform DFS traversals from each one. Encode a path
12940 -- in the ALI file of the main unit if it reaches into an external
12944 end Record_Invocation_Graph;
12946 --------------------------------------
12947 -- Record_Invocation_Graph_Encoding --
12948 --------------------------------------
12950 procedure Record_Invocation_Graph_Encoding is
12951 Kind : Invocation_Graph_Encoding_Kind := No_Encoding;
12954 -- Switch -gnatd_F (encode full invocation paths in ALI files) is in
12957 if Debug_Flag_Underscore_FF then
12958 Kind := Full_Path_Encoding;
12960 Kind := Endpoints_Encoding;
12963 -- Save the encoding format in the ALI file of the main unit
12965 Set_Invocation_Graph_Encoding
12967 Update_Units => False);
12968 end Record_Invocation_Graph_Encoding;
12970 ----------------------------
12971 -- Record_Invocation_Path --
12972 ----------------------------
12974 procedure Record_Invocation_Path (In_State : Processing_In_State) is
12975 package Scenarios renames Active_Scenario_Stack;
12978 -- Save a path when the active scenario stack contains at least one
12979 -- invocation scenario.
12981 if Scenarios.Last - Scenarios.First < 0 then
12985 -- Register all relations in the path when switch -gnatd_F (encode
12986 -- full invocation paths in ALI files) is in effect.
12988 if Debug_Flag_Underscore_FF then
12989 Record_Full_Invocation_Path (In_State);
12991 -- Otherwise register a single relation
12994 Record_Simple_Invocation_Path (In_State);
12997 Write_Invocation_Path (In_State);
12998 end Record_Invocation_Path;
13000 --------------------------------
13001 -- Record_Invocation_Relation --
13002 --------------------------------
13004 procedure Record_Invocation_Relation
13005 (Invk_Id : Entity_Id;
13006 Targ_Id : Entity_Id;
13007 In_State : Processing_In_State)
13009 pragma Assert (Present (Invk_Id));
13010 pragma Assert (Present (Targ_Id));
13012 procedure Get_Invocation_Attributes
13013 (Extra : out Entity_Id;
13014 Kind : out Invocation_Kind);
13015 pragma Inline (Get_Invocation_Attributes);
13016 -- Return the additional entity used in error diagnostics in Extra
13017 -- and the invocation kind in Kind which pertain to the invocation
13018 -- relation with invoker Invk_Id and target Targ_Id.
13020 -------------------------------
13021 -- Get_Invocation_Attributes --
13022 -------------------------------
13024 procedure Get_Invocation_Attributes
13025 (Extra : out Entity_Id;
13026 Kind : out Invocation_Kind)
13028 Targ_Rep : constant Target_Rep_Id :=
13029 Target_Representation_Of (Targ_Id, In_State);
13030 Spec_Decl : constant Node_Id := Spec_Declaration (Targ_Rep);
13033 -- Accept within a task body
13035 if Is_Accept_Alternative_Proc (Targ_Id) then
13036 Extra := Receiving_Entry (Targ_Id);
13037 Kind := Accept_Alternative;
13039 -- Activation of a task object
13041 elsif Is_Activation_Proc (Targ_Id)
13042 or else Is_Task_Type (Targ_Id)
13045 Kind := Task_Activation;
13047 -- Controlled adjustment actions
13049 elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then
13050 Extra := First_Formal_Type (Targ_Id);
13051 Kind := Controlled_Adjustment;
13053 -- Controlled finalization actions
13055 elsif Is_Controlled_Proc (Targ_Id, Name_Finalize)
13056 or else Is_Finalizer_Proc (Targ_Id)
13058 Extra := First_Formal_Type (Targ_Id);
13059 Kind := Controlled_Finalization;
13061 -- Controlled initialization actions
13063 elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then
13064 Extra := First_Formal_Type (Targ_Id);
13065 Kind := Controlled_Initialization;
13067 -- Default_Initial_Condition verification
13069 elsif Is_Default_Initial_Condition_Proc (Targ_Id) then
13070 Extra := First_Formal_Type (Targ_Id);
13071 Kind := Default_Initial_Condition_Verification;
13073 -- Initialization of object
13075 elsif Is_Init_Proc (Targ_Id) then
13076 Extra := First_Formal_Type (Targ_Id);
13077 Kind := Type_Initialization;
13079 -- Initial_Condition verification
13081 elsif Is_Initial_Condition_Proc (Targ_Id) then
13082 Extra := First_Formal_Type (Targ_Id);
13083 Kind := Initial_Condition_Verification;
13087 elsif Is_Generic_Unit (Targ_Id) then
13089 Kind := Instantiation;
13091 -- Internal controlled adjustment actions
13093 elsif Is_TSS (Targ_Id, TSS_Deep_Adjust) then
13094 Extra := First_Formal_Type (Targ_Id);
13095 Kind := Internal_Controlled_Adjustment;
13097 -- Internal controlled finalization actions
13099 elsif Is_TSS (Targ_Id, TSS_Deep_Finalize) then
13100 Extra := First_Formal_Type (Targ_Id);
13101 Kind := Internal_Controlled_Finalization;
13103 -- Internal controlled initialization actions
13105 elsif Is_TSS (Targ_Id, TSS_Deep_Initialize) then
13106 Extra := First_Formal_Type (Targ_Id);
13107 Kind := Internal_Controlled_Initialization;
13109 -- Invariant verification
13111 elsif Is_Invariant_Proc (Targ_Id)
13112 or else Is_Partial_Invariant_Proc (Targ_Id)
13114 Extra := First_Formal_Type (Targ_Id);
13115 Kind := Invariant_Verification;
13117 -- Postcondition verification
13119 elsif Is_Postconditions_Proc (Targ_Id) then
13120 Extra := Find_Enclosing_Scope (Spec_Decl);
13121 Kind := Postcondition_Verification;
13123 -- Protected entry call
13125 elsif Is_Protected_Entry (Targ_Id) then
13127 Kind := Protected_Entry_Call;
13129 -- Protected subprogram call
13131 elsif Is_Protected_Subp (Targ_Id) then
13133 Kind := Protected_Subprogram_Call;
13137 elsif Is_Task_Entry (Targ_Id) then
13139 Kind := Task_Entry_Call;
13141 -- Entry, operator, or subprogram call. This case must come last
13142 -- because most invocations above are variations of this case.
13144 elsif Ekind_In (Targ_Id, E_Entry,
13153 pragma Assert (False);
13155 Kind := No_Invocation;
13157 end Get_Invocation_Attributes;
13162 Extra_Nam : Name_Id;
13163 Kind : Invocation_Kind;
13164 Rel : Invoker_Target_Relation;
13166 -- Start of processing for Record_Invocation_Relation
13169 Rel.Invoker := Invk_Id;
13170 Rel.Target := Targ_Id;
13172 -- Nothing to do when the invocation relation has already been
13173 -- recorded in ALI file of the main unit.
13175 if Is_Saved_Relation (Rel) then
13179 -- Mark the relation as recorded in the ALI file
13181 Set_Is_Saved_Relation (Rel);
13183 -- Declare the invoker in the ALI file
13185 Declare_Invocation_Construct
13186 (Constr_Id => Invk_Id,
13187 In_State => In_State);
13189 -- Obtain the invocation-specific attributes of the relation
13191 Get_Invocation_Attributes (Extra, Kind);
13193 -- Certain invocations lack an extra entity used in error diagnostics
13195 if Present (Extra) then
13196 Extra_Nam := Chars (Extra);
13198 Extra_Nam := No_Name;
13201 -- Add the relation in the ALI file
13203 Add_Invocation_Relation
13204 (Extra => Extra_Nam,
13205 Invoker => Signature_Of (Invk_Id),
13207 Target => Signature_Of (Targ_Id),
13208 Update_Units => False);
13209 end Record_Invocation_Relation;
13211 -----------------------------------
13212 -- Record_Simple_Invocation_Path --
13213 -----------------------------------
13215 procedure Record_Simple_Invocation_Path
13216 (In_State : Processing_In_State)
13218 package Scenarios renames Active_Scenario_Stack;
13220 Last_Targ : constant Entity_Id :=
13221 Target_Of (Scenarios.Last, In_State);
13222 First_Targ : Entity_Id;
13225 -- The path originates from the elaboration of the body. Add an extra
13226 -- relation from the elaboration body procedure to the first active
13229 if In_State.Processing = Invocation_Body_Processing then
13230 Build_Elaborate_Body_Procedure;
13231 First_Targ := Elab_Body_Id;
13233 -- The path originates from the elaboration of the spec. Add an extra
13234 -- relation from the elaboration spec procedure to the first active
13237 elsif In_State.Processing = Invocation_Spec_Processing then
13238 Build_Elaborate_Spec_Procedure;
13239 First_Targ := Elab_Spec_Id;
13242 First_Targ := Target_Of (Scenarios.First, In_State);
13245 -- Record a single relation from the first to the last scenario
13247 if First_Targ /= Last_Targ then
13248 Record_Invocation_Relation
13249 (Invk_Id => First_Targ,
13250 Targ_Id => Last_Targ,
13251 In_State => In_State);
13253 end Record_Simple_Invocation_Path;
13255 ----------------------------
13256 -- Set_Is_Saved_Construct --
13257 ----------------------------
13259 procedure Set_Is_Saved_Construct
13260 (Constr : Entity_Id;
13261 Val : Boolean := True)
13263 pragma Assert (Present (Constr));
13267 NE_Set.Insert (Saved_Constructs_Set, Constr);
13269 NE_Set.Delete (Saved_Constructs_Set, Constr);
13271 end Set_Is_Saved_Construct;
13273 ---------------------------
13274 -- Set_Is_Saved_Relation --
13275 ---------------------------
13277 procedure Set_Is_Saved_Relation
13278 (Rel : Invoker_Target_Relation;
13279 Val : Boolean := True)
13283 IR_Set.Insert (Saved_Relations_Set, Rel);
13285 IR_Set.Delete (Saved_Relations_Set, Rel);
13287 end Set_Is_Saved_Relation;
13293 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id is
13294 Loc : constant Source_Ptr := Sloc (Id);
13296 function Instantiation_Locations return Name_Id;
13297 pragma Inline (Instantiation_Locations);
13298 -- Create a concatenation of all lines and colums of each instance
13299 -- where source location Loc appears. Return No_Name if no instances
13302 function Qualified_Scope return Name_Id;
13303 pragma Inline (Qualified_Scope);
13304 -- Obtain the qualified name of Id's scope
13306 -----------------------------
13307 -- Instantiation_Locations --
13308 -----------------------------
13310 function Instantiation_Locations return Name_Id is
13311 Buffer : Bounded_String (2052);
13314 SFI : Source_File_Index;
13317 SFI := Get_Source_File_Index (Loc);
13318 Inst := Instantiation (SFI);
13320 -- The location is within an instance. Construct a concatenation
13321 -- of all lines and colums of each individual instance using the
13322 -- following format:
13324 -- line1_column1_line2_column2_ ... _lineN_columnN
13326 if Inst /= No_Location then
13328 Append (Buffer, Nat (Get_Logical_Line_Number (Inst)));
13329 Append (Buffer, '_');
13330 Append (Buffer, Nat (Get_Column_Number (Inst)));
13332 SFI := Get_Source_File_Index (Inst);
13333 Inst := Instantiation (SFI);
13335 exit when Inst = No_Location;
13337 Append (Buffer, '_');
13340 Loc_Nam := Name_Find (Buffer);
13343 -- Otherwise there no instances are involved
13348 end Instantiation_Locations;
13350 ---------------------
13351 -- Qualified_Scope --
13352 ---------------------
13354 function Qualified_Scope return Name_Id is
13358 Scop := Scope (Id);
13360 -- The entity appears within an anonymous concurrent type created
13361 -- for a single protected or task type declaration. Use the entity
13362 -- of the anonymous object as it represents the original scope.
13364 if Is_Concurrent_Type (Scop)
13365 and then Present (Anonymous_Object (Scop))
13367 Scop := Anonymous_Object (Scop);
13370 return Get_Qualified_Name (Scop);
13371 end Qualified_Scope;
13373 -- Start of processing for Signature_Of
13377 Invocation_Signature_Of
13378 (Column => Nat (Get_Column_Number (Loc)),
13379 Line => Nat (Get_Logical_Line_Number (Loc)),
13380 Locations => Instantiation_Locations,
13381 Name => Chars (Id),
13382 Scope => Qualified_Scope);
13390 (Pos : Active_Scenario_Pos;
13391 In_State : Processing_In_State) return Entity_Id
13393 package Scenarios renames Active_Scenario_Stack;
13395 -- Ensure that the position is within the bounds of the active
13398 pragma Assert (Scenarios.First <= Pos);
13399 pragma Assert (Pos <= Scenarios.Last);
13401 Scen_Rep : constant Scenario_Rep_Id :=
13402 Scenario_Representation_Of
13403 (Scenarios.Table (Pos), In_State);
13406 -- The true target of an activation call is the current task type
13407 -- rather than routine Activate_Tasks.
13409 if Kind (Scen_Rep) = Task_Activation_Scenario then
13410 return Activated_Task_Type (Scen_Rep);
13412 return Target (Scen_Rep);
13416 ------------------------------
13417 -- Traverse_Invocation_Body --
13418 ------------------------------
13420 procedure Traverse_Invocation_Body
13422 In_State : Processing_In_State)
13427 Requires_Processing => Is_Invocation_Scenario'Access,
13428 Processor => Process_Invocation_Scenario'Access,
13429 In_State => In_State);
13430 end Traverse_Invocation_Body;
13432 ---------------------------
13433 -- Write_Invocation_Path --
13434 ---------------------------
13436 procedure Write_Invocation_Path (In_State : Processing_In_State) is
13437 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean);
13438 pragma Inline (Write_Target);
13439 -- Write out invocation target Targ_Id to standard output. Flag
13440 -- Is_First should be set when the target is first in a path.
13446 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean) is
13448 if not Is_First then
13449 Write_Str (" --> ");
13452 Write_Name (Get_Qualified_Name (Targ_Id));
13458 package Scenarios renames Active_Scenario_Stack;
13460 First_Seen : Boolean := False;
13462 -- Start of processing for Write_Invocation_Path
13465 -- Nothing to do when flag -gnatd_T (output trace information on
13466 -- invocation path recording) is not in effect.
13468 if not Debug_Flag_Underscore_TT then
13472 -- The path originates from the elaboration of the body. Write the
13473 -- elaboration body procedure.
13475 if In_State.Processing = Invocation_Body_Processing then
13476 Write_Target (Elab_Body_Id, True);
13477 First_Seen := True;
13479 -- The path originates from the elaboration of the spec. Write the
13480 -- elaboration spec procedure.
13482 elsif In_State.Processing = Invocation_Spec_Processing then
13483 Write_Target (Elab_Spec_Id, True);
13484 First_Seen := True;
13487 -- Write each individual target invoked by its corresponding scenario
13488 -- on the active scenario stack.
13490 for Index in Scenarios.First .. Scenarios.Last loop
13492 (Targ_Id => Target_Of (Index, In_State),
13493 Is_First => Index = Scenarios.First and then not First_Seen);
13497 end Write_Invocation_Path;
13498 end Invocation_Graph;
13500 ------------------------
13501 -- Is_Safe_Activation --
13502 ------------------------
13504 function Is_Safe_Activation
13506 Task_Rep : Target_Rep_Id) return Boolean
13509 -- The activation of a task coming from an external instance cannot
13510 -- cause an ABE because the generic was already instantiated. Note
13511 -- that the instantiation itself may lead to an ABE.
13514 In_External_Instance
13516 Target_Decl => Spec_Declaration (Task_Rep));
13517 end Is_Safe_Activation;
13523 function Is_Safe_Call
13525 Subp_Id : Entity_Id;
13526 Subp_Rep : Target_Rep_Id) return Boolean
13528 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep);
13529 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep);
13532 -- The target is either an abstract subprogram, formal subprogram, or
13533 -- imported, in which case it does not have a body at compile or bind
13534 -- time. Assume that the call is ABE-safe.
13536 if Is_Bodiless_Subprogram (Subp_Id) then
13539 -- The target is an instantiation of a generic subprogram. The call
13540 -- cannot cause an ABE because the generic was already instantiated.
13541 -- Note that the instantiation itself may lead to an ABE.
13543 elsif Is_Generic_Instance (Subp_Id) then
13546 -- The invocation of a target coming from an external instance cannot
13547 -- cause an ABE because the generic was already instantiated. Note that
13548 -- the instantiation itself may lead to an ABE.
13550 elsif In_External_Instance
13552 Target_Decl => Spec_Decl)
13556 -- The target is a subprogram body without a previous declaration. The
13557 -- call cannot cause an ABE because the body has already been seen.
13559 elsif Nkind (Spec_Decl) = N_Subprogram_Body
13560 and then No (Corresponding_Spec (Spec_Decl))
13564 -- The target is a subprogram body stub without a prior declaration.
13565 -- The call cannot cause an ABE because the proper body substitutes
13568 elsif Nkind (Spec_Decl) = N_Subprogram_Body_Stub
13569 and then No (Corresponding_Spec_Of_Stub (Spec_Decl))
13573 -- Subprogram bodies which wrap attribute references used as actuals
13574 -- in instantiations are always ABE-safe. These bodies are artifacts
13577 elsif Present (Body_Decl)
13578 and then Nkind (Body_Decl) = N_Subprogram_Body
13579 and then Was_Attribute_Reference (Body_Decl)
13587 ---------------------------
13588 -- Is_Safe_Instantiation --
13589 ---------------------------
13591 function Is_Safe_Instantiation
13593 Gen_Id : Entity_Id;
13594 Gen_Rep : Target_Rep_Id) return Boolean
13596 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep);
13599 -- The generic is an intrinsic subprogram in which case it does not
13600 -- have a body at compile or bind time. Assume that the instantiation
13603 if Is_Bodiless_Subprogram (Gen_Id) then
13606 -- The instantiation of an external nested generic cannot cause an ABE
13607 -- if the outer generic was already instantiated. Note that the instance
13608 -- of the outer generic may lead to an ABE.
13610 elsif In_External_Instance
13612 Target_Decl => Spec_Decl)
13616 -- The generic is a package. The instantiation cannot cause an ABE when
13617 -- the package has no body.
13619 elsif Ekind (Gen_Id) = E_Generic_Package
13620 and then not Has_Body (Spec_Decl)
13626 end Is_Safe_Instantiation;
13632 function Is_Same_Unit
13633 (Unit_1 : Entity_Id;
13634 Unit_2 : Entity_Id) return Boolean
13637 return Unit_Entity (Unit_1) = Unit_Entity (Unit_2);
13640 -------------------------------
13641 -- Kill_Elaboration_Scenario --
13642 -------------------------------
13644 procedure Kill_Elaboration_Scenario (N : Node_Id) is
13646 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
13647 -- enabled) is in effect because the legacy ABE lechanism does not need
13648 -- to carry out this action.
13650 if Legacy_Elaboration_Checks then
13653 -- Nothing to do when the elaboration phase of the compiler is not
13656 elsif not Elaboration_Phase_Active then
13660 -- Eliminate a recorded scenario when it appears within dead code
13661 -- because it will not be executed at elaboration time.
13663 if Is_Scenario (N) then
13664 Delete_Scenario (N);
13666 end Kill_Elaboration_Scenario;
13668 ----------------------
13669 -- Main_Unit_Entity --
13670 ----------------------
13672 function Main_Unit_Entity return Entity_Id is
13674 -- Note that Cunit_Entity (Main_Unit) is not reliable in the presence of
13675 -- generic bodies and may return an outdated entity.
13677 return Defining_Entity (Unit (Cunit (Main_Unit)));
13678 end Main_Unit_Entity;
13680 ----------------------
13681 -- Non_Private_View --
13682 ----------------------
13684 function Non_Private_View (Typ : Entity_Id) return Entity_Id is
13686 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
13687 return Full_View (Typ);
13691 end Non_Private_View;
13693 ---------------------------------
13694 -- Record_Elaboration_Scenario --
13695 ---------------------------------
13697 procedure Record_Elaboration_Scenario (N : Node_Id) is
13698 procedure Check_Preelaborated_Call
13700 Call_Lvl : Enclosing_Level_Kind);
13701 pragma Inline (Check_Preelaborated_Call);
13702 -- Verify that entry, operator, or subprogram call Call with enclosing
13703 -- level Call_Lvl does not appear at the library level of preelaborated
13706 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id;
13707 pragma Inline (Find_Code_Unit);
13708 -- Return the code unit which contains arbitrary node or entity Nod.
13709 -- This is the unit of the file which physically contains the related
13710 -- construct denoted by Nod except when Nod is within an instantiation.
13711 -- In that case the unit is that of the top-level instantiation.
13713 function In_Preelaborated_Context (Nod : Node_Id) return Boolean;
13714 pragma Inline (In_Preelaborated_Context);
13715 -- Determine whether arbitrary node Nod appears within a preelaborated
13718 procedure Record_Access_Taken
13720 Attr_Lvl : Enclosing_Level_Kind);
13721 pragma Inline (Record_Access_Taken);
13722 -- Record 'Access scenario Attr with enclosing level Attr_Lvl
13724 procedure Record_Call_Or_Task_Activation
13726 Call_Lvl : Enclosing_Level_Kind);
13727 pragma Inline (Record_Call_Or_Task_Activation);
13728 -- Record call scenario Call with enclosing level Call_Lvl
13730 procedure Record_Instantiation
13732 Inst_Lvl : Enclosing_Level_Kind);
13733 pragma Inline (Record_Instantiation);
13734 -- Record instantiation scenario Inst with enclosing level Inst_Lvl
13736 procedure Record_Variable_Assignment
13738 Asmt_Lvl : Enclosing_Level_Kind);
13739 pragma Inline (Record_Variable_Assignment);
13740 -- Record variable assignment scenario Asmt with enclosing level
13743 procedure Record_Variable_Reference
13745 Ref_Lvl : Enclosing_Level_Kind);
13746 pragma Inline (Record_Variable_Reference);
13747 -- Record variable reference scenario Ref with enclosing level Ref_Lvl
13749 ------------------------------
13750 -- Check_Preelaborated_Call --
13751 ------------------------------
13753 procedure Check_Preelaborated_Call
13755 Call_Lvl : Enclosing_Level_Kind)
13758 -- Nothing to do when the call is internally generated because it is
13759 -- assumed that it will never violate preelaboration.
13761 if not Is_Source_Call (Call) then
13764 -- Library-level calls are always considered because they are part of
13765 -- the associated unit's elaboration actions.
13767 elsif Call_Lvl in Library_Level then
13770 -- Calls at the library level of a generic package body have to be
13771 -- checked because they would render an instantiation illegal if the
13772 -- template is marked as preelaborated. Note that this does not apply
13773 -- to calls at the library level of a generic package spec.
13775 elsif Call_Lvl = Generic_Body_Level then
13778 -- Otherwise the call does not appear at the proper level and must
13779 -- not be considered for this check.
13785 -- The call appears within a preelaborated unit. Emit a warning only
13786 -- for internal uses, otherwise this is an error.
13788 if In_Preelaborated_Context (Call) then
13789 Error_Msg_Warn := GNAT_Mode;
13791 ("<<non-static call not allowed in preelaborated unit", Call);
13793 end Check_Preelaborated_Call;
13795 --------------------
13796 -- Find_Code_Unit --
13797 --------------------
13799 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id is
13801 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (Nod))));
13802 end Find_Code_Unit;
13804 ------------------------------
13805 -- In_Preelaborated_Context --
13806 ------------------------------
13808 function In_Preelaborated_Context (Nod : Node_Id) return Boolean is
13809 Body_Id : constant Entity_Id := Find_Code_Unit (Nod);
13810 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id);
13813 -- The node appears within a package body whose corresponding spec is
13814 -- subject to pragma Remote_Call_Interface or Remote_Types. This does
13815 -- not result in a preelaborated context because the package body may
13816 -- be on another machine.
13818 if Ekind (Body_Id) = E_Package_Body
13819 and then Ekind_In (Spec_Id, E_Generic_Package, E_Package)
13820 and then (Is_Remote_Call_Interface (Spec_Id)
13821 or else Is_Remote_Types (Spec_Id))
13825 -- Otherwise the node appears within a preelaborated context when the
13826 -- associated unit is preelaborated.
13829 return Is_Preelaborated_Unit (Spec_Id);
13831 end In_Preelaborated_Context;
13833 -------------------------
13834 -- Record_Access_Taken --
13835 -------------------------
13837 procedure Record_Access_Taken
13839 Attr_Lvl : Enclosing_Level_Kind)
13842 -- Signal any enclosing local exception handlers that the 'Access may
13843 -- raise Program_Error due to a failed ABE check when switch -gnatd.o
13844 -- (conservative elaboration order for indirect calls) is in effect.
13845 -- Marking the exception handlers ensures proper expansion by both
13846 -- the front and back end restriction when No_Exception_Propagation
13849 if Debug_Flag_Dot_O then
13850 Possible_Local_Raise (Attr, Standard_Program_Error);
13853 -- Add 'Access to the appropriate set
13855 if Attr_Lvl = Library_Body_Level then
13856 Add_Library_Body_Scenario (Attr);
13858 elsif Attr_Lvl = Library_Spec_Level
13859 or else Attr_Lvl = Instantiation_Level
13861 Add_Library_Spec_Scenario (Attr);
13864 -- 'Access requires a conditional ABE check when the dynamic model is
13867 Add_Dynamic_ABE_Check_Scenario (Attr);
13868 end Record_Access_Taken;
13870 ------------------------------------
13871 -- Record_Call_Or_Task_Activation --
13872 ------------------------------------
13874 procedure Record_Call_Or_Task_Activation
13876 Call_Lvl : Enclosing_Level_Kind)
13879 -- Signal any enclosing local exception handlers that the call may
13880 -- raise Program_Error due to failed ABE check. Marking the exception
13881 -- handlers ensures proper expansion by both the front and back end
13882 -- restriction when No_Exception_Propagation is in effect.
13884 Possible_Local_Raise (Call, Standard_Program_Error);
13886 -- Perform early detection of guaranteed ABEs in order to suppress
13887 -- the instantiation of generic bodies because gigi cannot handle
13888 -- certain types of premature instantiations.
13890 Process_Guaranteed_ABE
13892 In_State => Guaranteed_ABE_State);
13894 -- Add the call or task activation to the appropriate set
13896 if Call_Lvl = Declaration_Level then
13897 Add_Declaration_Scenario (Call);
13899 elsif Call_Lvl = Library_Body_Level then
13900 Add_Library_Body_Scenario (Call);
13902 elsif Call_Lvl = Library_Spec_Level
13903 or else Call_Lvl = Instantiation_Level
13905 Add_Library_Spec_Scenario (Call);
13908 -- A call or a task activation requires a conditional ABE check when
13909 -- the dynamic model is in effect.
13911 Add_Dynamic_ABE_Check_Scenario (Call);
13912 end Record_Call_Or_Task_Activation;
13914 --------------------------
13915 -- Record_Instantiation --
13916 --------------------------
13918 procedure Record_Instantiation
13920 Inst_Lvl : Enclosing_Level_Kind)
13923 -- Signal enclosing local exception handlers that instantiation may
13924 -- raise Program_Error due to failed ABE check. Marking the exception
13925 -- handlers ensures proper expansion by both the front and back end
13926 -- restriction when No_Exception_Propagation is in effect.
13928 Possible_Local_Raise (Inst, Standard_Program_Error);
13930 -- Perform early detection of guaranteed ABEs in order to suppress
13931 -- the instantiation of generic bodies because gigi cannot handle
13932 -- certain types of premature instantiations.
13934 Process_Guaranteed_ABE
13936 In_State => Guaranteed_ABE_State);
13938 -- Add the instantiation to the appropriate set
13940 if Inst_Lvl = Declaration_Level then
13941 Add_Declaration_Scenario (Inst);
13943 elsif Inst_Lvl = Library_Body_Level then
13944 Add_Library_Body_Scenario (Inst);
13946 elsif Inst_Lvl = Library_Spec_Level
13947 or else Inst_Lvl = Instantiation_Level
13949 Add_Library_Spec_Scenario (Inst);
13952 -- Instantiations of generics subject to SPARK_Mode On require
13953 -- elaboration-related checks even though the instantiations may
13954 -- not appear within elaboration code.
13956 if Is_Suitable_SPARK_Instantiation (Inst) then
13957 Add_SPARK_Scenario (Inst);
13960 -- An instantiation requires a conditional ABE check when the dynamic
13961 -- model is in effect.
13963 Add_Dynamic_ABE_Check_Scenario (Inst);
13964 end Record_Instantiation;
13966 --------------------------------
13967 -- Record_Variable_Assignment --
13968 --------------------------------
13970 procedure Record_Variable_Assignment
13972 Asmt_Lvl : Enclosing_Level_Kind)
13975 -- Add the variable assignment to the appropriate set
13977 if Asmt_Lvl = Library_Body_Level then
13978 Add_Library_Body_Scenario (Asmt);
13980 elsif Asmt_Lvl = Library_Spec_Level
13981 or else Asmt_Lvl = Instantiation_Level
13983 Add_Library_Spec_Scenario (Asmt);
13985 end Record_Variable_Assignment;
13987 -------------------------------
13988 -- Record_Variable_Reference --
13989 -------------------------------
13991 procedure Record_Variable_Reference
13993 Ref_Lvl : Enclosing_Level_Kind)
13996 -- Add the variable reference to the appropriate set
13998 if Ref_Lvl = Library_Body_Level then
13999 Add_Library_Body_Scenario (Ref);
14001 elsif Ref_Lvl = Library_Spec_Level
14002 or else Ref_Lvl = Instantiation_Level
14004 Add_Library_Spec_Scenario (Ref);
14006 end Record_Variable_Reference;
14010 Scen : constant Node_Id := Scenario (N);
14011 Scen_Lvl : Enclosing_Level_Kind;
14013 -- Start of processing for Record_Elaboration_Scenario
14016 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
14017 -- enabled) is in effect because the legacy ABE mechanism does not need
14018 -- to carry out this action.
14020 if Legacy_Elaboration_Checks then
14023 -- Nothing to do for ASIS because ABE checks and diagnostics are not
14024 -- performed in this mode.
14026 elsif ASIS_Mode then
14029 -- Nothing to do when the scenario is being preanalyzed
14031 elsif Preanalysis_Active then
14034 -- Nothing to do when the elaboration phase of the compiler is not
14037 elsif not Elaboration_Phase_Active then
14041 Scen_Lvl := Find_Enclosing_Level (Scen);
14043 -- Ensure that a library-level call does not appear in a preelaborated
14044 -- unit. The check must come before ignoring scenarios within external
14045 -- units or inside generics because calls in those context must also be
14048 if Is_Suitable_Call (Scen) then
14049 Check_Preelaborated_Call (Scen, Scen_Lvl);
14052 -- Nothing to do when the scenario does not appear within the main unit
14054 if not In_Main_Context (Scen) then
14057 -- Nothing to do when the scenario appears within a generic
14059 elsif Inside_A_Generic then
14064 elsif Is_Suitable_Access_Taken (Scen) then
14065 Record_Access_Taken
14067 Attr_Lvl => Scen_Lvl);
14069 -- Call or task activation
14071 elsif Is_Suitable_Call (Scen) then
14072 Record_Call_Or_Task_Activation
14074 Call_Lvl => Scen_Lvl);
14076 -- Derived type declaration
14078 elsif Is_Suitable_SPARK_Derived_Type (Scen) then
14079 Add_SPARK_Scenario (Scen);
14083 elsif Is_Suitable_Instantiation (Scen) then
14084 Record_Instantiation
14086 Inst_Lvl => Scen_Lvl);
14088 -- Refined_State pragma
14090 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then
14091 Add_SPARK_Scenario (Scen);
14093 -- Variable assignment
14095 elsif Is_Suitable_Variable_Assignment (Scen) then
14096 Record_Variable_Assignment
14098 Asmt_Lvl => Scen_Lvl);
14100 -- Variable reference
14102 elsif Is_Suitable_Variable_Reference (Scen) then
14103 Record_Variable_Reference
14105 Ref_Lvl => Scen_Lvl);
14107 end Record_Elaboration_Scenario;
14113 function Scenario (N : Node_Id) return Node_Id is
14114 Orig_N : constant Node_Id := Original_Node (N);
14117 -- An expanded instantiation is rewritten into a spec-body pair where
14118 -- N denotes the spec. In this case the original instantiation is the
14119 -- proper elaboration scenario.
14121 if Nkind (Orig_N) in N_Generic_Instantiation then
14124 -- Otherwise the scenario is already in its proper form
14131 ----------------------
14132 -- Scenario_Storage --
14133 ----------------------
14135 package body Scenario_Storage is
14137 ---------------------
14138 -- Data structures --
14139 ---------------------
14141 -- The following sets store all scenarios
14143 Declaration_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14144 Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14145 Library_Body_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14146 Library_Spec_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14147 SPARK_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14149 -------------------------------
14150 -- Finalize_Scenario_Storage --
14151 -------------------------------
14153 procedure Finalize_Scenario_Storage is
14155 NE_Set.Destroy (Declaration_Scenarios);
14156 NE_Set.Destroy (Dynamic_ABE_Check_Scenarios);
14157 NE_Set.Destroy (Library_Body_Scenarios);
14158 NE_Set.Destroy (Library_Spec_Scenarios);
14159 NE_Set.Destroy (SPARK_Scenarios);
14160 end Finalize_Scenario_Storage;
14162 ---------------------------------
14163 -- Initialize_Scenario_Storage --
14164 ---------------------------------
14166 procedure Initialize_Scenario_Storage is
14168 Declaration_Scenarios := NE_Set.Create (1000);
14169 Dynamic_ABE_Check_Scenarios := NE_Set.Create (500);
14170 Library_Body_Scenarios := NE_Set.Create (1000);
14171 Library_Spec_Scenarios := NE_Set.Create (1000);
14172 SPARK_Scenarios := NE_Set.Create (100);
14173 end Initialize_Scenario_Storage;
14175 ------------------------------
14176 -- Add_Declaration_Scenario --
14177 ------------------------------
14179 procedure Add_Declaration_Scenario (N : Node_Id) is
14180 pragma Assert (Present (N));
14182 NE_Set.Insert (Declaration_Scenarios, N);
14183 end Add_Declaration_Scenario;
14185 ------------------------------------
14186 -- Add_Dynamic_ABE_Check_Scenario --
14187 ------------------------------------
14189 procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id) is
14190 pragma Assert (Present (N));
14193 if not Check_Or_Failure_Generation_OK then
14196 -- Nothing to do if the dynamic model is not in effect
14198 elsif not Dynamic_Elaboration_Checks then
14202 NE_Set.Insert (Dynamic_ABE_Check_Scenarios, N);
14203 end Add_Dynamic_ABE_Check_Scenario;
14205 -------------------------------
14206 -- Add_Library_Body_Scenario --
14207 -------------------------------
14209 procedure Add_Library_Body_Scenario (N : Node_Id) is
14210 pragma Assert (Present (N));
14212 NE_Set.Insert (Library_Body_Scenarios, N);
14213 end Add_Library_Body_Scenario;
14215 -------------------------------
14216 -- Add_Library_Spec_Scenario --
14217 -------------------------------
14219 procedure Add_Library_Spec_Scenario (N : Node_Id) is
14220 pragma Assert (Present (N));
14222 NE_Set.Insert (Library_Spec_Scenarios, N);
14223 end Add_Library_Spec_Scenario;
14225 ------------------------
14226 -- Add_SPARK_Scenario --
14227 ------------------------
14229 procedure Add_SPARK_Scenario (N : Node_Id) is
14230 pragma Assert (Present (N));
14232 NE_Set.Insert (SPARK_Scenarios, N);
14233 end Add_SPARK_Scenario;
14235 ---------------------
14236 -- Delete_Scenario --
14237 ---------------------
14239 procedure Delete_Scenario (N : Node_Id) is
14240 pragma Assert (Present (N));
14243 -- Delete the scenario from whichever set it belongs to
14245 NE_Set.Delete (Declaration_Scenarios, N);
14246 NE_Set.Delete (Dynamic_ABE_Check_Scenarios, N);
14247 NE_Set.Delete (Library_Body_Scenarios, N);
14248 NE_Set.Delete (Library_Spec_Scenarios, N);
14249 NE_Set.Delete (SPARK_Scenarios, N);
14250 end Delete_Scenario;
14252 -----------------------------------
14253 -- Iterate_Declaration_Scenarios --
14254 -----------------------------------
14256 function Iterate_Declaration_Scenarios return NE_Set.Iterator is
14258 return NE_Set.Iterate (Declaration_Scenarios);
14259 end Iterate_Declaration_Scenarios;
14261 -----------------------------------------
14262 -- Iterate_Dynamic_ABE_Check_Scenarios --
14263 -----------------------------------------
14265 function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator is
14267 return NE_Set.Iterate (Dynamic_ABE_Check_Scenarios);
14268 end Iterate_Dynamic_ABE_Check_Scenarios;
14270 ------------------------------------
14271 -- Iterate_Library_Body_Scenarios --
14272 ------------------------------------
14274 function Iterate_Library_Body_Scenarios return NE_Set.Iterator is
14276 return NE_Set.Iterate (Library_Body_Scenarios);
14277 end Iterate_Library_Body_Scenarios;
14279 ------------------------------------
14280 -- Iterate_Library_Spec_Scenarios --
14281 ------------------------------------
14283 function Iterate_Library_Spec_Scenarios return NE_Set.Iterator is
14285 return NE_Set.Iterate (Library_Spec_Scenarios);
14286 end Iterate_Library_Spec_Scenarios;
14288 -----------------------------
14289 -- Iterate_SPARK_Scenarios --
14290 -----------------------------
14292 function Iterate_SPARK_Scenarios return NE_Set.Iterator is
14294 return NE_Set.Iterate (SPARK_Scenarios);
14295 end Iterate_SPARK_Scenarios;
14297 ----------------------
14298 -- Replace_Scenario --
14299 ----------------------
14301 procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id) is
14302 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set);
14303 -- Determine whether scenario Old_N is present in set Scenarios, and
14304 -- if this is the case it, replace it with New_N.
14306 -------------------------
14307 -- Replace_Scenario_In --
14308 -------------------------
14310 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set) is
14312 -- The set is intentionally checked for existance because node
14313 -- rewriting may occur after Sem_Elab has verified all scenarios
14314 -- and data structures have been destroyed.
14316 if NE_Set.Present (Scenarios)
14317 and then NE_Set.Contains (Scenarios, Old_N)
14319 NE_Set.Delete (Scenarios, Old_N);
14320 NE_Set.Insert (Scenarios, New_N);
14322 end Replace_Scenario_In;
14324 -- Start of processing for Replace_Scenario
14327 Replace_Scenario_In (Declaration_Scenarios);
14328 Replace_Scenario_In (Dynamic_ABE_Check_Scenarios);
14329 Replace_Scenario_In (Library_Body_Scenarios);
14330 Replace_Scenario_In (Library_Spec_Scenarios);
14331 Replace_Scenario_In (SPARK_Scenarios);
14332 end Replace_Scenario;
14333 end Scenario_Storage;
14339 package body Semantics is
14341 --------------------------------
14342 -- Is_Accept_Alternative_Proc --
14343 --------------------------------
14345 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is
14347 -- To qualify, the entity must denote a procedure with a receiving
14351 Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id));
14352 end Is_Accept_Alternative_Proc;
14354 ------------------------
14355 -- Is_Activation_Proc --
14356 ------------------------
14358 function Is_Activation_Proc (Id : Entity_Id) return Boolean is
14360 -- To qualify, the entity must denote one of the runtime procedures
14361 -- in charge of task activation.
14363 if Ekind (Id) = E_Procedure then
14364 if Restricted_Profile then
14365 return Is_RTE (Id, RE_Activate_Restricted_Tasks);
14367 return Is_RTE (Id, RE_Activate_Tasks);
14372 end Is_Activation_Proc;
14374 ----------------------------
14375 -- Is_Ada_Semantic_Target --
14376 ----------------------------
14378 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is
14381 Is_Activation_Proc (Id)
14382 or else Is_Controlled_Proc (Id, Name_Adjust)
14383 or else Is_Controlled_Proc (Id, Name_Finalize)
14384 or else Is_Controlled_Proc (Id, Name_Initialize)
14385 or else Is_Init_Proc (Id)
14386 or else Is_Invariant_Proc (Id)
14387 or else Is_Protected_Entry (Id)
14388 or else Is_Protected_Subp (Id)
14389 or else Is_Protected_Body_Subp (Id)
14390 or else Is_Subprogram_Inst (Id)
14391 or else Is_Task_Entry (Id);
14392 end Is_Ada_Semantic_Target;
14394 --------------------------------
14395 -- Is_Assertion_Pragma_Target --
14396 --------------------------------
14398 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is
14401 Is_Default_Initial_Condition_Proc (Id)
14402 or else Is_Initial_Condition_Proc (Id)
14403 or else Is_Invariant_Proc (Id)
14404 or else Is_Partial_Invariant_Proc (Id)
14405 or else Is_Postconditions_Proc (Id);
14406 end Is_Assertion_Pragma_Target;
14408 ----------------------------
14409 -- Is_Bodiless_Subprogram --
14410 ----------------------------
14412 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is
14414 -- An abstract subprogram does not have a body
14416 if Ekind_In (Subp_Id, E_Function,
14419 and then Is_Abstract_Subprogram (Subp_Id)
14423 -- A formal subprogram does not have a body
14425 elsif Is_Formal_Subprogram (Subp_Id) then
14428 -- An imported subprogram may have a body, however it is not known at
14429 -- compile or bind time where the body resides and whether it will be
14430 -- elaborated on time.
14432 elsif Is_Imported (Subp_Id) then
14437 end Is_Bodiless_Subprogram;
14439 ----------------------
14440 -- Is_Bridge_Target --
14441 ----------------------
14443 function Is_Bridge_Target (Id : Entity_Id) return Boolean is
14446 Is_Accept_Alternative_Proc (Id)
14447 or else Is_Finalizer_Proc (Id)
14448 or else Is_Partial_Invariant_Proc (Id)
14449 or else Is_Postconditions_Proc (Id)
14450 or else Is_TSS (Id, TSS_Deep_Adjust)
14451 or else Is_TSS (Id, TSS_Deep_Finalize)
14452 or else Is_TSS (Id, TSS_Deep_Initialize);
14453 end Is_Bridge_Target;
14455 ------------------------
14456 -- Is_Controlled_Proc --
14457 ------------------------
14459 function Is_Controlled_Proc
14460 (Subp_Id : Entity_Id;
14461 Subp_Nam : Name_Id) return Boolean
14463 Formal_Id : Entity_Id;
14466 pragma Assert (Nam_In (Subp_Nam, Name_Adjust,
14470 -- To qualify, the subprogram must denote a source procedure with
14471 -- name Adjust, Finalize, or Initialize where the sole formal is
14474 if Comes_From_Source (Subp_Id)
14475 and then Ekind (Subp_Id) = E_Procedure
14476 and then Chars (Subp_Id) = Subp_Nam
14478 Formal_Id := First_Formal (Subp_Id);
14481 Present (Formal_Id)
14482 and then Is_Controlled (Etype (Formal_Id))
14483 and then No (Next_Formal (Formal_Id));
14487 end Is_Controlled_Proc;
14489 ---------------------------------------
14490 -- Is_Default_Initial_Condition_Proc --
14491 ---------------------------------------
14493 function Is_Default_Initial_Condition_Proc
14494 (Id : Entity_Id) return Boolean
14497 -- To qualify, the entity must denote a Default_Initial_Condition
14500 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id);
14501 end Is_Default_Initial_Condition_Proc;
14503 -----------------------
14504 -- Is_Finalizer_Proc --
14505 -----------------------
14507 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is
14509 -- To qualify, the entity must denote a _Finalizer procedure
14511 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
14512 end Is_Finalizer_Proc;
14514 -------------------------------
14515 -- Is_Initial_Condition_Proc --
14516 -------------------------------
14518 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is
14520 -- To qualify, the entity must denote an Initial_Condition procedure
14523 Ekind (Id) = E_Procedure
14524 and then Is_Initial_Condition_Procedure (Id);
14525 end Is_Initial_Condition_Proc;
14527 --------------------
14528 -- Is_Initialized --
14529 --------------------
14531 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is
14533 -- To qualify, the object declaration must have an expression
14536 Present (Expression (Obj_Decl))
14537 or else Has_Init_Expression (Obj_Decl);
14538 end Is_Initialized;
14540 -----------------------
14541 -- Is_Invariant_Proc --
14542 -----------------------
14544 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is
14546 -- To qualify, the entity must denote the "full" invariant procedure
14548 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id);
14549 end Is_Invariant_Proc;
14551 ---------------------------------------
14552 -- Is_Non_Library_Level_Encapsulator --
14553 ---------------------------------------
14555 function Is_Non_Library_Level_Encapsulator
14556 (N : Node_Id) return Boolean
14560 when N_Abstract_Subprogram_Declaration
14561 | N_Aspect_Specification
14562 | N_Component_Declaration
14564 | N_Entry_Declaration
14565 | N_Expression_Function
14566 | N_Formal_Abstract_Subprogram_Declaration
14567 | N_Formal_Concrete_Subprogram_Declaration
14568 | N_Formal_Object_Declaration
14569 | N_Formal_Package_Declaration
14570 | N_Formal_Type_Declaration
14571 | N_Generic_Association
14572 | N_Implicit_Label_Declaration
14573 | N_Incomplete_Type_Declaration
14574 | N_Private_Extension_Declaration
14575 | N_Private_Type_Declaration
14577 | N_Protected_Type_Declaration
14578 | N_Single_Protected_Declaration
14579 | N_Single_Task_Declaration
14580 | N_Subprogram_Body
14581 | N_Subprogram_Declaration
14583 | N_Task_Type_Declaration
14588 return Is_Generic_Declaration_Or_Body (N);
14590 end Is_Non_Library_Level_Encapsulator;
14592 -------------------------------
14593 -- Is_Partial_Invariant_Proc --
14594 -------------------------------
14596 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is
14598 -- To qualify, the entity must denote the "partial" invariant
14602 Ekind (Id) = E_Procedure
14603 and then Is_Partial_Invariant_Procedure (Id);
14604 end Is_Partial_Invariant_Proc;
14606 ----------------------------
14607 -- Is_Postconditions_Proc --
14608 ----------------------------
14610 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is
14612 -- To qualify, the entity must denote a _Postconditions procedure
14615 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions;
14616 end Is_Postconditions_Proc;
14618 ---------------------------
14619 -- Is_Preelaborated_Unit --
14620 ---------------------------
14622 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is
14625 Is_Preelaborated (Id)
14626 or else Is_Pure (Id)
14627 or else Is_Remote_Call_Interface (Id)
14628 or else Is_Remote_Types (Id)
14629 or else Is_Shared_Passive (Id);
14630 end Is_Preelaborated_Unit;
14632 ------------------------
14633 -- Is_Protected_Entry --
14634 ------------------------
14636 function Is_Protected_Entry (Id : Entity_Id) return Boolean is
14638 -- To qualify, the entity must denote an entry defined in a protected
14643 and then Is_Protected_Type (Non_Private_View (Scope (Id)));
14644 end Is_Protected_Entry;
14646 -----------------------
14647 -- Is_Protected_Subp --
14648 -----------------------
14650 function Is_Protected_Subp (Id : Entity_Id) return Boolean is
14652 -- To qualify, the entity must denote a subprogram defined within a
14656 Ekind_In (Id, E_Function, E_Procedure)
14657 and then Is_Protected_Type (Non_Private_View (Scope (Id)));
14658 end Is_Protected_Subp;
14660 ----------------------------
14661 -- Is_Protected_Body_Subp --
14662 ----------------------------
14664 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is
14666 -- To qualify, the entity must denote a subprogram with attribute
14667 -- Protected_Subprogram set.
14670 Ekind_In (Id, E_Function, E_Procedure)
14671 and then Present (Protected_Subprogram (Id));
14672 end Is_Protected_Body_Subp;
14678 function Is_Scenario (N : Node_Id) return Boolean is
14681 when N_Assignment_Statement
14682 | N_Attribute_Reference
14684 | N_Entry_Call_Statement
14687 | N_Function_Instantiation
14689 | N_Package_Instantiation
14690 | N_Procedure_Call_Statement
14691 | N_Procedure_Instantiation
14692 | N_Requeue_Statement
14701 ------------------------------
14702 -- Is_SPARK_Semantic_Target --
14703 ------------------------------
14705 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is
14708 Is_Default_Initial_Condition_Proc (Id)
14709 or else Is_Initial_Condition_Proc (Id);
14710 end Is_SPARK_Semantic_Target;
14712 ------------------------
14713 -- Is_Subprogram_Inst --
14714 ------------------------
14716 function Is_Subprogram_Inst (Id : Entity_Id) return Boolean is
14718 -- To qualify, the entity must denote a function or a procedure which
14719 -- is hidden within an anonymous package, and is a generic instance.
14722 Ekind_In (Id, E_Function, E_Procedure)
14723 and then Is_Hidden (Id)
14724 and then Is_Generic_Instance (Id);
14725 end Is_Subprogram_Inst;
14727 ------------------------------
14728 -- Is_Suitable_Access_Taken --
14729 ------------------------------
14731 function Is_Suitable_Access_Taken (N : Node_Id) return Boolean is
14734 Subp_Id : Entity_Id;
14737 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
14739 if Debug_Flag_Dot_UU then
14742 -- Nothing to do when the scenario is not an attribute reference
14744 elsif Nkind (N) /= N_Attribute_Reference then
14747 -- Nothing to do for internally-generated attributes because they are
14748 -- assumed to be ABE safe.
14750 elsif not Comes_From_Source (N) then
14754 Nam := Attribute_Name (N);
14755 Pref := Prefix (N);
14757 -- Sanitize the prefix of the attribute
14759 if not Is_Entity_Name (Pref) then
14762 elsif No (Entity (Pref)) then
14766 Subp_Id := Entity (Pref);
14768 if not Is_Subprogram_Or_Entry (Subp_Id) then
14772 -- Traverse a possible chain of renamings to obtain the original
14773 -- entry or subprogram which the prefix may rename.
14775 Subp_Id := Get_Renamed_Entity (Subp_Id);
14777 -- To qualify, the attribute must meet the following prerequisites:
14781 -- The prefix must denote a source entry, operator, or subprogram
14782 -- which is not imported.
14784 Comes_From_Source (Subp_Id)
14785 and then Is_Subprogram_Or_Entry (Subp_Id)
14786 and then not Is_Bodiless_Subprogram (Subp_Id)
14788 -- The attribute name must be one of the 'Access forms. Note that
14789 -- 'Unchecked_Access cannot apply to a subprogram.
14791 and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access);
14792 end Is_Suitable_Access_Taken;
14794 ----------------------
14795 -- Is_Suitable_Call --
14796 ----------------------
14798 function Is_Suitable_Call (N : Node_Id) return Boolean is
14800 -- Entry and subprogram calls are intentionally ignored because they
14801 -- may undergo expansion depending on the compilation mode, previous
14802 -- errors, generic context, etc. Call markers play the role of calls
14803 -- and provide a uniform foundation for ABE processing.
14805 return Nkind (N) = N_Call_Marker;
14806 end Is_Suitable_Call;
14808 -------------------------------
14809 -- Is_Suitable_Instantiation --
14810 -------------------------------
14812 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is
14813 Inst : constant Node_Id := Scenario (N);
14816 -- To qualify, the instantiation must come from source
14819 Comes_From_Source (Inst)
14820 and then Nkind (Inst) in N_Generic_Instantiation;
14821 end Is_Suitable_Instantiation;
14823 ------------------------------------
14824 -- Is_Suitable_SPARK_Derived_Type --
14825 ------------------------------------
14827 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is
14832 -- To qualify, the type declaration must denote a derived tagged type
14833 -- with primitive operations, subject to pragma SPARK_Mode On.
14835 if Nkind (N) = N_Full_Type_Declaration
14836 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
14838 Typ := Defining_Entity (N);
14839 Prag := SPARK_Pragma (Typ);
14842 Is_Tagged_Type (Typ)
14843 and then Has_Primitive_Operations (Typ)
14844 and then Present (Prag)
14845 and then Get_SPARK_Mode_From_Annotation (Prag) = On;
14849 end Is_Suitable_SPARK_Derived_Type;
14851 -------------------------------------
14852 -- Is_Suitable_SPARK_Instantiation --
14853 -------------------------------------
14855 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is
14856 Inst : constant Node_Id := Scenario (N);
14858 Gen_Id : Entity_Id;
14862 -- To qualify, both the instantiation and the generic must be subject
14863 -- to SPARK_Mode On.
14865 if Is_Suitable_Instantiation (N) then
14866 Gen_Id := Instantiated_Generic (Inst);
14867 Prag := SPARK_Pragma (Gen_Id);
14870 Is_SPARK_Mode_On_Node (Inst)
14871 and then Present (Prag)
14872 and then Get_SPARK_Mode_From_Annotation (Prag) = On;
14876 end Is_Suitable_SPARK_Instantiation;
14878 --------------------------------------------
14879 -- Is_Suitable_SPARK_Refined_State_Pragma --
14880 --------------------------------------------
14882 function Is_Suitable_SPARK_Refined_State_Pragma
14883 (N : Node_Id) return Boolean
14886 -- To qualfy, the pragma must denote Refined_State
14889 Nkind (N) = N_Pragma
14890 and then Pragma_Name (N) = Name_Refined_State;
14891 end Is_Suitable_SPARK_Refined_State_Pragma;
14893 -------------------------------------
14894 -- Is_Suitable_Variable_Assignment --
14895 -------------------------------------
14897 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is
14899 N_Unit_Id : Entity_Id;
14901 Var_Decl : Node_Id;
14902 Var_Id : Entity_Id;
14903 Var_Unit : Node_Id;
14904 Var_Unit_Id : Entity_Id;
14907 -- Nothing to do when the scenario is not an assignment
14909 if Nkind (N) /= N_Assignment_Statement then
14912 -- Nothing to do for internally-generated assignments because they
14913 -- are assumed to be ABE safe.
14915 elsif not Comes_From_Source (N) then
14918 -- Assignments are ignored in GNAT mode on the assumption that
14919 -- they are ABE-safe. This behaviour parallels that of the old
14922 elsif GNAT_Mode then
14926 Nam := Assignment_Target (N);
14928 -- Sanitize the left hand side of the assignment
14930 if not Is_Entity_Name (Nam) then
14933 elsif No (Entity (Nam)) then
14937 Var_Id := Entity (Nam);
14939 -- Sanitize the variable
14941 if Var_Id = Any_Id then
14944 elsif Ekind (Var_Id) /= E_Variable then
14948 Var_Decl := Declaration_Node (Var_Id);
14950 if Nkind (Var_Decl) /= N_Object_Declaration then
14954 N_Unit_Id := Find_Top_Unit (N);
14955 N_Unit := Unit_Declaration_Node (N_Unit_Id);
14957 Var_Unit_Id := Find_Top_Unit (Var_Decl);
14958 Var_Unit := Unit_Declaration_Node (Var_Unit_Id);
14960 -- To qualify, the assignment must meet the following prerequisites:
14963 Comes_From_Source (Var_Id)
14965 -- The variable must be declared in the spec of compilation unit
14968 and then Nkind (Var_Unit) = N_Package_Declaration
14969 and then Find_Enclosing_Level (Var_Decl) = Library_Spec_Level
14971 -- The assignment must occur in the body of compilation unit U
14973 and then Nkind (N_Unit) = N_Package_Body
14974 and then Present (Corresponding_Body (Var_Unit))
14975 and then Corresponding_Body (Var_Unit) = N_Unit_Id;
14976 end Is_Suitable_Variable_Assignment;
14978 ------------------------------------
14979 -- Is_Suitable_Variable_Reference --
14980 ------------------------------------
14982 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is
14984 -- Expanded names and identifiers are intentionally ignored because
14985 -- they be folded, optimized away, etc. Variable references markers
14986 -- play the role of variable references and provide a uniform
14987 -- foundation for ABE processing.
14989 return Nkind (N) = N_Variable_Reference_Marker;
14990 end Is_Suitable_Variable_Reference;
14992 -------------------
14993 -- Is_Task_Entry --
14994 -------------------
14996 function Is_Task_Entry (Id : Entity_Id) return Boolean is
14998 -- To qualify, the entity must denote an entry defined in a task type
15001 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id)));
15004 ------------------------
15005 -- Is_Up_Level_Target --
15006 ------------------------
15008 function Is_Up_Level_Target
15009 (Targ_Decl : Node_Id;
15010 In_State : Processing_In_State) return Boolean
15012 Root : constant Node_Id := Root_Scenario;
15013 Root_Rep : constant Scenario_Rep_Id :=
15014 Scenario_Representation_Of (Root, In_State);
15017 -- The root appears within the declaratons of a block statement,
15018 -- entry body, subprogram body, or task body ignoring enclosing
15019 -- packages. The root is always within the main unit.
15021 if not In_State.Suppress_Up_Level_Targets
15022 and then Level (Root_Rep) = Declaration_Level
15024 -- The target is within the main unit. It acts as an up-level
15025 -- target when it appears within a context which encloses the
15028 -- package body Main_Unit is
15029 -- function Func ...; -- target
15031 -- procedure Proc is
15032 -- X : ... := Func; -- root scenario
15034 if In_Extended_Main_Code_Unit (Targ_Decl) then
15035 return not In_Same_Context (Root, Targ_Decl, Nested_OK => True);
15037 -- Otherwise the target is external to the main unit which makes
15038 -- it an up-level target.
15046 end Is_Up_Level_Target;
15049 ---------------------------
15050 -- Set_Elaboration_Phase --
15051 ---------------------------
15053 procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status) is
15055 Elaboration_Phase := Status;
15056 end Set_Elaboration_Phase;
15058 ---------------------
15059 -- SPARK_Processor --
15060 ---------------------
15062 package body SPARK_Processor is
15064 -----------------------
15065 -- Local subprograms --
15066 -----------------------
15068 procedure Process_SPARK_Derived_Type
15069 (Typ_Decl : Node_Id;
15070 Typ_Rep : Scenario_Rep_Id;
15071 In_State : Processing_In_State);
15072 pragma Inline (Process_SPARK_Derived_Type);
15073 -- Verify that the freeze node of a derived type denoted by declaration
15074 -- Typ_Decl is within the early call region of each overriding primitive
15075 -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is
15076 -- the representation of the type. In_State denotes the current state of
15077 -- the Processing phase.
15079 procedure Process_SPARK_Instantiation
15081 Inst_Rep : Scenario_Rep_Id;
15082 In_State : Processing_In_State);
15083 pragma Inline (Process_SPARK_Instantiation);
15084 -- Verify that instanciation Inst does not precede the generic body it
15085 -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the
15086 -- instantiation. In_State is the current state of the Processing phase.
15088 procedure Process_SPARK_Refined_State_Pragma
15090 Prag_Rep : Scenario_Rep_Id;
15091 In_State : Processing_In_State);
15092 pragma Inline (Process_SPARK_Refined_State_Pragma);
15093 -- Verify that each constituent of Refined_State pragma Prag which
15094 -- belongs to abstract state mentioned in pragma Initializes has prior
15095 -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)).
15096 -- Prag_Rep is the representation of the pragma. In_State denotes the
15097 -- current state of the Processing phase.
15099 procedure Process_SPARK_Scenario
15101 In_State : Processing_In_State);
15102 pragma Inline (Process_SPARK_Scenario);
15103 -- Top-level dispatcher for verifying SPARK scenarios which are not
15104 -- always executable during elaboration but still need elaboration-
15105 -- related checks. In_State is the current state of the Processing
15108 ---------------------------------
15109 -- Check_SPARK_Model_In_Effect --
15110 ---------------------------------
15112 SPARK_Model_Warning_Posted : Boolean := False;
15113 -- This flag prevents the same SPARK model-related warning from being
15114 -- emitted multiple times.
15116 procedure Check_SPARK_Model_In_Effect is
15117 Spec_Id : constant Entity_Id := Unique_Entity (Main_Unit_Entity);
15120 -- Do not emit the warning multiple times as this creates useless
15123 if SPARK_Model_Warning_Posted then
15126 -- SPARK rule verification requires the "strict" static model
15128 elsif Static_Elaboration_Checks
15129 and not Relaxed_Elaboration_Checks
15133 -- Any other combination of models does not guarantee the absence of
15134 -- ABE problems for SPARK rule verification purposes. Note that there
15135 -- is no need to check for the presence of the legacy ABE mechanism
15136 -- because the legacy code has its own dedicated processing for SPARK
15140 SPARK_Model_Warning_Posted := True;
15143 ("??SPARK elaboration checks require static elaboration model",
15146 if Dynamic_Elaboration_Checks then
15148 ("\dynamic elaboration model is in effect", Spec_Id);
15151 pragma Assert (Relaxed_Elaboration_Checks);
15153 ("\relaxed elaboration model is in effect", Spec_Id);
15156 end Check_SPARK_Model_In_Effect;
15158 ---------------------------
15159 -- Check_SPARK_Scenarios --
15160 ---------------------------
15162 procedure Check_SPARK_Scenarios is
15163 Iter : NE_Set.Iterator;
15167 Iter := Iterate_SPARK_Scenarios;
15168 while NE_Set.Has_Next (Iter) loop
15169 NE_Set.Next (Iter, N);
15171 Process_SPARK_Scenario
15173 In_State => SPARK_State);
15175 end Check_SPARK_Scenarios;
15177 --------------------------------
15178 -- Process_SPARK_Derived_Type --
15179 --------------------------------
15181 procedure Process_SPARK_Derived_Type
15182 (Typ_Decl : Node_Id;
15183 Typ_Rep : Scenario_Rep_Id;
15184 In_State : Processing_In_State)
15186 pragma Unreferenced (In_State);
15188 Typ : constant Entity_Id := Target (Typ_Rep);
15190 Stop_Check : exception;
15191 -- This exception is raised when the freeze node violates the
15192 -- placement rules.
15194 procedure Check_Overriding_Primitive
15197 pragma Inline (Check_Overriding_Primitive);
15198 -- Verify that freeze node FNode is within the early call region of
15199 -- overriding primitive Prim's body.
15201 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr;
15202 pragma Inline (Freeze_Node_Location);
15203 -- Return a more accurate source location associated with freeze node
15206 function Precedes_Source_Construct (N : Node_Id) return Boolean;
15207 pragma Inline (Precedes_Source_Construct);
15208 -- Determine whether arbitrary node N appears prior to some source
15211 procedure Suggest_Elaborate_Body
15213 Body_Decl : Node_Id;
15214 Error_Nod : Node_Id);
15215 pragma Inline (Suggest_Elaborate_Body);
15216 -- Suggest the use of pragma Elaborate_Body when the pragma will
15217 -- allow for node N to appear within the early call region of
15218 -- subprogram body Body_Decl. The suggestion is attached to
15219 -- Error_Nod as a continuation error.
15221 --------------------------------
15222 -- Check_Overriding_Primitive --
15223 --------------------------------
15225 procedure Check_Overriding_Primitive
15229 Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim);
15230 Body_Decl : Node_Id;
15231 Body_Id : Entity_Id;
15235 -- Nothing to do for predefined primitives because they are
15236 -- artifacts of tagged type expansion and cannot override source
15237 -- primitives. Nothing to do as well for inherited primitives as
15238 -- the check concerns overridding ones.
15240 if Is_Predefined_Dispatching_Operation (Prim)
15241 or else not Is_Overriding_Subprogram (Prim)
15246 Body_Id := Corresponding_Body (Prim_Decl);
15248 -- Nothing to do when the primitive does not have a corresponding
15249 -- body. This can happen when the unit with the bodies is not the
15250 -- main unit subjected to ABE checks.
15252 if No (Body_Id) then
15255 -- The primitive overrides a parent or progenitor primitive
15257 elsif Present (Overridden_Operation (Prim)) then
15259 -- Nothing to do when overriding an interface primitive happens
15260 -- by inheriting a non-interface primitive as the check would
15261 -- be done on the parent primitive.
15263 if Present (Alias (Prim)) then
15267 -- Nothing to do when the primitive is not overriding. The body of
15268 -- such a primitive cannot be targeted by a dispatching call which
15269 -- is executable during elaboration, and cannot cause an ABE.
15275 Body_Decl := Unit_Declaration_Node (Body_Id);
15276 Region := Find_Early_Call_Region (Body_Decl);
15278 -- The freeze node appears prior to the early call region of the
15281 -- IMPORTANT: This check must always be performed even when
15282 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
15283 -- specified because the static model cannot guarantee the absence
15284 -- of ABEs in the presence of dispatching calls.
15286 if Earlier_In_Extended_Unit (FNode, Region) then
15287 Error_Msg_Node_2 := Prim;
15289 ("first freezing point of type & must appear within early "
15290 & "call region of primitive body & (SPARK RM 7.7(8))",
15293 Error_Msg_Sloc := Sloc (Region);
15294 Error_Msg_N ("\region starts #", Typ_Decl);
15296 Error_Msg_Sloc := Sloc (Body_Decl);
15297 Error_Msg_N ("\region ends #", Typ_Decl);
15299 Error_Msg_Sloc := Freeze_Node_Location (FNode);
15300 Error_Msg_N ("\first freezing point #", Typ_Decl);
15302 -- If applicable, suggest the use of pragma Elaborate_Body in
15303 -- the associated package spec.
15305 Suggest_Elaborate_Body
15307 Body_Decl => Body_Decl,
15308 Error_Nod => Typ_Decl);
15312 end Check_Overriding_Primitive;
15314 --------------------------
15315 -- Freeze_Node_Location --
15316 --------------------------
15318 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is
15319 Context : constant Node_Id := Parent (FNode);
15320 Loc : constant Source_Ptr := Sloc (FNode);
15322 Prv_Decls : List_Id;
15323 Vis_Decls : List_Id;
15326 -- In general, the source location of the freeze node is as close
15327 -- as possible to the real freeze point, except when the freeze
15328 -- node is at the "bottom" of a package spec.
15330 if Nkind (Context) = N_Package_Specification then
15331 Prv_Decls := Private_Declarations (Context);
15332 Vis_Decls := Visible_Declarations (Context);
15334 -- The freeze node appears in the private declarations of the
15337 if Present (Prv_Decls)
15338 and then List_Containing (FNode) = Prv_Decls
15342 -- The freeze node appears in the visible declarations of the
15343 -- package and there are no private declarations.
15345 elsif Present (Vis_Decls)
15346 and then List_Containing (FNode) = Vis_Decls
15347 and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls))
15351 -- Otherwise the freeze node is not in the "last" declarative
15352 -- list of the package. Use the existing source location of the
15359 -- The freeze node appears at the "bottom" of the package when
15360 -- it is in the "last" declarative list and is either the last
15361 -- in the list or is followed by internal constructs only. In
15362 -- that case the more appropriate source location is that of
15363 -- the package end label.
15365 if not Precedes_Source_Construct (FNode) then
15366 return Sloc (End_Label (Context));
15371 end Freeze_Node_Location;
15373 -------------------------------
15374 -- Precedes_Source_Construct --
15375 -------------------------------
15377 function Precedes_Source_Construct (N : Node_Id) return Boolean is
15382 while Present (Decl) loop
15383 if Comes_From_Source (Decl) then
15386 -- A generated body for a source expression function is treated
15387 -- as a source construct.
15389 elsif Nkind (Decl) = N_Subprogram_Body
15390 and then Was_Expression_Function (Decl)
15391 and then Comes_From_Source (Original_Node (Decl))
15400 end Precedes_Source_Construct;
15402 ----------------------------
15403 -- Suggest_Elaborate_Body --
15404 ----------------------------
15406 procedure Suggest_Elaborate_Body
15408 Body_Decl : Node_Id;
15409 Error_Nod : Node_Id)
15411 Unit_Id : constant Node_Id := Unit (Cunit (Main_Unit));
15415 -- The suggestion applies only when the subprogram body resides in
15416 -- a compilation package body, and a pragma Elaborate_Body would
15417 -- allow for the node to appear in the early call region of the
15418 -- subprogram body. This implies that all code from the subprogram
15419 -- body up to the node is preelaborable.
15421 if Nkind (Unit_Id) = N_Package_Body then
15423 -- Find the start of the early call region again assuming that
15424 -- the package spec has pragma Elaborate_Body. Note that the
15425 -- internal data structures are intentionally not updated
15426 -- because this is a speculative search.
15429 Find_Early_Call_Region
15430 (Body_Decl => Body_Decl,
15431 Assume_Elab_Body => True,
15432 Skip_Memoization => True);
15434 -- If the node appears within the early call region, assuming
15435 -- that the package spec carries pragma Elaborate_Body, then it
15436 -- is safe to suggest the pragma.
15438 if Earlier_In_Extended_Unit (Region, N) then
15439 Error_Msg_Name_1 := Name_Elaborate_Body;
15441 ("\consider adding pragma % in spec of unit &",
15442 Error_Nod, Defining_Entity (Unit_Id));
15445 end Suggest_Elaborate_Body;
15449 FNode : constant Node_Id := Freeze_Node (Typ);
15450 Prims : constant Elist_Id := Direct_Primitive_Operations (Typ);
15452 Prim_Elmt : Elmt_Id;
15454 -- Start of processing for Process_SPARK_Derived_Type
15457 -- A type should have its freeze node set by the time SPARK scenarios
15458 -- are being verified.
15460 pragma Assert (Present (FNode));
15462 -- Verify that the freeze node of the derived type is within the
15463 -- early call region of each overriding primitive body
15464 -- (SPARK RM 7.7(8)).
15466 if Present (Prims) then
15467 Prim_Elmt := First_Elmt (Prims);
15468 while Present (Prim_Elmt) loop
15469 Check_Overriding_Primitive
15470 (Prim => Node (Prim_Elmt),
15473 Next_Elmt (Prim_Elmt);
15480 end Process_SPARK_Derived_Type;
15482 ---------------------------------
15483 -- Process_SPARK_Instantiation --
15484 ---------------------------------
15486 procedure Process_SPARK_Instantiation
15488 Inst_Rep : Scenario_Rep_Id;
15489 In_State : Processing_In_State)
15491 Gen_Id : constant Entity_Id := Target (Inst_Rep);
15492 Gen_Rep : constant Target_Rep_Id :=
15493 Target_Representation_Of (Gen_Id, In_State);
15494 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep);
15497 -- The instantiation and the generic body are both in the main unit
15499 if Present (Body_Decl)
15500 and then In_Extended_Main_Code_Unit (Body_Decl)
15502 -- If the instantiation appears prior to the generic body, then the
15503 -- instantiation is illegal (SPARK RM 7.7(6)).
15505 -- IMPORTANT: This check must always be performed even when
15506 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
15507 -- specified because the rule prevents use-before-declaration of
15508 -- objects that may precede the generic body.
15510 and then Earlier_In_Extended_Unit (Inst, Body_Decl)
15513 ("cannot instantiate & before body seen", Inst, Gen_Id);
15515 end Process_SPARK_Instantiation;
15517 ----------------------------
15518 -- Process_SPARK_Scenario --
15519 ----------------------------
15521 procedure Process_SPARK_Scenario
15523 In_State : Processing_In_State)
15525 Scen : constant Node_Id := Scenario (N);
15528 -- Ensure that a suitable elaboration model is in effect for SPARK
15529 -- rule verification.
15531 Check_SPARK_Model_In_Effect;
15533 -- Add the current scenario to the stack of active scenarios
15535 Push_Active_Scenario (Scen);
15539 if Is_Suitable_SPARK_Derived_Type (Scen) then
15540 Process_SPARK_Derived_Type
15542 Typ_Rep => Scenario_Representation_Of (Scen, In_State),
15543 In_State => In_State);
15547 elsif Is_Suitable_SPARK_Instantiation (Scen) then
15548 Process_SPARK_Instantiation
15550 Inst_Rep => Scenario_Representation_Of (Scen, In_State),
15551 In_State => In_State);
15553 -- Refined_State pragma
15555 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then
15556 Process_SPARK_Refined_State_Pragma
15558 Prag_Rep => Scenario_Representation_Of (Scen, In_State),
15559 In_State => In_State);
15562 -- Remove the current scenario from the stack of active scenarios
15563 -- once all ABE diagnostics and checks have been performed.
15565 Pop_Active_Scenario (Scen);
15566 end Process_SPARK_Scenario;
15568 ----------------------------------------
15569 -- Process_SPARK_Refined_State_Pragma --
15570 ----------------------------------------
15572 procedure Process_SPARK_Refined_State_Pragma
15574 Prag_Rep : Scenario_Rep_Id;
15575 In_State : Processing_In_State)
15577 pragma Unreferenced (Prag_Rep);
15579 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id);
15580 pragma Inline (Check_SPARK_Constituent);
15581 -- Ensure that a single constituent Constit_Id is elaborated prior to
15584 procedure Check_SPARK_Constituents (Constits : Elist_Id);
15585 pragma Inline (Check_SPARK_Constituents);
15586 -- Ensure that all constituents found in list Constits are elaborated
15587 -- prior to the main unit.
15589 procedure Check_SPARK_Initialized_State (State : Node_Id);
15590 pragma Inline (Check_SPARK_Initialized_State);
15591 -- Ensure that the constituents of single abstract state State are
15592 -- elaborated prior to the main unit.
15594 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id);
15595 pragma Inline (Check_SPARK_Initialized_States);
15596 -- Ensure that the constituents of all abstract states which appear
15597 -- in the Initializes pragma of package Pack_Id are elaborated prior
15598 -- to the main unit.
15600 -----------------------------
15601 -- Check_SPARK_Constituent --
15602 -----------------------------
15604 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is
15608 -- Nothing to do for "null" constituents
15610 if Nkind (Constit_Id) = N_Null then
15613 -- Nothing to do for illegal constituents
15615 elsif Error_Posted (Constit_Id) then
15619 SM_Prag := SPARK_Pragma (Constit_Id);
15621 -- The check applies only when the constituent is subject to
15622 -- pragma SPARK_Mode On.
15624 if Present (SM_Prag)
15625 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On
15627 -- An external constituent of an abstract state which appears
15628 -- in the Initializes pragma of a package spec imposes an
15629 -- Elaborate requirement on the context of the main unit.
15630 -- Determine whether the context has a pragma strong enough to
15631 -- meet the requirement.
15633 -- IMPORTANT: This check is performed only when -gnatd.v
15634 -- (enforce SPARK elaboration rules in SPARK code) is in effect
15635 -- because the static model can ensure the prior elaboration of
15636 -- the unit which contains a constituent by installing implicit
15637 -- Elaborate pragma.
15639 if Debug_Flag_Dot_V then
15640 Meet_Elaboration_Requirement
15642 Targ_Id => Constit_Id,
15643 Req_Nam => Name_Elaborate,
15644 In_State => In_State);
15646 -- Otherwise ensure that the unit with the external constituent
15647 -- is elaborated prior to the main unit.
15650 Ensure_Prior_Elaboration
15652 Unit_Id => Find_Top_Unit (Constit_Id),
15653 Prag_Nam => Name_Elaborate,
15654 In_State => In_State);
15657 end Check_SPARK_Constituent;
15659 ------------------------------
15660 -- Check_SPARK_Constituents --
15661 ------------------------------
15663 procedure Check_SPARK_Constituents (Constits : Elist_Id) is
15664 Constit_Elmt : Elmt_Id;
15667 if Present (Constits) then
15668 Constit_Elmt := First_Elmt (Constits);
15669 while Present (Constit_Elmt) loop
15670 Check_SPARK_Constituent (Node (Constit_Elmt));
15671 Next_Elmt (Constit_Elmt);
15674 end Check_SPARK_Constituents;
15676 -----------------------------------
15677 -- Check_SPARK_Initialized_State --
15678 -----------------------------------
15680 procedure Check_SPARK_Initialized_State (State : Node_Id) is
15682 State_Id : Entity_Id;
15685 -- Nothing to do for "null" initialization items
15687 if Nkind (State) = N_Null then
15690 -- Nothing to do for illegal states
15692 elsif Error_Posted (State) then
15696 State_Id := Entity_Of (State);
15698 -- Sanitize the state
15700 if No (State_Id) then
15703 elsif Error_Posted (State_Id) then
15706 elsif Ekind (State_Id) /= E_Abstract_State then
15710 -- The check is performed only when the abstract state is subject
15711 -- to SPARK_Mode On.
15713 SM_Prag := SPARK_Pragma (State_Id);
15715 if Present (SM_Prag)
15716 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On
15718 Check_SPARK_Constituents (Refinement_Constituents (State_Id));
15720 end Check_SPARK_Initialized_State;
15722 ------------------------------------
15723 -- Check_SPARK_Initialized_States --
15724 ------------------------------------
15726 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is
15727 Init_Prag : constant Node_Id :=
15728 Get_Pragma (Pack_Id, Pragma_Initializes);
15734 if Present (Init_Prag) then
15735 Inits := Expression (Get_Argument (Init_Prag, Pack_Id));
15737 -- Avoid processing a "null" initialization list. The only
15738 -- other alternative is an aggregate.
15740 if Nkind (Inits) = N_Aggregate then
15742 -- The initialization items appear in list form:
15744 -- (state1, state2)
15746 if Present (Expressions (Inits)) then
15747 Init := First (Expressions (Inits));
15748 while Present (Init) loop
15749 Check_SPARK_Initialized_State (Init);
15754 -- The initialization items appear in associated form:
15756 -- (state1 => item1,
15757 -- state2 => (item2, item3))
15759 if Present (Component_Associations (Inits)) then
15760 Init := First (Component_Associations (Inits));
15761 while Present (Init) loop
15762 Check_SPARK_Initialized_State (Init);
15768 end Check_SPARK_Initialized_States;
15772 Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (Prag);
15774 -- Start of processing for Process_SPARK_Refined_State_Pragma
15777 -- Pragma Refined_State must be associated with a package body
15780 (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body);
15782 -- Verify that each external contitunent of an abstract state
15783 -- mentioned in pragma Initializes is properly elaborated.
15785 Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body));
15786 end Process_SPARK_Refined_State_Pragma;
15787 end SPARK_Processor;
15789 -------------------------------
15790 -- Spec_And_Body_From_Entity --
15791 -------------------------------
15793 procedure Spec_And_Body_From_Entity
15795 Spec_Decl : out Node_Id;
15796 Body_Decl : out Node_Id)
15799 Spec_And_Body_From_Node
15800 (N => Unit_Declaration_Node (Id),
15801 Spec_Decl => Spec_Decl,
15802 Body_Decl => Body_Decl);
15803 end Spec_And_Body_From_Entity;
15805 -----------------------------
15806 -- Spec_And_Body_From_Node --
15807 -----------------------------
15809 procedure Spec_And_Body_From_Node
15811 Spec_Decl : out Node_Id;
15812 Body_Decl : out Node_Id)
15814 Body_Id : Entity_Id;
15815 Spec_Id : Entity_Id;
15818 -- Assume that the construct lacks spec and body
15820 Body_Decl := Empty;
15821 Spec_Decl := Empty;
15825 if Nkind_In (N, N_Package_Body,
15830 Spec_Id := Corresponding_Spec (N);
15832 -- The body completes a previous declaration
15834 if Present (Spec_Id) then
15835 Spec_Decl := Unit_Declaration_Node (Spec_Id);
15837 -- Otherwise the body acts as the initial declaration, and is both a
15838 -- spec and body. There is no need to look for an optional body.
15848 elsif Nkind_In (N, N_Entry_Declaration,
15849 N_Generic_Package_Declaration,
15850 N_Generic_Subprogram_Declaration,
15851 N_Package_Declaration,
15852 N_Protected_Type_Declaration,
15853 N_Subprogram_Declaration,
15854 N_Task_Type_Declaration)
15858 -- Expression function
15860 elsif Nkind (N) = N_Expression_Function then
15861 Spec_Id := Corresponding_Spec (N);
15862 pragma Assert (Present (Spec_Id));
15864 Spec_Decl := Unit_Declaration_Node (Spec_Id);
15868 elsif Nkind (N) in N_Generic_Instantiation then
15869 Spec_Decl := Instance_Spec (N);
15870 pragma Assert (Present (Spec_Decl));
15874 elsif Nkind (N) in N_Body_Stub then
15875 Spec_Id := Corresponding_Spec_Of_Stub (N);
15877 -- The stub completes a previous declaration
15879 if Present (Spec_Id) then
15880 Spec_Decl := Unit_Declaration_Node (Spec_Id);
15882 -- Otherwise the stub acts as a spec
15889 -- Obtain an optional or mandatory body
15891 if Present (Spec_Decl) then
15892 Body_Id := Corresponding_Body (Spec_Decl);
15894 if Present (Body_Id) then
15895 Body_Decl := Unit_Declaration_Node (Body_Id);
15898 end Spec_And_Body_From_Node;
15900 -------------------------------
15901 -- Static_Elaboration_Checks --
15902 -------------------------------
15904 function Static_Elaboration_Checks return Boolean is
15906 return not Dynamic_Elaboration_Checks;
15907 end Static_Elaboration_Checks;
15913 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is
15914 function Is_Subunit (Id : Entity_Id) return Boolean;
15915 pragma Inline (Is_Subunit);
15916 -- Determine whether the entity of an initial declaration denotes a
15923 function Is_Subunit (Id : Entity_Id) return Boolean is
15924 Decl : constant Node_Id := Unit_Declaration_Node (Id);
15928 Nkind_In (Decl, N_Generic_Package_Declaration,
15929 N_Generic_Subprogram_Declaration,
15930 N_Package_Declaration,
15931 N_Protected_Type_Declaration,
15932 N_Subprogram_Declaration,
15933 N_Task_Type_Declaration)
15934 and then Present (Corresponding_Body (Decl))
15935 and then Nkind (Parent (Unit_Declaration_Node
15936 (Corresponding_Body (Decl)))) = N_Subunit;
15943 -- Start of processing for Unit_Entity
15946 Id := Unique_Entity (Unit_Id);
15948 -- Skip all subunits found in the scope chain which ends at the input
15951 while Is_Subunit (Id) loop
15958 ---------------------------------
15959 -- Update_Elaboration_Scenario --
15960 ---------------------------------
15962 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is
15964 -- Nothing to do when the elaboration phase of the compiler is not
15967 if not Elaboration_Phase_Active then
15970 -- Nothing to do when the old and new scenarios are one and the same
15972 elsif Old_N = New_N then
15976 -- A scenario is being transformed by Atree.Rewrite. Update all relevant
15977 -- internal data structures to reflect this change. This ensures that a
15978 -- potential run-time conditional ABE check or a guaranteed ABE failure
15979 -- is inserted at the proper place in the tree.
15981 if Is_Scenario (Old_N) then
15982 Replace_Scenario (Old_N, New_N);
15984 end Update_Elaboration_Scenario;
15986 ---------------------------------------------------------------------------
15988 -- 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 --
15990 -- M E C H A N I S M --
15992 ---------------------------------------------------------------------------
15994 -- This section contains the implementation of the pre-18.x legacy ABE
15995 -- mechanism. The mechanism can be activated using switch -gnatH (legacy
15996 -- elaboration checking mode enabled).
15998 -----------------------------
15999 -- Description of Approach --
16000 -----------------------------
16002 -- Every non-static call that is encountered by Sem_Res results in a call
16003 -- to Check_Elab_Call, with N being the call node, and Outer set to its
16004 -- default value of True. In addition X'Access is treated like a call
16005 -- for the access-to-procedure case, and in SPARK mode only we also
16006 -- check variable references.
16008 -- The goal of Check_Elab_Call is to determine whether or not the reference
16009 -- in question can generate an access before elaboration error (raising
16010 -- Program_Error) either by directly calling a subprogram whose body
16011 -- has not yet been elaborated, or indirectly, by calling a subprogram
16012 -- whose body has been elaborated, but which contains a call to such a
16015 -- In addition, in SPARK mode, we are checking for a variable reference in
16016 -- another package, which requires an explicit Elaborate_All pragma.
16018 -- The only references that we need to look at the outer level are
16019 -- references that occur in elaboration code. There are two cases. The
16020 -- reference can be at the outer level of elaboration code, or it can
16021 -- be within another unit, e.g. the elaboration code of a subprogram.
16023 -- In the case of an elaboration call at the outer level, we must trace
16024 -- all calls to outer level routines either within the current unit or to
16025 -- other units that are with'ed. For calls within the current unit, we can
16026 -- determine if the body has been elaborated or not, and if it has not,
16027 -- then a warning is generated.
16029 -- Note that there are two subcases. If the original call directly calls a
16030 -- subprogram whose body has not been elaborated, then we know that an ABE
16031 -- will take place, and we replace the call by a raise of Program_Error.
16032 -- If the call is indirect, then we don't know that the PE will be raised,
16033 -- since the call might be guarded by a conditional. In this case we set
16034 -- Do_Elab_Check on the call so that a dynamic check is generated, and
16035 -- output a warning.
16037 -- For calls to a subprogram in a with'ed unit or a 'Access or variable
16038 -- reference (SPARK mode case), we require that a pragma Elaborate_All
16039 -- or pragma Elaborate be present, or that the referenced unit have a
16040 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
16041 -- of these conditions is met, then a warning is generated that a pragma
16042 -- Elaborate_All may be needed (error in the SPARK case), or an implicit
16043 -- pragma is generated.
16045 -- For the case of an elaboration call at some inner level, we are
16046 -- interested in tracing only calls to subprograms at the same level, i.e.
16047 -- those that can be called during elaboration. Any calls to outer level
16048 -- routines cannot cause ABE's as a result of the original call (there
16049 -- might be an outer level call to the subprogram from outside that causes
16050 -- the ABE, but that gets analyzed separately).
16052 -- Note that we never trace calls to inner level subprograms, since these
16053 -- cannot result in ABE's unless there is an elaboration problem at a lower
16054 -- level, which will be separately detected.
16056 -- Note on pragma Elaborate. The checking here assumes that a pragma
16057 -- Elaborate on a with'ed unit guarantees that subprograms within the unit
16058 -- can be called without causing an ABE. This is not in fact the case since
16059 -- pragma Elaborate does not guarantee the transitive coverage guaranteed
16060 -- by Elaborate_All. However, we decide to trust the user in this case.
16062 --------------------------------------
16063 -- Instantiation Elaboration Errors --
16064 --------------------------------------
16066 -- A special case arises when an instantiation appears in a context that is
16067 -- known to be before the body is elaborated, e.g.
16069 -- generic package x is ...
16071 -- package xx is new x;
16073 -- package body x is ...
16075 -- In this situation it is certain that an elaboration error will occur,
16076 -- and an unconditional raise Program_Error statement is inserted before
16077 -- the instantiation, and a warning generated.
16079 -- The problem is that in this case we have no place to put the body of
16080 -- the instantiation. We can't put it in the normal place, because it is
16081 -- too early, and will cause errors to occur as a result of referencing
16082 -- entities before they are declared.
16084 -- Our approach in this case is simply to avoid creating the body of the
16085 -- instantiation in such a case. The instantiation spec is modified to
16086 -- include dummy bodies for all subprograms, so that the resulting code
16087 -- does not contain subprogram specs with no corresponding bodies.
16089 -- The following table records the recursive call chain for output in the
16090 -- Output routine. Each entry records the call node and the entity of the
16091 -- called routine. The number of entries in the table (i.e. the value of
16092 -- Elab_Call.Last) indicates the current depth of recursion and is used to
16093 -- identify the outer level.
16095 type Elab_Call_Element is record
16100 package Elab_Call is new Table.Table
16101 (Table_Component_Type => Elab_Call_Element,
16102 Table_Index_Type => Int,
16103 Table_Low_Bound => 1,
16104 Table_Initial => 50,
16105 Table_Increment => 100,
16106 Table_Name => "Elab_Call");
16108 -- The following table records all calls that have been processed starting
16109 -- from an outer level call. The table prevents both infinite recursion and
16110 -- useless reanalysis of calls within the same context. The use of context
16111 -- is important because it allows for proper checks in more complex code:
16114 -- Call; -- requires a check
16115 -- Call; -- does not need a check thanks to the table
16117 -- Call; -- requires a check, different context
16120 -- Call; -- requires a check, different context
16122 type Visited_Element is record
16123 Subp_Id : Entity_Id;
16124 -- The entity of the subprogram being called
16127 -- The context where the call to the subprogram occurs
16130 package Elab_Visited is new Table.Table
16131 (Table_Component_Type => Visited_Element,
16132 Table_Index_Type => Int,
16133 Table_Low_Bound => 1,
16134 Table_Initial => 200,
16135 Table_Increment => 100,
16136 Table_Name => "Elab_Visited");
16138 -- The following table records delayed calls which must be examined after
16139 -- all generic bodies have been instantiated.
16141 type Delay_Element is record
16143 -- The parameter N from the call to Check_Internal_Call. Note that this
16144 -- node may get rewritten over the delay period by expansion in the call
16145 -- case (but not in the instantiation case).
16148 -- The parameter E from the call to Check_Internal_Call
16150 Orig_Ent : Entity_Id;
16151 -- The parameter Orig_Ent from the call to Check_Internal_Call
16153 Curscop : Entity_Id;
16154 -- The current scope of the call. This is restored when we complete the
16155 -- delayed call, so that we do this in the right scope.
16157 Outer_Scope : Entity_Id;
16158 -- Save scope of outer level call
16160 From_Elab_Code : Boolean;
16161 -- Save indication of whether this call is from elaboration code
16163 In_Task_Activation : Boolean;
16164 -- Save indication of whether this call is from a task body. Tasks are
16165 -- activated at the "begin", which is after all local procedure bodies,
16166 -- so calls to those procedures can't fail, even if they occur after the
16169 From_SPARK_Code : Boolean;
16170 -- Save indication of whether this call is under SPARK_Mode => On
16173 package Delay_Check is new Table.Table
16174 (Table_Component_Type => Delay_Element,
16175 Table_Index_Type => Int,
16176 Table_Low_Bound => 1,
16177 Table_Initial => 1000,
16178 Table_Increment => 100,
16179 Table_Name => "Delay_Check");
16181 C_Scope : Entity_Id;
16182 -- Top-level scope of current scope. Compute this only once at the outer
16183 -- level, i.e. for a call to Check_Elab_Call from outside this unit.
16185 Outer_Level_Sloc : Source_Ptr;
16186 -- Save Sloc value for outer level call node for comparisons of source
16187 -- locations. A body is too late if it appears after the *outer* level
16188 -- call, not the particular call that is being analyzed.
16190 From_Elab_Code : Boolean;
16191 -- This flag shows whether the outer level call currently being examined
16192 -- is or is not in elaboration code. We are only interested in calls to
16193 -- routines in other units if this flag is True.
16195 In_Task_Activation : Boolean := False;
16196 -- This flag indicates whether we are performing elaboration checks on task
16197 -- bodies, at the point of activation. If true, we do not raise
16198 -- Program_Error for calls to local procedures, because all local bodies
16199 -- are known to be elaborated. However, we still need to trace such calls,
16200 -- because a local procedure could call a procedure in another package,
16201 -- so we might need an implicit Elaborate_All.
16203 Delaying_Elab_Checks : Boolean := True;
16204 -- This is set True till the compilation is complete, including the
16205 -- insertion of all instance bodies. Then when Check_Elab_Calls is called,
16206 -- the delay table is used to make the delayed calls and this flag is reset
16207 -- to False, so that the calls are processed.
16209 -----------------------
16210 -- Local Subprograms --
16211 -----------------------
16213 -- Note: Outer_Scope in all following specs represents the scope of
16214 -- interest of the outer level call. If it is set to Standard_Standard,
16215 -- then it means the outer level call was at elaboration level, and that
16216 -- thus all calls are of interest. If it was set to some other scope,
16217 -- then the original call was an inner call, and we are not interested
16218 -- in calls that go outside this scope.
16220 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id);
16221 -- Analysis of construct N shows that we should set Elaborate_All_Desirable
16222 -- for the WITH clause for unit U (which will always be present). A special
16223 -- case is when N is a function or procedure instantiation, in which case
16224 -- it is sufficient to set Elaborate_Desirable, since in this case there is
16225 -- no possibility of transitive elaboration issues.
16227 procedure Check_A_Call
16230 Outer_Scope : Entity_Id;
16231 Inter_Unit_Only : Boolean;
16232 Generate_Warnings : Boolean := True;
16233 In_Init_Proc : Boolean := False);
16234 -- This is the internal recursive routine that is called to check for
16235 -- possible elaboration error. The argument N is a subprogram call or
16236 -- generic instantiation, or 'Access attribute reference to be checked, and
16237 -- E is the entity of the called subprogram, or instantiated generic unit,
16238 -- or subprogram referenced by 'Access.
16240 -- In SPARK mode, N can also be a variable reference, since in SPARK this
16241 -- also triggers a requirement for Elaborate_All, and in this case E is the
16242 -- entity being referenced.
16244 -- Outer_Scope is the outer level scope for the original reference.
16245 -- Inter_Unit_Only is set if the call is only to be checked in the
16246 -- case where it is to another unit (and skipped if within a unit).
16247 -- Generate_Warnings is set to False to suppress warning messages about
16248 -- missing pragma Elaborate_All's. These messages are not wanted for
16249 -- inner calls in the dynamic model. Note that an instance of the Access
16250 -- attribute applied to a subprogram also generates a call to this
16251 -- procedure (since the referenced subprogram may be called later
16252 -- indirectly). Flag In_Init_Proc should be set whenever the current
16253 -- context is a type init proc.
16255 -- Note: this might better be called Check_A_Reference to recognize the
16256 -- variable case for SPARK, but we prefer to retain the historical name
16257 -- since in practice this is mostly about checking calls for the possible
16258 -- occurrence of an access-before-elaboration exception.
16260 procedure Check_Bad_Instantiation (N : Node_Id);
16261 -- N is a node for an instantiation (if called with any other node kind,
16262 -- Check_Bad_Instantiation ignores the call). This subprogram checks for
16263 -- the special case of a generic instantiation of a generic spec in the
16264 -- same declarative part as the instantiation where a body is present and
16265 -- has not yet been seen. This is an obvious error, but needs to be checked
16266 -- specially at the time of the instantiation, since it is a case where we
16267 -- cannot insert the body anywhere. If this case is detected, warnings are
16268 -- generated, and a raise of Program_Error is inserted. In addition any
16269 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation
16270 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this
16271 -- flag as an indication that no attempt should be made to insert an
16274 procedure Check_Internal_Call
16277 Outer_Scope : Entity_Id;
16278 Orig_Ent : Entity_Id);
16279 -- N is a function call or procedure statement call node and E is the
16280 -- entity of the called function, which is within the current compilation
16281 -- unit (where subunits count as part of the parent). This call checks if
16282 -- this call, or any call within any accessed body could cause an ABE, and
16283 -- if so, outputs a warning. Orig_Ent differs from E only in the case of
16284 -- renamings, and points to the original name of the entity. This is used
16285 -- for error messages. Outer_Scope is the outer level scope for the
16288 procedure Check_Internal_Call_Continue
16291 Outer_Scope : Entity_Id;
16292 Orig_Ent : Entity_Id);
16293 -- The processing for Check_Internal_Call is divided up into two phases,
16294 -- and this represents the second phase. The second phase is delayed if
16295 -- Delaying_Elab_Checks is set to True. In this delayed case, the first
16296 -- phase makes an entry in the Delay_Check table, which is processed when
16297 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
16298 -- Check_Internal_Call. Outer_Scope is the outer level scope for the
16301 function Get_Referenced_Ent (N : Node_Id) return Entity_Id;
16302 -- N is either a function or procedure call or an access attribute that
16303 -- references a subprogram. This call retrieves the relevant entity. If
16304 -- this is a call to a protected subprogram, the entity is a selected
16305 -- component. The callable entity may be absent, in which case Empty is
16306 -- returned. This happens with non-analyzed calls in nested generics.
16308 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable
16309 -- entity, in which case, the value returned is simply this entity.
16311 function Has_Generic_Body (N : Node_Id) return Boolean;
16312 -- N is a generic package instantiation node, and this routine determines
16313 -- if this package spec does in fact have a generic body. If so, then
16314 -- True is returned, otherwise False. Note that this is not at all the
16315 -- same as checking if the unit requires a body, since it deals with
16316 -- the case of optional bodies accurately (i.e. if a body is optional,
16317 -- then it looks to see if a body is actually present). Note: this
16318 -- function can only do a fully correct job if in generating code mode
16319 -- where all bodies have to be present. If we are operating in semantics
16320 -- check only mode, then in some cases of optional bodies, a result of
16321 -- False may incorrectly be given. In practice this simply means that
16322 -- some cases of warnings for incorrect order of elaboration will only
16323 -- be given when generating code, which is not a big problem (and is
16324 -- inevitable, given the optional body semantics of Ada).
16326 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty);
16327 -- Given code for an elaboration check (or unconditional raise if the check
16328 -- is not needed), inserts the code in the appropriate place. N is the call
16329 -- or instantiation node for which the check code is required. C is the
16330 -- test whose failure triggers the raise.
16332 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean;
16333 -- Returns True if node N is a call to a generic formal subprogram
16335 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean;
16336 -- Determine whether entity Id denotes a [Deep_]Finalize procedure
16338 procedure Output_Calls
16340 Check_Elab_Flag : Boolean);
16341 -- Outputs chain of calls stored in the Elab_Call table. The caller has
16342 -- already generated the main warning message, so the warnings generated
16343 -- are all continuation messages. The argument is the call node at which
16344 -- the messages are to be placed. When Check_Elab_Flag is set, calls are
16345 -- enumerated only when flag Elab_Warning is set for the dynamic case or
16346 -- when flag Elab_Info_Messages is set for the static case.
16348 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
16349 -- Given two scopes, determine whether they are the same scope from an
16350 -- elaboration point of view, i.e. packages and blocks are ignored.
16352 procedure Set_C_Scope;
16353 -- On entry C_Scope is set to some scope. On return, C_Scope is reset
16354 -- to be the enclosing compilation unit of this scope.
16356 procedure Set_Elaboration_Constraint
16360 -- The current unit U may depend semantically on some unit P that is not
16361 -- in the current context. If there is an elaboration call that reaches P,
16362 -- we need to indicate that P requires an Elaborate_All, but this is not
16363 -- effective in U's ali file, if there is no with_clause for P. In this
16364 -- case we add the Elaborate_All on the unit Q that directly or indirectly
16365 -- makes P available. This can happen in two cases:
16367 -- a) Q declares a subtype of a type declared in P, and the call is an
16368 -- initialization call for an object of that subtype.
16370 -- b) Q declares an object of some tagged type whose root type is
16371 -- declared in P, and the initialization call uses object notation on
16372 -- that object to reach a primitive operation or a classwide operation
16375 -- If P appears in the context of U, the current processing is correct.
16376 -- Otherwise we must identify these two cases to retrieve Q and place the
16377 -- Elaborate_All_Desirable on it.
16379 function Spec_Entity (E : Entity_Id) return Entity_Id;
16380 -- Given a compilation unit entity, if it is a spec entity, it is returned
16381 -- unchanged. If it is a body entity, then the spec for the corresponding
16382 -- spec is returned
16384 function Within (E1, E2 : Entity_Id) return Boolean;
16385 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
16386 -- of its contained scopes, False otherwise.
16388 function Within_Elaborate_All
16389 (Unit : Unit_Number_Type;
16390 E : Entity_Id) return Boolean;
16391 -- Return True if we are within the scope of an Elaborate_All for E, or if
16392 -- we are within the scope of an Elaborate_All for some other unit U, and U
16393 -- with's E. This prevents spurious warnings when the called entity is
16394 -- renamed within U, or in case of generic instances.
16396 --------------------------------------
16397 -- Activate_Elaborate_All_Desirable --
16398 --------------------------------------
16400 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is
16401 UN : constant Unit_Number_Type := Get_Code_Unit (N);
16402 CU : constant Node_Id := Cunit (UN);
16403 UE : constant Entity_Id := Cunit_Entity (UN);
16404 Unm : constant Unit_Name_Type := Unit_Name (UN);
16405 CI : constant List_Id := Context_Items (CU);
16409 procedure Add_To_Context_And_Mark (Itm : Node_Id);
16410 -- This procedure is called when the elaborate indication must be
16411 -- applied to a unit not in the context of the referencing unit. The
16412 -- unit gets added to the context as an implicit with.
16414 function In_Withs_Of (UEs : Entity_Id) return Boolean;
16415 -- UEs is the spec entity of a unit. If the unit to be marked is
16416 -- in the context item list of this unit spec, then the call returns
16417 -- True and Itm is left set to point to the relevant N_With_Clause node.
16419 procedure Set_Elab_Flag (Itm : Node_Id);
16420 -- Sets Elaborate_[All_]Desirable as appropriate on Itm
16422 -----------------------------
16423 -- Add_To_Context_And_Mark --
16424 -----------------------------
16426 procedure Add_To_Context_And_Mark (Itm : Node_Id) is
16427 CW : constant Node_Id :=
16428 Make_With_Clause (Sloc (Itm),
16429 Name => Name (Itm));
16432 Set_Library_Unit (CW, Library_Unit (Itm));
16433 Set_Implicit_With (CW);
16435 -- Set elaborate all desirable on copy and then append the copy to
16436 -- the list of body with's and we are done.
16438 Set_Elab_Flag (CW);
16439 Append_To (CI, CW);
16440 end Add_To_Context_And_Mark;
16446 function In_Withs_Of (UEs : Entity_Id) return Boolean is
16447 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs);
16448 CUs : constant Node_Id := Cunit (UNs);
16449 CIs : constant List_Id := Context_Items (CUs);
16452 Itm := First (CIs);
16453 while Present (Itm) loop
16454 if Nkind (Itm) = N_With_Clause then
16456 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
16469 -------------------
16470 -- Set_Elab_Flag --
16471 -------------------
16473 procedure Set_Elab_Flag (Itm : Node_Id) is
16475 if Nkind (N) in N_Subprogram_Instantiation then
16476 Set_Elaborate_Desirable (Itm);
16478 Set_Elaborate_All_Desirable (Itm);
16482 -- Start of processing for Activate_Elaborate_All_Desirable
16485 -- Do not set binder indication if expansion is disabled, as when
16486 -- compiling a generic unit.
16488 if not Expander_Active then
16492 -- If an instance of a generic package contains a controlled object (so
16493 -- we're calling Initialize at elaboration time), and the instance is in
16494 -- a package body P that says "with P;", then we need to return without
16495 -- adding "pragma Elaborate_All (P);" to P.
16497 if U = Main_Unit_Entity then
16502 while Present (Itm) loop
16503 if Nkind (Itm) = N_With_Clause then
16504 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
16506 -- If we find it, then mark elaborate all desirable and return
16509 Set_Elab_Flag (Itm);
16517 -- If we fall through then the with clause is not present in the
16518 -- current unit. One legitimate possibility is that the with clause
16519 -- is present in the spec when we are a body.
16521 if Is_Body_Name (Unm)
16522 and then In_Withs_Of (Spec_Entity (UE))
16524 Add_To_Context_And_Mark (Itm);
16528 -- Similarly, we may be in the spec or body of a child unit, where
16529 -- the unit in question is with'ed by some ancestor of the child unit.
16531 if Is_Child_Name (Unm) then
16538 Pkg := Scope (Pkg);
16539 exit when Pkg = Standard_Standard;
16541 if In_Withs_Of (Pkg) then
16542 Add_To_Context_And_Mark (Itm);
16549 -- Here if we do not find with clause on spec or body. We just ignore
16550 -- this case; it means that the elaboration involves some other unit
16551 -- than the unit being compiled, and will be caught elsewhere.
16552 end Activate_Elaborate_All_Desirable;
16558 procedure Check_A_Call
16561 Outer_Scope : Entity_Id;
16562 Inter_Unit_Only : Boolean;
16563 Generate_Warnings : Boolean := True;
16564 In_Init_Proc : Boolean := False)
16566 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
16567 -- Indicates if we have Access attribute case
16569 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean;
16570 -- True if we're calling an instance of a generic subprogram, or a
16571 -- subprogram in an instance of a generic package, and the call is
16572 -- outside that instance.
16574 procedure Elab_Warning
16577 Ent : Node_Or_Entity_Id);
16578 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
16579 -- dynamic or static elaboration model), N and Ent. Msg_D is a real
16580 -- warning (output if Msg_D is non-null and Elab_Warnings is set),
16581 -- Msg_S is an info message (output if Elab_Info_Messages is set).
16583 function Find_W_Scope return Entity_Id;
16584 -- Find top-level scope for called entity (not following renamings
16585 -- or derivations). This is where the Elaborate_All will go if it is
16586 -- needed. We start with the called entity, except in the case of an
16587 -- initialization procedure outside the current package, where the init
16588 -- proc is in the root package, and we start from the entity of the name
16591 -----------------------------------
16592 -- Call_To_Instance_From_Outside --
16593 -----------------------------------
16595 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is
16596 Scop : Entity_Id := Id;
16600 if Scop = Standard_Standard then
16604 if Is_Generic_Instance (Scop) then
16605 return not In_Open_Scopes (Scop);
16608 Scop := Scope (Scop);
16610 end Call_To_Instance_From_Outside;
16616 procedure Elab_Warning
16619 Ent : Node_Or_Entity_Id)
16622 -- Dynamic elaboration checks, real warning
16624 if Dynamic_Elaboration_Checks then
16625 if not Access_Case then
16626 if Msg_D /= "" and then Elab_Warnings then
16627 Error_Msg_NE (Msg_D, N, Ent);
16630 -- In the access case emit first warning message as well,
16631 -- otherwise list of calls will appear as errors.
16633 elsif Elab_Warnings then
16634 Error_Msg_NE (Msg_S, N, Ent);
16637 -- Static elaboration checks, info message
16640 if Elab_Info_Messages then
16641 Error_Msg_NE (Msg_S, N, Ent);
16650 function Find_W_Scope return Entity_Id is
16651 Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N);
16652 W_Scope : Entity_Id;
16655 if Is_Init_Proc (Refed_Ent)
16656 and then not In_Same_Extended_Unit (N, Refed_Ent)
16658 W_Scope := Scope (Refed_Ent);
16663 -- Now loop through scopes to get to the enclosing compilation unit
16665 while not Is_Compilation_Unit (W_Scope) loop
16666 W_Scope := Scope (W_Scope);
16674 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
16675 -- Indicates if we have instantiation case
16677 Loc : constant Source_Ptr := Sloc (N);
16679 Variable_Case : constant Boolean :=
16680 Nkind (N) in N_Has_Entity
16681 and then Present (Entity (N))
16682 and then Ekind (Entity (N)) = E_Variable;
16683 -- Indicates if we have variable reference case
16685 W_Scope : constant Entity_Id := Find_W_Scope;
16686 -- Top-level scope of directly called entity for subprogram. This
16687 -- differs from E_Scope in the case where renamings or derivations
16688 -- are involved, since it does not follow these links. W_Scope is
16689 -- generally in a visible unit, and it is this scope that may require
16690 -- an Elaborate_All. However, there are some cases (initialization
16691 -- calls and calls involving object notation) where W_Scope might not
16692 -- be in the context of the current unit, and there is an intermediate
16693 -- package that is, in which case the Elaborate_All has to be placed
16694 -- on this intermediate package. These special cases are handled in
16695 -- Set_Elaboration_Constraint.
16698 Callee_Unit_Internal : Boolean;
16699 Caller_Unit_Internal : Boolean;
16701 Inst_Callee : Source_Ptr;
16702 Inst_Caller : Source_Ptr;
16703 Unit_Callee : Unit_Number_Type;
16704 Unit_Caller : Unit_Number_Type;
16706 Body_Acts_As_Spec : Boolean;
16707 -- Set to true if call is to body acting as spec (no separate spec)
16709 Cunit_SC : Boolean := False;
16710 -- Set to suppress dynamic elaboration checks where one of the
16711 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
16712 -- if a pragma Elaborate[_All] applies to that scope, in which case
16713 -- warnings on the scope are also suppressed. For the internal case,
16714 -- we ignore this flag.
16716 E_Scope : Entity_Id;
16717 -- Top-level scope of entity for called subprogram. This value includes
16718 -- following renamings and derivations, so this scope can be in a
16719 -- non-visible unit. This is the scope that is to be investigated to
16720 -- see whether an elaboration check is required.
16723 -- Flag set when the subprogram being invoked is the procedure generated
16724 -- for pragma Default_Initial_Condition.
16726 SPARK_Elab_Errors : Boolean;
16727 -- Flag set when an entity is called or a variable is read during SPARK
16728 -- dynamic elaboration.
16730 -- Start of processing for Check_A_Call
16733 -- If the call is known to be within a local Suppress Elaboration
16734 -- pragma, nothing to check. This can happen in task bodies. But
16735 -- we ignore this for a call to a generic formal.
16737 if Nkind (N) in N_Subprogram_Call
16738 and then No_Elaboration_Check (N)
16739 and then not Is_Call_Of_Generic_Formal (N)
16743 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to
16744 -- check, we don't mind in this case if the call occurs before the body
16745 -- since this is all generated code.
16747 elsif Nkind (Original_Node (N)) = N_Attribute_Reference
16748 and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars
16752 -- Intrinsics such as instances of Unchecked_Deallocation do not have
16753 -- any body, so elaboration checking is not needed, and would be wrong.
16755 elsif Is_Intrinsic_Subprogram (E) then
16758 -- Do not consider references to internal variables for SPARK semantics
16760 elsif Variable_Case and then not Comes_From_Source (E) then
16764 -- Proceed with check
16768 -- For a variable reference, just set Body_Acts_As_Spec to False
16770 if Variable_Case then
16771 Body_Acts_As_Spec := False;
16773 -- Additional checks for all other cases
16776 -- Go to parent for derived subprogram, or to original subprogram in
16777 -- the case of a renaming (Alias covers both these cases).
16780 if (Suppress_Elaboration_Warnings (Ent)
16781 or else Elaboration_Checks_Suppressed (Ent))
16782 and then (Inst_Case or else No (Alias (Ent)))
16787 -- Nothing to do for imported entities
16789 if Is_Imported (Ent) then
16793 exit when Inst_Case or else No (Alias (Ent));
16794 Ent := Alias (Ent);
16797 Decl := Unit_Declaration_Node (Ent);
16799 if Nkind (Decl) = N_Subprogram_Body then
16800 Body_Acts_As_Spec := True;
16802 elsif Nkind_In (Decl, N_Subprogram_Declaration,
16803 N_Subprogram_Body_Stub)
16806 Body_Acts_As_Spec := False;
16808 -- If we have none of an instantiation, subprogram body or subprogram
16809 -- declaration, or in the SPARK case, a variable reference, then
16810 -- it is not a case that we want to check. (One case is a call to a
16811 -- generic formal subprogram, where we do not want the check in the
16821 if Elaboration_Checks_Suppressed (E_Scope)
16822 or else Suppress_Elaboration_Warnings (E_Scope)
16827 -- Exit when we get to compilation unit, not counting subunits
16829 exit when Is_Compilation_Unit (E_Scope)
16830 and then (Is_Child_Unit (E_Scope)
16831 or else Scope (E_Scope) = Standard_Standard);
16833 pragma Assert (E_Scope /= Standard_Standard);
16835 -- Move up a scope looking for compilation unit
16837 E_Scope := Scope (E_Scope);
16840 -- No checks needed for pure or preelaborated compilation units
16842 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then
16846 -- If the generic entity is within a deeper instance than we are, then
16847 -- either the instantiation to which we refer itself caused an ABE, in
16848 -- which case that will be handled separately, or else we know that the
16849 -- body we need appears as needed at the point of the instantiation.
16850 -- However, this assumption is only valid if we are in static mode.
16852 if not Dynamic_Elaboration_Checks
16854 Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N))
16859 -- Do not give a warning for a package with no body
16861 if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then
16865 -- Case of entity is in same unit as call or instantiation. In the
16866 -- instantiation case, W_Scope may be different from E_Scope; we want
16867 -- the unit in which the instantiation occurs, since we're analyzing
16868 -- based on the expansion.
16870 if W_Scope = C_Scope then
16871 if not Inter_Unit_Only then
16872 Check_Internal_Call (N, Ent, Outer_Scope, E);
16878 -- Case of entity is not in current unit (i.e. with'ed unit case)
16880 -- We are only interested in such calls if the outer call was from
16881 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
16883 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then
16887 -- Nothing to do if some scope said that no checks were required
16893 -- Nothing to do for a generic instance, because a call to an instance
16894 -- cannot fail the elaboration check, because the body of the instance
16895 -- is always elaborated immediately after the spec.
16897 if Call_To_Instance_From_Outside (Ent) then
16901 -- Nothing to do if subprogram with no separate spec. However, a call
16902 -- to Deep_Initialize may result in a call to a user-defined Initialize
16903 -- procedure, which imposes a body dependency. This happens only if the
16904 -- type is controlled and the Initialize procedure is not inherited.
16906 if Body_Acts_As_Spec then
16907 if Is_TSS (Ent, TSS_Deep_Initialize) then
16909 Typ : constant Entity_Id := Etype (First_Formal (Ent));
16913 if not Is_Controlled (Typ) then
16916 Init := Find_Prim_Op (Typ, Name_Initialize);
16918 if Comes_From_Source (Init) then
16931 -- Check cases of internal units
16933 Callee_Unit_Internal := In_Internal_Unit (E_Scope);
16935 -- Do not give a warning if the with'ed unit is internal and this is
16936 -- the generic instantiation case (this saves a lot of hassle dealing
16937 -- with the Text_IO special child units)
16939 if Callee_Unit_Internal and Inst_Case then
16943 if C_Scope = Standard_Standard then
16944 Caller_Unit_Internal := False;
16946 Caller_Unit_Internal := In_Internal_Unit (C_Scope);
16949 -- Do not give a warning if the with'ed unit is internal and the caller
16950 -- is not internal (since the binder always elaborates internal units
16953 if Callee_Unit_Internal and not Caller_Unit_Internal then
16957 -- For now, if debug flag -gnatdE is not set, do no checking for one
16958 -- internal unit withing another. This fixes the problem with the sgi
16959 -- build and storage errors. To be resolved later ???
16961 if (Callee_Unit_Internal and Caller_Unit_Internal)
16962 and not Debug_Flag_EE
16967 if Is_TSS (E, TSS_Deep_Initialize) then
16971 -- If the call is in an instance, and the called entity is not
16972 -- defined in the same instance, then the elaboration issue focuses
16973 -- around the unit containing the template, it is this unit that
16974 -- requires an Elaborate_All.
16976 -- However, if we are doing dynamic elaboration, we need to chase the
16977 -- call in the usual manner.
16979 -- We also need to chase the call in the usual manner if it is a call
16980 -- to a generic formal parameter, since that case was not handled as
16981 -- part of the processing of the template.
16983 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N)));
16984 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent)));
16986 if Inst_Caller = No_Location then
16987 Unit_Caller := No_Unit;
16989 Unit_Caller := Get_Source_Unit (N);
16992 if Inst_Callee = No_Location then
16993 Unit_Callee := No_Unit;
16995 Unit_Callee := Get_Source_Unit (Ent);
16998 if Unit_Caller /= No_Unit
16999 and then Unit_Callee /= Unit_Caller
17000 and then not Dynamic_Elaboration_Checks
17001 and then not Is_Call_Of_Generic_Formal (N)
17003 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller));
17005 -- If we don't get a spec entity, just ignore call. Not quite
17006 -- clear why this check is necessary. ???
17008 if No (E_Scope) then
17012 -- Otherwise step to enclosing compilation unit
17014 while not Is_Compilation_Unit (E_Scope) loop
17015 E_Scope := Scope (E_Scope);
17018 -- For the case where N is not an instance, and is not a call within
17019 -- instance to other than a generic formal, we recompute E_Scope
17020 -- for the error message, since we do NOT want to go to the unit
17021 -- that has the ultimate declaration in the case of renaming and
17022 -- derivation and we also want to go to the generic unit in the
17023 -- case of an instance, and no further.
17026 -- Loop to carefully follow renamings and derivations one step
17027 -- outside the current unit, but not further.
17029 if not (Inst_Case or Variable_Case)
17030 and then Present (Alias (Ent))
17032 E_Scope := Alias (Ent);
17038 while not Is_Compilation_Unit (E_Scope) loop
17039 E_Scope := Scope (E_Scope);
17042 -- If E_Scope is the same as C_Scope, it means that there
17043 -- definitely was a local renaming or derivation, and we
17044 -- are not yet out of the current unit.
17046 exit when E_Scope /= C_Scope;
17047 Ent := Alias (Ent);
17050 -- If no alias, there could be a previous error, but not if we've
17051 -- already reached the outermost level (Standard).
17059 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then
17063 -- Determine whether the Default_Initial_Condition procedure of some
17064 -- type is being invoked.
17066 Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent);
17068 -- Checks related to Default_Initial_Condition fall under the SPARK
17069 -- umbrella because this is a SPARK-specific annotation.
17071 SPARK_Elab_Errors :=
17072 SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks);
17074 -- Now check if an Elaborate_All (or dynamic check) is needed
17076 if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors)
17077 and then Generate_Warnings
17078 and then not Suppress_Elaboration_Warnings (Ent)
17079 and then not Elaboration_Checks_Suppressed (Ent)
17080 and then not Suppress_Elaboration_Warnings (E_Scope)
17081 and then not Elaboration_Checks_Suppressed (E_Scope)
17083 -- Instantiation case
17086 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then
17088 ("instantiation of & during elaboration in SPARK", N, Ent);
17091 ("instantiation of & may raise Program_Error?l?",
17092 "info: instantiation of & during elaboration?$?", Ent);
17095 -- Indirect call case, info message only in static elaboration
17096 -- case, because the attribute reference itself cannot raise an
17097 -- exception. Note that SPARK does not permit indirect calls.
17099 elsif Access_Case then
17100 Elab_Warning ("", "info: access to & during elaboration?$?", Ent);
17102 -- Variable reference in SPARK mode
17104 elsif Variable_Case then
17105 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then
17107 ("reference to & during elaboration in SPARK", N, Ent);
17110 -- Subprogram call case
17113 if Nkind (Name (N)) in N_Has_Entity
17114 and then Is_Init_Proc (Entity (Name (N)))
17115 and then Comes_From_Source (Ent)
17118 ("implicit call to & may raise Program_Error?l?",
17119 "info: implicit call to & during elaboration?$?",
17122 elsif SPARK_Elab_Errors then
17124 -- Emit a specialized error message when the elaboration of an
17125 -- object of a private type evaluates the expression of pragma
17126 -- Default_Initial_Condition. This prevents the internal name
17127 -- of the procedure from appearing in the error message.
17131 ("call to Default_Initial_Condition during elaboration in "
17135 ("call to & during elaboration in SPARK", N, Ent);
17140 ("call to & may raise Program_Error?l?",
17141 "info: call to & during elaboration?$?",
17146 Error_Msg_Qual_Level := Nat'Last;
17148 -- Case of Elaborate_All not present and required, for SPARK this
17149 -- is an error, so give an error message.
17151 if SPARK_Elab_Errors then
17152 Error_Msg_NE -- CODEFIX
17153 ("\Elaborate_All pragma required for&", N, W_Scope);
17155 -- Otherwise we generate an implicit pragma. For a subprogram
17156 -- instantiation, Elaborate is good enough, since no transitive
17157 -- call is possible at elaboration time in this case.
17159 elsif Nkind (N) in N_Subprogram_Instantiation then
17161 ("\missing pragma Elaborate for&?l?",
17162 "\implicit pragma Elaborate for& generated?$?",
17165 -- For all other cases, we need an implicit Elaborate_All
17169 ("\missing pragma Elaborate_All for&?l?",
17170 "\implicit pragma Elaborate_All for & generated?$?",
17174 Error_Msg_Qual_Level := 0;
17176 -- Take into account the flags related to elaboration warning
17177 -- messages when enumerating the various calls involved. This
17178 -- ensures the proper pairing of the main warning and the
17179 -- clarification messages generated by Output_Calls.
17181 Output_Calls (N, Check_Elab_Flag => True);
17183 -- Set flag to prevent further warnings for same unit unless in
17184 -- All_Errors_Mode.
17186 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
17187 Set_Suppress_Elaboration_Warnings (W_Scope);
17191 -- Check for runtime elaboration check required
17193 if Dynamic_Elaboration_Checks then
17194 if not Elaboration_Checks_Suppressed (Ent)
17195 and then not Elaboration_Checks_Suppressed (W_Scope)
17196 and then not Elaboration_Checks_Suppressed (E_Scope)
17197 and then not Cunit_SC
17199 -- Runtime elaboration check required. Generate check of the
17200 -- elaboration Boolean for the unit containing the entity.
17202 -- Note that for this case, we do check the real unit (the one
17203 -- from following renamings, since that is the issue).
17205 -- Could this possibly miss a useless but required PE???
17207 Insert_Elab_Check (N,
17208 Make_Attribute_Reference (Loc,
17209 Attribute_Name => Name_Elaborated,
17211 New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
17213 -- Prevent duplicate elaboration checks on the same call, which
17214 -- can happen if the body enclosing the call appears itself in a
17215 -- call whose elaboration check is delayed.
17217 if Nkind (N) in N_Subprogram_Call then
17218 Set_No_Elaboration_Check (N);
17222 -- Case of static elaboration model
17225 -- Do not do anything if elaboration checks suppressed. Note that
17226 -- we check Ent here, not E, since we want the real entity for the
17227 -- body to see if checks are suppressed for it, not the dummy
17228 -- entry for renamings or derivations.
17230 if Elaboration_Checks_Suppressed (Ent)
17231 or else Elaboration_Checks_Suppressed (E_Scope)
17232 or else Elaboration_Checks_Suppressed (W_Scope)
17236 -- Do not generate an Elaborate_All for finalization routines
17237 -- that perform partial clean up as part of initialization.
17239 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then
17242 -- Here we need to generate an implicit elaborate all
17245 -- Generate Elaborate_All warning unless suppressed
17247 if (Elab_Info_Messages and Generate_Warnings and not Inst_Case)
17248 and then not Suppress_Elaboration_Warnings (Ent)
17249 and then not Suppress_Elaboration_Warnings (E_Scope)
17250 and then not Suppress_Elaboration_Warnings (W_Scope)
17252 Error_Msg_Node_2 := W_Scope;
17254 ("info: call to& in elaboration code requires pragma "
17255 & "Elaborate_All on&?$?", N, E);
17258 -- Set indication for binder to generate Elaborate_All
17260 Set_Elaboration_Constraint (N, E, W_Scope);
17265 -----------------------------
17266 -- Check_Bad_Instantiation --
17267 -----------------------------
17269 procedure Check_Bad_Instantiation (N : Node_Id) is
17273 -- Nothing to do if we do not have an instantiation (happens in some
17274 -- error cases, and also in the formal package declaration case)
17276 if Nkind (N) not in N_Generic_Instantiation then
17279 -- Nothing to do if serious errors detected (avoid cascaded errors)
17281 elsif Serious_Errors_Detected /= 0 then
17284 -- Nothing to do if not in full analysis mode
17286 elsif not Full_Analysis then
17289 -- Nothing to do if inside a generic template
17291 elsif Inside_A_Generic then
17294 -- Nothing to do if a library level instantiation
17296 elsif Nkind (Parent (N)) = N_Compilation_Unit then
17299 -- Nothing to do if we are compiling a proper body for semantic
17300 -- purposes only. The generic body may be in another proper body.
17303 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit
17308 Ent := Get_Generic_Entity (N);
17310 -- The case we are interested in is when the generic spec is in the
17311 -- current declarative part
17313 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
17314 or else not In_Same_Extended_Unit (N, Ent)
17319 -- If the generic entity is within a deeper instance than we are, then
17320 -- either the instantiation to which we refer itself caused an ABE, in
17321 -- which case that will be handled separately. Otherwise, we know that
17322 -- the body we need appears as needed at the point of the instantiation.
17323 -- If they are both at the same level but not within the same instance
17324 -- then the body of the generic will be in the earlier instance.
17327 D1 : constant Nat := Instantiation_Depth (Sloc (Ent));
17328 D2 : constant Nat := Instantiation_Depth (Sloc (N));
17335 and then Is_Generic_Instance (Scope (Ent))
17336 and then not In_Open_Scopes (Scope (Ent))
17342 -- Now we can proceed, if the entity being called has a completion,
17343 -- then we are definitely OK, since we have already seen the body.
17345 if Has_Completion (Ent) then
17349 -- If there is no body, then nothing to do
17351 if not Has_Generic_Body (N) then
17355 -- Here we definitely have a bad instantiation
17357 Error_Msg_Warn := SPARK_Mode /= On;
17358 Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent);
17359 Error_Msg_N ("\Program_Error [<<", N);
17361 Insert_Elab_Check (N);
17362 Set_Is_Known_Guaranteed_ABE (N);
17363 end Check_Bad_Instantiation;
17365 ---------------------
17366 -- Check_Elab_Call --
17367 ---------------------
17369 procedure Check_Elab_Call
17371 Outer_Scope : Entity_Id := Empty;
17372 In_Init_Proc : Boolean := False)
17378 pragma Assert (Legacy_Elaboration_Checks);
17380 -- If the reference is not in the main unit, there is nothing to check.
17381 -- Elaboration call from units in the context of the main unit will lead
17382 -- to semantic dependencies when those units are compiled.
17384 if not In_Extended_Main_Code_Unit (N) then
17388 -- For an entry call, check relevant restriction
17390 if Nkind (N) = N_Entry_Call_Statement
17391 and then not In_Subprogram_Or_Concurrent_Unit
17393 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
17395 -- Nothing to do if this is not an expected type of reference (happens
17396 -- in some error conditions, and in some cases where rewriting occurs).
17398 elsif Nkind (N) not in N_Subprogram_Call
17399 and then Nkind (N) /= N_Attribute_Reference
17400 and then (SPARK_Mode /= On
17401 or else Nkind (N) not in N_Has_Entity
17402 or else No (Entity (N))
17403 or else Ekind (Entity (N)) /= E_Variable)
17407 -- Nothing to do if this is a call already rewritten for elab checking.
17408 -- Such calls appear as the targets of If_Expressions.
17410 -- This check MUST be wrong, it catches far too much
17412 elsif Nkind (Parent (N)) = N_If_Expression then
17415 -- Nothing to do if inside a generic template
17417 elsif Inside_A_Generic
17418 and then No (Enclosing_Generic_Body (N))
17422 -- Nothing to do if call is being preanalyzed, as when within a
17423 -- pre/postcondition, a predicate, or an invariant.
17425 elsif In_Spec_Expression then
17429 -- Nothing to do if this is a call to a postcondition, which is always
17430 -- within a subprogram body, even though the current scope may be the
17431 -- enclosing scope of the subprogram.
17433 if Nkind (N) = N_Procedure_Call_Statement
17434 and then Is_Entity_Name (Name (N))
17435 and then Chars (Entity (Name (N))) = Name_uPostconditions
17440 -- Here we have a reference at elaboration time that must be checked
17442 if Debug_Flag_Underscore_LL then
17443 Write_Str (" Check_Elab_Ref: ");
17445 if Nkind (N) = N_Attribute_Reference then
17446 if not Is_Entity_Name (Prefix (N)) then
17447 Write_Str ("<<not entity name>>");
17449 Write_Name (Chars (Entity (Prefix (N))));
17452 Write_Str ("'Access");
17454 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then
17455 Write_Str ("<<not entity name>> ");
17458 Write_Name (Chars (Entity (Name (N))));
17461 Write_Str (" reference at ");
17462 Write_Location (Sloc (N));
17466 -- Climb up the tree to make sure we are not inside default expression
17467 -- of a parameter specification or a record component, since in both
17468 -- these cases, we will be doing the actual reference later, not now,
17469 -- and it is at the time of the actual reference (statically speaking)
17470 -- that we must do our static check, not at the time of its initial
17473 -- However, we have to check references within component definitions
17474 -- (e.g. a function call that determines an array component bound),
17475 -- so we terminate the loop in that case.
17478 while Present (P) loop
17479 if Nkind_In (P, N_Parameter_Specification,
17480 N_Component_Declaration)
17484 -- The reference occurs within the constraint of a component,
17485 -- so it must be checked.
17487 elsif Nkind (P) = N_Component_Definition then
17495 -- Stuff that happens only at the outer level
17497 if No (Outer_Scope) then
17498 Elab_Visited.Set_Last (0);
17500 -- Nothing to do if current scope is Standard (this is a bit odd, but
17501 -- it happens in the case of generic instantiations).
17503 C_Scope := Current_Scope;
17505 if C_Scope = Standard_Standard then
17509 -- First case, we are in elaboration code
17511 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
17513 if From_Elab_Code then
17515 -- Complain if ref that comes from source in preelaborated unit
17516 -- and we are not inside a subprogram (i.e. we are in elab code).
17518 if Comes_From_Source (N)
17519 and then In_Preelaborated_Unit
17520 and then not In_Inlined_Body
17521 and then Nkind (N) /= N_Attribute_Reference
17523 -- This is a warning in GNAT mode allowing such calls to be
17524 -- used in the predefined library with appropriate care.
17526 Error_Msg_Warn := GNAT_Mode;
17528 ("<<non-static call not allowed in preelaborated unit", N);
17532 -- Second case, we are inside a subprogram or concurrent unit, which
17533 -- means we are not in elaboration code.
17536 -- In this case, the issue is whether we are inside the
17537 -- declarative part of the unit in which we live, or inside its
17538 -- statements. In the latter case, there is no issue of ABE calls
17539 -- at this level (a call from outside to the unit in which we live
17540 -- might cause an ABE, but that will be detected when we analyze
17541 -- that outer level call, as it recurses into the called unit).
17543 -- Climb up the tree, doing this test, and also testing for being
17544 -- inside a default expression, which, as discussed above, is not
17545 -- checked at this stage.
17554 -- If we find a parentless subtree, it seems safe to assume
17555 -- that we are not in a declarative part and that no
17556 -- checking is required.
17562 if Is_List_Member (P) then
17563 L := List_Containing (P);
17570 exit when Nkind (P) = N_Subunit;
17572 -- Filter out case of default expressions, where we do not
17573 -- do the check at this stage.
17575 if Nkind_In (P, N_Parameter_Specification,
17576 N_Component_Declaration)
17581 -- A protected body has no elaboration code and contains
17582 -- only other bodies.
17584 if Nkind (P) = N_Protected_Body then
17587 elsif Nkind_In (P, N_Subprogram_Body,
17592 if L = Declarations (P) then
17595 -- We are not in elaboration code, but we are doing
17596 -- dynamic elaboration checks, in this case, we still
17597 -- need to do the reference, since the subprogram we are
17598 -- in could be called from another unit, also in dynamic
17599 -- elaboration check mode, at elaboration time.
17601 elsif Dynamic_Elaboration_Checks then
17603 -- We provide a debug flag to disable this check. That
17604 -- way we have an easy work around for regressions
17605 -- that are caused by this new check. This debug flag
17606 -- can be removed later.
17608 if Debug_Flag_DD then
17612 -- Do the check in this case
17616 elsif Nkind (P) = N_Task_Body then
17618 -- The check is deferred until Check_Task_Activation
17619 -- but we need to capture local suppress pragmas
17620 -- that may inhibit checks on this call.
17622 Ent := Get_Referenced_Ent (N);
17627 elsif Elaboration_Checks_Suppressed (Current_Scope)
17628 or else Elaboration_Checks_Suppressed (Ent)
17629 or else Elaboration_Checks_Suppressed (Scope (Ent))
17631 if Nkind (N) in N_Subprogram_Call then
17632 Set_No_Elaboration_Check (N);
17638 -- Static model, call is not in elaboration code, we
17639 -- never need to worry, because in the static model the
17640 -- top-level caller always takes care of things.
17651 Ent := Get_Referenced_Ent (N);
17657 -- Determine whether a prior call to the same subprogram was already
17658 -- examined within the same context. If this is the case, then there is
17659 -- no need to proceed with the various warnings and checks because the
17660 -- work was already done for the previous call.
17663 Self : constant Visited_Element :=
17664 (Subp_Id => Ent, Context => Parent (N));
17667 for Index in 1 .. Elab_Visited.Last loop
17668 if Self = Elab_Visited.Table (Index) then
17674 -- See if we need to analyze this reference. We analyze it if either of
17675 -- the following conditions is met:
17677 -- It is an inner level call (since in this case it was triggered
17678 -- by an outer level call from elaboration code), but only if the
17679 -- call is within the scope of the original outer level call.
17681 -- It is an outer level reference from elaboration code, or a call to
17682 -- an entity is in the same elaboration scope.
17684 -- And in these cases, we will check both inter-unit calls and
17685 -- intra-unit (within a single unit) calls.
17687 C_Scope := Current_Scope;
17689 -- If not outer level reference, then we follow it if it is within the
17690 -- original scope of the outer reference.
17692 if Present (Outer_Scope)
17693 and then Within (Scope (Ent), Outer_Scope)
17699 Outer_Scope => Outer_Scope,
17700 Inter_Unit_Only => False,
17701 In_Init_Proc => In_Init_Proc);
17703 -- Nothing to do if elaboration checks suppressed for this scope.
17704 -- However, an interesting exception, the fact that elaboration checks
17705 -- are suppressed within an instance (because we can trace the body when
17706 -- we process the template) does not extend to calls to generic formal
17709 elsif Elaboration_Checks_Suppressed (Current_Scope)
17710 and then not Is_Call_Of_Generic_Formal (N)
17714 elsif From_Elab_Code then
17716 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
17718 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
17720 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
17722 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
17723 -- is set, then we will do the check, but only in the inter-unit case
17724 -- (this is to accommodate unguarded elaboration calls from other units
17725 -- in which this same mode is set). We don't want warnings in this case,
17726 -- it would generate warnings having nothing to do with elaboration.
17728 elsif Dynamic_Elaboration_Checks then
17734 Inter_Unit_Only => True,
17735 Generate_Warnings => False);
17737 -- Otherwise nothing to do
17743 -- A call to an Init_Proc in elaboration code may bring additional
17744 -- dependencies, if some of the record components thereof have
17745 -- initializations that are function calls that come from source. We
17746 -- treat the current node as a call to each of these functions, to check
17747 -- their elaboration impact.
17749 if Is_Init_Proc (Ent) and then From_Elab_Code then
17750 Process_Init_Proc : declare
17751 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
17753 function Check_Init_Call (Nod : Node_Id) return Traverse_Result;
17754 -- Find subprogram calls within body of Init_Proc for Traverse
17755 -- instantiation below.
17757 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call);
17758 -- Traversal procedure to find all calls with body of Init_Proc
17760 ---------------------
17761 -- Check_Init_Call --
17762 ---------------------
17764 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is
17768 if Nkind (Nod) in N_Subprogram_Call
17769 and then Is_Entity_Name (Name (Nod))
17771 Func := Entity (Name (Nod));
17773 if Comes_From_Source (Func) then
17775 (N, Func, Standard_Standard, Inter_Unit_Only => True);
17783 end Check_Init_Call;
17785 -- Start of processing for Process_Init_Proc
17788 if Nkind (Unit_Decl) = N_Subprogram_Body then
17789 Traverse_Body (Handled_Statement_Sequence (Unit_Decl));
17791 end Process_Init_Proc;
17793 end Check_Elab_Call;
17795 -----------------------
17796 -- Check_Elab_Assign --
17797 -----------------------
17799 procedure Check_Elab_Assign (N : Node_Id) is
17803 Pkg_Spec : Entity_Id;
17804 Pkg_Body : Entity_Id;
17807 pragma Assert (Legacy_Elaboration_Checks);
17809 -- For record or array component, check prefix. If it is an access type,
17810 -- then there is nothing to do (we do not know what is being assigned),
17811 -- but otherwise this is an assignment to the prefix.
17813 if Nkind_In (N, N_Indexed_Component,
17814 N_Selected_Component,
17817 if not Is_Access_Type (Etype (Prefix (N))) then
17818 Check_Elab_Assign (Prefix (N));
17824 -- For type conversion, check expression
17826 if Nkind (N) = N_Type_Conversion then
17827 Check_Elab_Assign (Expression (N));
17831 -- Nothing to do if this is not an entity reference otherwise get entity
17833 if Is_Entity_Name (N) then
17839 -- What we are looking for is a reference in the body of a package that
17840 -- modifies a variable declared in the visible part of the package spec.
17843 and then Comes_From_Source (N)
17844 and then not Suppress_Elaboration_Warnings (Ent)
17845 and then Ekind (Ent) = E_Variable
17846 and then not In_Private_Part (Ent)
17847 and then Is_Library_Level_Entity (Ent)
17849 Scop := Current_Scope;
17851 if No (Scop) or else Scop = Standard_Standard then
17853 elsif Ekind (Scop) = E_Package
17854 and then Is_Compilation_Unit (Scop)
17858 Scop := Scope (Scop);
17862 -- Here Scop points to the containing library package
17865 Pkg_Body := Body_Entity (Pkg_Spec);
17867 -- All OK if the package has an Elaborate_Body pragma
17869 if Has_Pragma_Elaborate_Body (Scop) then
17873 -- OK if entity being modified is not in containing package spec
17875 if not In_Same_Source_Unit (Scop, Ent) then
17879 -- All OK if entity appears in generic package or generic instance.
17880 -- We just get too messed up trying to give proper warnings in the
17881 -- presence of generics. Better no message than a junk one.
17883 Scop := Scope (Ent);
17884 while Present (Scop) and then Scop /= Pkg_Spec loop
17885 if Ekind (Scop) = E_Generic_Package then
17887 elsif Ekind (Scop) = E_Package
17888 and then Is_Generic_Instance (Scop)
17893 Scop := Scope (Scop);
17896 -- All OK if in task, don't issue warnings there
17898 if In_Task_Activation then
17902 -- OK if no package body
17904 if No (Pkg_Body) then
17908 -- OK if reference is not in package body
17910 if not In_Same_Source_Unit (Pkg_Body, N) then
17914 -- OK if package body has no handled statement sequence
17917 HSS : constant Node_Id :=
17918 Handled_Statement_Sequence (Declaration_Node (Pkg_Body));
17920 if No (HSS) or else not Comes_From_Source (HSS) then
17925 -- We definitely have a case of a modification of an entity in
17926 -- the package spec from the elaboration code of the package body.
17927 -- We may not give the warning (because there are some additional
17928 -- checks to avoid too many false positives), but it would be a good
17929 -- idea for the binder to try to keep the body elaboration close to
17930 -- the spec elaboration.
17932 Set_Elaborate_Body_Desirable (Pkg_Spec);
17934 -- All OK in gnat mode (we know what we are doing)
17940 -- All OK if all warnings suppressed
17942 if Warning_Mode = Suppress then
17946 -- All OK if elaboration checks suppressed for entity
17948 if Checks_May_Be_Suppressed (Ent)
17949 and then Is_Check_Suppressed (Ent, Elaboration_Check)
17954 -- OK if the entity is initialized. Note that the No_Initialization
17955 -- flag usually means that the initialization has been rewritten into
17956 -- assignments, but that still counts for us.
17959 Decl : constant Node_Id := Declaration_Node (Ent);
17961 if Nkind (Decl) = N_Object_Declaration
17962 and then (Present (Expression (Decl))
17963 or else No_Initialization (Decl))
17969 -- Here is where we give the warning
17971 -- All OK if warnings suppressed on the entity
17973 if not Has_Warnings_Off (Ent) then
17974 Error_Msg_Sloc := Sloc (Ent);
17977 ("??& can be accessed by clients before this initialization",
17980 ("\??add Elaborate_Body to spec to ensure & is initialized",
17984 if not All_Errors_Mode then
17985 Set_Suppress_Elaboration_Warnings (Ent);
17988 end Check_Elab_Assign;
17990 ----------------------
17991 -- Check_Elab_Calls --
17992 ----------------------
17994 -- WARNING: This routine manages SPARK regions
17996 procedure Check_Elab_Calls is
17997 Saved_SM : SPARK_Mode_Type;
17998 Saved_SMP : Node_Id;
18001 pragma Assert (Legacy_Elaboration_Checks);
18003 -- If expansion is disabled, do not generate any checks, unless we
18004 -- are in GNATprove mode, so that errors are issued in GNATprove for
18005 -- violations of static elaboration rules in SPARK code. Also skip
18006 -- checks if any subunits are missing because in either case we lack the
18007 -- full information that we need, and no object file will be created in
18010 if (not Expander_Active and not GNATprove_Mode)
18011 or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
18012 or else Subunits_Missing
18017 -- Skip delayed calls if we had any errors
18019 if Serious_Errors_Detected = 0 then
18020 Delaying_Elab_Checks := False;
18021 Expander_Mode_Save_And_Set (True);
18023 for J in Delay_Check.First .. Delay_Check.Last loop
18024 Push_Scope (Delay_Check.Table (J).Curscop);
18025 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
18026 In_Task_Activation := Delay_Check.Table (J).In_Task_Activation;
18028 Saved_SM := SPARK_Mode;
18029 Saved_SMP := SPARK_Mode_Pragma;
18031 -- Set appropriate value of SPARK_Mode
18033 if Delay_Check.Table (J).From_SPARK_Code then
18037 Check_Internal_Call_Continue
18038 (N => Delay_Check.Table (J).N,
18039 E => Delay_Check.Table (J).E,
18040 Outer_Scope => Delay_Check.Table (J).Outer_Scope,
18041 Orig_Ent => Delay_Check.Table (J).Orig_Ent);
18043 Restore_SPARK_Mode (Saved_SM, Saved_SMP);
18047 -- Set Delaying_Elab_Checks back on for next main compilation
18049 Expander_Mode_Restore;
18050 Delaying_Elab_Checks := True;
18052 end Check_Elab_Calls;
18054 ------------------------------
18055 -- Check_Elab_Instantiation --
18056 ------------------------------
18058 procedure Check_Elab_Instantiation
18060 Outer_Scope : Entity_Id := Empty)
18065 pragma Assert (Legacy_Elaboration_Checks);
18067 -- Check for and deal with bad instantiation case. There is some
18068 -- duplicated code here, but we will worry about this later ???
18070 Check_Bad_Instantiation (N);
18072 if Is_Known_Guaranteed_ABE (N) then
18076 -- Nothing to do if we do not have an instantiation (happens in some
18077 -- error cases, and also in the formal package declaration case)
18079 if Nkind (N) not in N_Generic_Instantiation then
18083 -- Nothing to do if inside a generic template
18085 if Inside_A_Generic then
18089 -- Nothing to do if the instantiation is not in the main unit
18091 if not In_Extended_Main_Code_Unit (N) then
18095 Ent := Get_Generic_Entity (N);
18096 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
18098 -- See if we need to analyze this instantiation. We analyze it if
18099 -- either of the following conditions is met:
18101 -- It is an inner level instantiation (since in this case it was
18102 -- triggered by an outer level call from elaboration code), but
18103 -- only if the instantiation is within the scope of the original
18104 -- outer level call.
18106 -- It is an outer level instantiation from elaboration code, or the
18107 -- instantiated entity is in the same elaboration scope.
18109 -- And in these cases, we will check both the inter-unit case and
18110 -- the intra-unit (within a single unit) case.
18112 C_Scope := Current_Scope;
18114 if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then
18116 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
18118 elsif From_Elab_Code then
18120 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
18122 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
18124 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
18126 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is
18127 -- set, then we will do the check, but only in the inter-unit case (this
18128 -- is to accommodate unguarded elaboration calls from other units in
18129 -- which this same mode is set). We inhibit warnings in this case, since
18130 -- this instantiation is not occurring in elaboration code.
18132 elsif Dynamic_Elaboration_Checks then
18138 Inter_Unit_Only => True,
18139 Generate_Warnings => False);
18144 end Check_Elab_Instantiation;
18146 -------------------------
18147 -- Check_Internal_Call --
18148 -------------------------
18150 procedure Check_Internal_Call
18153 Outer_Scope : Entity_Id;
18154 Orig_Ent : Entity_Id)
18156 function Within_Initial_Condition (Call : Node_Id) return Boolean;
18157 -- Determine whether call Call occurs within pragma Initial_Condition or
18158 -- pragma Check with check_kind set to Initial_Condition.
18160 ------------------------------
18161 -- Within_Initial_Condition --
18162 ------------------------------
18164 function Within_Initial_Condition (Call : Node_Id) return Boolean is
18170 -- Traverse the parent chain looking for an enclosing pragma
18173 while Present (Par) loop
18174 if Nkind (Par) = N_Pragma then
18175 Nam := Pragma_Name (Par);
18177 -- Pragma Initial_Condition appears in its alternative from as
18178 -- Check (Initial_Condition, ...).
18180 if Nam = Name_Check then
18181 Args := Pragma_Argument_Associations (Par);
18183 -- Pragma Check should have at least two arguments
18185 pragma Assert (Present (Args));
18188 Chars (Expression (First (Args))) = Name_Initial_Condition;
18192 elsif Nam = Name_Initial_Condition then
18195 -- Since pragmas are never nested within other pragmas, stop
18202 -- Prevent the search from going too far
18204 elsif Is_Body_Or_Package_Declaration (Par) then
18208 Par := Parent (Par);
18210 -- If assertions are not enabled, the check pragma is rewritten
18211 -- as an if_statement in sem_prag, to generate various warnings
18212 -- on boolean expressions. Retrieve the original pragma.
18214 if Nkind (Original_Node (Par)) = N_Pragma then
18215 Par := Original_Node (Par);
18220 end Within_Initial_Condition;
18224 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
18226 -- Start of processing for Check_Internal_Call
18229 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the
18230 -- node comes from source.
18232 if Nkind (N) = N_Attribute_Reference
18233 and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O)
18234 or else not Comes_From_Source (N))
18238 -- If not function or procedure call, instantiation, or 'Access, then
18239 -- ignore call (this happens in some error cases and rewriting cases).
18241 elsif not Nkind_In (N, N_Attribute_Reference,
18243 N_Procedure_Call_Statement)
18244 and then not Inst_Case
18248 -- Nothing to do if this is a call or instantiation that has already
18249 -- been found to be a sure ABE.
18251 elsif Nkind (N) /= N_Attribute_Reference
18252 and then Is_Known_Guaranteed_ABE (N)
18256 -- Nothing to do if errors already detected (avoid cascaded errors)
18258 elsif Serious_Errors_Detected /= 0 then
18261 -- Nothing to do if not in full analysis mode
18263 elsif not Full_Analysis then
18266 -- Nothing to do if analyzing in special spec-expression mode, since the
18267 -- call is not actually being made at this time.
18269 elsif In_Spec_Expression then
18272 -- Nothing to do for call to intrinsic subprogram
18274 elsif Is_Intrinsic_Subprogram (E) then
18277 -- Nothing to do if call is within a generic unit
18279 elsif Inside_A_Generic then
18282 -- Nothing to do when the call appears within pragma Initial_Condition.
18283 -- The pragma is part of the elaboration statements of a package body
18284 -- and may only call external subprograms or subprograms whose body is
18285 -- already available.
18287 elsif Within_Initial_Condition (N) then
18291 -- Delay this call if we are still delaying calls
18293 if Delaying_Elab_Checks then
18297 Orig_Ent => Orig_Ent,
18298 Curscop => Current_Scope,
18299 Outer_Scope => Outer_Scope,
18300 From_Elab_Code => From_Elab_Code,
18301 In_Task_Activation => In_Task_Activation,
18302 From_SPARK_Code => SPARK_Mode = On));
18305 -- Otherwise, call phase 2 continuation right now
18308 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
18310 end Check_Internal_Call;
18312 ----------------------------------
18313 -- Check_Internal_Call_Continue --
18314 ----------------------------------
18316 procedure Check_Internal_Call_Continue
18319 Outer_Scope : Entity_Id;
18320 Orig_Ent : Entity_Id)
18322 function Find_Elab_Reference (N : Node_Id) return Traverse_Result;
18323 -- Function applied to each node as we traverse the body. Checks for
18324 -- call or entity reference that needs checking, and if so checks it.
18325 -- Always returns OK, so entire tree is traversed, except that as
18326 -- described below subprogram bodies are skipped for now.
18328 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference);
18329 -- Traverse procedure using above Find_Elab_Reference function
18331 -------------------------
18332 -- Find_Elab_Reference --
18333 -------------------------
18335 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is
18339 -- If user has specified that there are no entry calls in elaboration
18340 -- code, do not trace past an accept statement, because the rendez-
18341 -- vous will happen after elaboration.
18343 if Nkind_In (Original_Node (N), N_Accept_Statement,
18344 N_Selective_Accept)
18345 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
18349 -- If we have a function call, check it
18351 elsif Nkind (N) = N_Function_Call then
18352 Check_Elab_Call (N, Outer_Scope);
18355 -- If we have a procedure call, check the call, and also check
18356 -- arguments that are assignments (OUT or IN OUT mode formals).
18358 elsif Nkind (N) = N_Procedure_Call_Statement then
18359 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E));
18361 Actual := First_Actual (N);
18362 while Present (Actual) loop
18363 if Known_To_Be_Assigned (Actual) then
18364 Check_Elab_Assign (Actual);
18367 Next_Actual (Actual);
18372 -- If we have an access attribute for a subprogram, check it.
18373 -- Suppress this behavior under debug flag.
18375 elsif not Debug_Flag_Dot_UU
18376 and then Nkind (N) = N_Attribute_Reference
18377 and then Nam_In (Attribute_Name (N), Name_Access,
18378 Name_Unrestricted_Access)
18379 and then Is_Entity_Name (Prefix (N))
18380 and then Is_Subprogram (Entity (Prefix (N)))
18382 Check_Elab_Call (N, Outer_Scope);
18385 -- In SPARK mode, if we have an entity reference to a variable, then
18386 -- check it. For now we consider any reference.
18388 elsif SPARK_Mode = On
18389 and then Nkind (N) in N_Has_Entity
18390 and then Present (Entity (N))
18391 and then Ekind (Entity (N)) = E_Variable
18393 Check_Elab_Call (N, Outer_Scope);
18396 -- If we have a generic instantiation, check it
18398 elsif Nkind (N) in N_Generic_Instantiation then
18399 Check_Elab_Instantiation (N, Outer_Scope);
18402 -- Skip subprogram bodies that come from source (wait for call to
18403 -- analyze these). The reason for the come from source test is to
18404 -- avoid catching task bodies.
18406 -- For task bodies, we should really avoid these too, waiting for the
18407 -- task activation, but that's too much trouble to catch for now, so
18408 -- we go in unconditionally. This is not so terrible, it means the
18409 -- error backtrace is not quite complete, and we are too eager to
18410 -- scan bodies of tasks that are unused, but this is hardly very
18413 elsif Nkind (N) = N_Subprogram_Body
18414 and then Comes_From_Source (N)
18418 elsif Nkind (N) = N_Assignment_Statement
18419 and then Comes_From_Source (N)
18421 Check_Elab_Assign (Name (N));
18427 end Find_Elab_Reference;
18429 Inst_Case : constant Boolean := Is_Generic_Unit (E);
18430 Loc : constant Source_Ptr := Sloc (N);
18435 -- Start of processing for Check_Internal_Call_Continue
18438 -- Save outer level call if at outer level
18440 if Elab_Call.Last = 0 then
18441 Outer_Level_Sloc := Loc;
18444 -- If the call is to a function that renames a literal, no check needed
18446 if Ekind (E) = E_Enumeration_Literal then
18450 -- Register the subprogram as examined within this particular context.
18451 -- This ensures that calls to the same subprogram but in different
18452 -- contexts receive warnings and checks of their own since the calls
18453 -- may be reached through different flow paths.
18455 Elab_Visited.Append ((Subp_Id => E, Context => Parent (N)));
18457 Sbody := Unit_Declaration_Node (E);
18459 if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then
18460 Ebody := Corresponding_Body (Sbody);
18465 Sbody := Unit_Declaration_Node (Ebody);
18469 -- If the body appears after the outer level call or instantiation then
18470 -- we have an error case handled below.
18472 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
18473 and then not In_Task_Activation
18477 -- If we have the instantiation case we are done, since we now know that
18478 -- the body of the generic appeared earlier.
18480 elsif Inst_Case then
18483 -- Otherwise we have a call, so we trace through the called body to see
18484 -- if it has any problems.
18487 pragma Assert (Nkind (Sbody) = N_Subprogram_Body);
18489 Elab_Call.Append ((Cloc => Loc, Ent => E));
18491 if Debug_Flag_Underscore_LL then
18492 Write_Str ("Elab_Call.Last = ");
18493 Write_Int (Int (Elab_Call.Last));
18494 Write_Str (" Ent = ");
18495 Write_Name (Chars (E));
18496 Write_Str (" at ");
18497 Write_Location (Sloc (N));
18501 -- Now traverse declarations and statements of subprogram body. Note
18502 -- that we cannot simply Traverse (Sbody), since traverse does not
18503 -- normally visit subprogram bodies.
18508 Decl := First (Declarations (Sbody));
18509 while Present (Decl) loop
18515 Traverse (Handled_Statement_Sequence (Sbody));
18517 Elab_Call.Decrement_Last;
18521 -- Here is the case of calling a subprogram where the body has not yet
18522 -- been encountered. A warning message is needed, except if this is the
18523 -- case of appearing within an aspect specification that results in
18524 -- a check call, we do not really have such a situation, so no warning
18525 -- is needed (e.g. the case of a precondition, where the call appears
18526 -- textually before the body, but in actual fact is moved to the
18527 -- appropriate subprogram body and so does not need a check).
18536 -- Keep looking at parents if we are still in the subexpression
18538 if Nkind (P) in N_Subexpr then
18541 -- Here P is the parent of the expression, check for special case
18544 O := Original_Node (P);
18546 -- Definitely not the special case if orig node is not a pragma
18548 exit when Nkind (O) /= N_Pragma;
18550 -- Check we have an If statement or a null statement (happens
18551 -- when the If has been expanded to be True).
18553 exit when not Nkind_In (P, N_If_Statement, N_Null_Statement);
18555 -- Our special case will be indicated either by the pragma
18556 -- coming from an aspect ...
18558 if Present (Corresponding_Aspect (O)) then
18561 -- Or, in the case of an initial condition, specifically by a
18562 -- Check pragma specifying an Initial_Condition check.
18564 elsif Pragma_Name (O) = Name_Check
18567 (Expression (First (Pragma_Argument_Associations (O)))) =
18568 Name_Initial_Condition
18572 -- For anything else, we have an error
18581 -- Not that special case, warning and dynamic check is required
18583 -- If we have nothing in the call stack, then this is at the outer
18584 -- level, and the ABE is bound to occur, unless it's a 'Access, or
18585 -- it's a renaming.
18587 if Elab_Call.Last = 0 then
18588 Error_Msg_Warn := SPARK_Mode /= On;
18591 Insert_Check : Boolean := True;
18592 -- This flag is set to True if an elaboration check should be
18596 if In_Task_Activation then
18597 Insert_Check := False;
18599 elsif Inst_Case then
18601 ("cannot instantiate& before body seen<<", N, Orig_Ent);
18603 elsif Nkind (N) = N_Attribute_Reference then
18605 ("Access attribute of & before body seen<<", N, Orig_Ent);
18606 Error_Msg_N ("\possible Program_Error on later references<", N);
18607 Insert_Check := False;
18609 elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /=
18610 N_Subprogram_Renaming_Declaration
18613 ("cannot call& before body seen<<", N, Orig_Ent);
18615 elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then
18616 Insert_Check := False;
18619 if Insert_Check then
18620 Error_Msg_N ("\Program_Error [<<", N);
18621 Insert_Elab_Check (N);
18625 -- Call is not at outer level
18628 -- Do not generate elaboration checks in GNATprove mode because the
18629 -- elaboration counter and the check are both forms of expansion.
18631 if GNATprove_Mode then
18634 -- Generate an elaboration check
18636 elsif not Elaboration_Checks_Suppressed (E) then
18637 Set_Elaboration_Entity_Required (E);
18639 -- Create a declaration of the elaboration entity, and insert it
18640 -- prior to the subprogram or the generic unit, within the same
18641 -- scope. Since the subprogram may be overloaded, create a unique
18644 if No (Elaboration_Entity (E)) then
18646 Loce : constant Source_Ptr := Sloc (E);
18647 Ent : constant Entity_Id :=
18648 Make_Defining_Identifier (Loc,
18649 New_External_Name (Chars (E), 'E', -1));
18652 Set_Elaboration_Entity (E, Ent);
18653 Push_Scope (Scope (E));
18655 Insert_Action (Declaration_Node (E),
18656 Make_Object_Declaration (Loce,
18657 Defining_Identifier => Ent,
18658 Object_Definition =>
18659 New_Occurrence_Of (Standard_Short_Integer, Loce),
18661 Make_Integer_Literal (Loc, Uint_0)));
18663 -- Set elaboration flag at the point of the body
18665 Set_Elaboration_Flag (Sbody, E);
18667 -- Kill current value indication. This is necessary because
18668 -- the tests of this flag are inserted out of sequence and
18669 -- must not pick up bogus indications of the wrong constant
18670 -- value. Also, this is never a true constant, since one way
18671 -- or another, it gets reset.
18673 Set_Current_Value (Ent, Empty);
18674 Set_Last_Assignment (Ent, Empty);
18675 Set_Is_True_Constant (Ent, False);
18682 -- raise Program_Error with "access before elaboration";
18685 Insert_Elab_Check (N,
18686 Make_Attribute_Reference (Loc,
18687 Attribute_Name => Name_Elaborated,
18688 Prefix => New_Occurrence_Of (E, Loc)));
18691 -- Generate the warning
18693 if not Suppress_Elaboration_Warnings (E)
18694 and then not Elaboration_Checks_Suppressed (E)
18696 -- Suppress this warning if we have a function call that occurred
18697 -- within an assertion expression, since we can get false warnings
18698 -- in this case, due to the out of order handling in this case.
18701 (Nkind (Original_Node (N)) /= N_Function_Call
18702 or else not In_Assertion_Expression_Pragma (Original_Node (N)))
18704 Error_Msg_Warn := SPARK_Mode /= On;
18708 ("instantiation of& may occur before body is seen<l<",
18711 -- A rather specific check. For Finalize/Adjust/Initialize, if
18712 -- the type has Warnings_Off set, suppress the warning.
18714 if Nam_In (Chars (E), Name_Adjust,
18717 and then Present (First_Formal (E))
18720 T : constant Entity_Id := Etype (First_Formal (E));
18722 if Is_Controlled (T) then
18723 if Warnings_Off (T)
18724 or else (Ekind (T) = E_Private_Type
18725 and then Warnings_Off (Full_View (T)))
18733 -- Go ahead and give warning if not this special case
18736 ("call to& may occur before body is seen<l<", N, Orig_Ent);
18739 Error_Msg_N ("\Program_Error ]<l<", N);
18741 -- There is no need to query the elaboration warning message flags
18742 -- because the main message is an error, not a warning, therefore
18743 -- all the clarification messages produces by Output_Calls must be
18744 -- emitted unconditionally.
18748 Output_Calls (N, Check_Elab_Flag => False);
18751 end Check_Internal_Call_Continue;
18753 ---------------------------
18754 -- Check_Task_Activation --
18755 ---------------------------
18757 procedure Check_Task_Activation (N : Node_Id) is
18758 Loc : constant Source_Ptr := Sloc (N);
18759 Inter_Procs : constant Elist_Id := New_Elmt_List;
18760 Intra_Procs : constant Elist_Id := New_Elmt_List;
18763 Task_Scope : Entity_Id;
18764 Cunit_SC : Boolean := False;
18767 Enclosing : Entity_Id;
18769 procedure Add_Task_Proc (Typ : Entity_Id);
18770 -- Add to Task_Procs the task body procedure(s) of task types in Typ.
18771 -- For record types, this procedure recurses over component types.
18773 procedure Collect_Tasks (Decls : List_Id);
18774 -- Collect the types of the tasks that are to be activated in the given
18775 -- list of declarations, in order to perform elaboration checks on the
18776 -- corresponding task procedures that are called implicitly here.
18778 function Outer_Unit (E : Entity_Id) return Entity_Id;
18779 -- find enclosing compilation unit of Entity, ignoring subunits, or
18780 -- else enclosing subprogram. If E is not a package, there is no need
18781 -- for inter-unit elaboration checks.
18783 -------------------
18784 -- Add_Task_Proc --
18785 -------------------
18787 procedure Add_Task_Proc (Typ : Entity_Id) is
18789 Proc : Entity_Id := Empty;
18792 if Is_Task_Type (Typ) then
18793 Proc := Get_Task_Body_Procedure (Typ);
18795 elsif Is_Array_Type (Typ)
18796 and then Has_Task (Base_Type (Typ))
18798 Add_Task_Proc (Component_Type (Typ));
18800 elsif Is_Record_Type (Typ)
18801 and then Has_Task (Base_Type (Typ))
18803 Comp := First_Component (Typ);
18804 while Present (Comp) loop
18805 Add_Task_Proc (Etype (Comp));
18806 Comp := Next_Component (Comp);
18810 -- If the task type is another unit, we will perform the usual
18811 -- elaboration check on its enclosing unit. If the type is in the
18812 -- same unit, we can trace the task body as for an internal call,
18813 -- but we only need to examine other external calls, because at
18814 -- the point the task is activated, internal subprogram bodies
18815 -- will have been elaborated already. We keep separate lists for
18816 -- each kind of task.
18818 -- Skip this test if errors have occurred, since in this case
18819 -- we can get false indications.
18821 if Serious_Errors_Detected /= 0 then
18825 if Present (Proc) then
18826 if Outer_Unit (Scope (Proc)) = Enclosing then
18828 if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
18830 (not Is_Generic_Instance (Scope (Proc))
18831 or else Scope (Proc) = Scope (Defining_Identifier (Decl)))
18833 Error_Msg_Warn := SPARK_Mode /= On;
18835 ("task will be activated before elaboration of its body<<",
18837 Error_Msg_N ("\Program_Error [<<", Decl);
18840 (Corresponding_Body (Unit_Declaration_Node (Proc)))
18842 Append_Elmt (Proc, Intra_Procs);
18846 -- No need for multiple entries of the same type
18848 Elmt := First_Elmt (Inter_Procs);
18849 while Present (Elmt) loop
18850 if Node (Elmt) = Proc then
18857 Append_Elmt (Proc, Inter_Procs);
18862 -------------------
18863 -- Collect_Tasks --
18864 -------------------
18866 procedure Collect_Tasks (Decls : List_Id) is
18868 if Present (Decls) then
18869 Decl := First (Decls);
18870 while Present (Decl) loop
18871 if Nkind (Decl) = N_Object_Declaration
18872 and then Has_Task (Etype (Defining_Identifier (Decl)))
18874 Add_Task_Proc (Etype (Defining_Identifier (Decl)));
18886 function Outer_Unit (E : Entity_Id) return Entity_Id is
18891 while Present (Outer) loop
18892 if Elaboration_Checks_Suppressed (Outer) then
18896 exit when Is_Child_Unit (Outer)
18897 or else Scope (Outer) = Standard_Standard
18898 or else Ekind (Outer) /= E_Package;
18899 Outer := Scope (Outer);
18905 -- Start of processing for Check_Task_Activation
18908 pragma Assert (Legacy_Elaboration_Checks);
18910 Enclosing := Outer_Unit (Current_Scope);
18912 -- Find all tasks declared in the current unit
18914 if Nkind (N) = N_Package_Body then
18915 P := Unit_Declaration_Node (Corresponding_Spec (N));
18917 Collect_Tasks (Declarations (N));
18918 Collect_Tasks (Visible_Declarations (Specification (P)));
18919 Collect_Tasks (Private_Declarations (Specification (P)));
18921 elsif Nkind (N) = N_Package_Declaration then
18922 Collect_Tasks (Visible_Declarations (Specification (N)));
18923 Collect_Tasks (Private_Declarations (Specification (N)));
18926 Collect_Tasks (Declarations (N));
18929 -- We only perform detailed checks in all tasks that are library level
18930 -- entities. If the master is a subprogram or task, activation will
18931 -- depend on the activation of the master itself.
18933 -- Should dynamic checks be added in the more general case???
18935 if Ekind (Enclosing) /= E_Package then
18939 -- For task types defined in other units, we want the unit containing
18940 -- the task body to be elaborated before the current one.
18942 Elmt := First_Elmt (Inter_Procs);
18943 while Present (Elmt) loop
18944 Ent := Node (Elmt);
18945 Task_Scope := Outer_Unit (Scope (Ent));
18947 if not Is_Compilation_Unit (Task_Scope) then
18950 elsif Suppress_Elaboration_Warnings (Task_Scope)
18951 or else Elaboration_Checks_Suppressed (Task_Scope)
18955 elsif Dynamic_Elaboration_Checks then
18956 if not Elaboration_Checks_Suppressed (Ent)
18957 and then not Cunit_SC
18958 and then not Restriction_Active
18959 (No_Entry_Calls_In_Elaboration_Code)
18961 -- Runtime elaboration check required. Generate check of the
18962 -- elaboration counter for the unit containing the entity.
18964 Insert_Elab_Check (N,
18965 Make_Attribute_Reference (Loc,
18967 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc),
18968 Attribute_Name => Name_Elaborated));
18972 -- Force the binder to elaborate other unit first
18974 if Elab_Info_Messages
18975 and then not Suppress_Elaboration_Warnings (Ent)
18976 and then not Elaboration_Checks_Suppressed (Ent)
18977 and then not Suppress_Elaboration_Warnings (Task_Scope)
18978 and then not Elaboration_Checks_Suppressed (Task_Scope)
18980 Error_Msg_Node_2 := Task_Scope;
18982 ("info: activation of an instance of task type & requires "
18983 & "pragma Elaborate_All on &?$?", N, Ent);
18986 Activate_Elaborate_All_Desirable (N, Task_Scope);
18987 Set_Suppress_Elaboration_Warnings (Task_Scope);
18993 -- For tasks declared in the current unit, trace other calls within the
18994 -- task procedure bodies, which are available.
18996 if not Debug_Flag_Dot_Y then
18997 In_Task_Activation := True;
18999 Elmt := First_Elmt (Intra_Procs);
19000 while Present (Elmt) loop
19001 Ent := Node (Elmt);
19002 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
19006 In_Task_Activation := False;
19008 end Check_Task_Activation;
19010 ------------------------
19011 -- Get_Referenced_Ent --
19012 ------------------------
19014 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is
19018 if Nkind (N) in N_Has_Entity
19019 and then Present (Entity (N))
19020 and then Ekind (Entity (N)) = E_Variable
19025 if Nkind (N) = N_Attribute_Reference then
19033 elsif Nkind (Nam) = N_Selected_Component then
19034 return Entity (Selector_Name (Nam));
19035 elsif not Is_Entity_Name (Nam) then
19038 return Entity (Nam);
19040 end Get_Referenced_Ent;
19042 ----------------------
19043 -- Has_Generic_Body --
19044 ----------------------
19046 function Has_Generic_Body (N : Node_Id) return Boolean is
19047 Ent : constant Entity_Id := Get_Generic_Entity (N);
19048 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
19051 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id;
19052 -- Determine if the list of nodes headed by N and linked by Next
19053 -- contains a package body for the package spec entity E, and if so
19054 -- return the package body. If not, then returns Empty.
19056 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id;
19057 -- This procedure is called load the unit whose name is given by Nam.
19058 -- This unit is being loaded to see whether it contains an optional
19059 -- generic body. The returned value is the loaded unit, which is always
19060 -- a package body (only package bodies can contain other entities in the
19061 -- sense in which Has_Generic_Body is interested). We only attempt to
19062 -- load bodies if we are generating code. If we are in semantics check
19063 -- only mode, then it would be wrong to load bodies that are not
19064 -- required from a semantic point of view, so in this case we return
19065 -- Empty. The result is that the caller may incorrectly decide that a
19066 -- generic spec does not have a body when in fact it does, but the only
19067 -- harm in this is that some warnings on elaboration problems may be
19068 -- lost in semantic checks only mode, which is not big loss. We also
19069 -- return Empty if we go for a body and it is not there.
19071 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id;
19072 -- PE is the entity for a package spec. This function locates the
19073 -- corresponding package body, returning Empty if none is found. The
19074 -- package body returned is fully parsed but may not yet be analyzed,
19075 -- so only syntactic fields should be referenced.
19081 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is
19086 while Present (Nod) loop
19088 -- If we found the package body we are looking for, return it
19090 if Nkind (Nod) = N_Package_Body
19091 and then Chars (Defining_Unit_Name (Nod)) = Chars (E)
19095 -- If we found the stub for the body, go after the subunit,
19096 -- loading it if necessary.
19098 elsif Nkind (Nod) = N_Package_Body_Stub
19099 and then Chars (Defining_Identifier (Nod)) = Chars (E)
19101 if Present (Library_Unit (Nod)) then
19102 return Unit (Library_Unit (Nod));
19105 return Load_Package_Body (Get_Unit_Name (Nod));
19108 -- If neither package body nor stub, keep looking on chain
19118 -----------------------
19119 -- Load_Package_Body --
19120 -----------------------
19122 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is
19123 U : Unit_Number_Type;
19126 if Operating_Mode /= Generate_Code then
19136 if U = No_Unit then
19139 return Unit (Cunit (U));
19142 end Load_Package_Body;
19144 -------------------------------
19145 -- Locate_Corresponding_Body --
19146 -------------------------------
19148 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is
19149 Spec : constant Node_Id := Declaration_Node (PE);
19150 Decl : constant Node_Id := Parent (Spec);
19151 Scop : constant Entity_Id := Scope (PE);
19155 if Is_Library_Level_Entity (PE) then
19157 -- If package is a library unit that requires a body, we have no
19158 -- choice but to go after that body because it might contain an
19159 -- optional body for the original generic package.
19161 if Unit_Requires_Body (PE) then
19163 -- Load the body. Note that we are a little careful here to use
19164 -- Spec to get the unit number, rather than PE or Decl, since
19165 -- in the case where the package is itself a library level
19166 -- instantiation, Spec will properly reference the generic
19167 -- template, which is what we really want.
19171 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec))));
19173 -- But if the package is a library unit that does NOT require
19174 -- a body, then no body is permitted, so we are sure that there
19175 -- is no body for the original generic package.
19181 -- Otherwise look and see if we are embedded in a further package
19183 elsif Is_Package_Or_Generic_Package (Scop) then
19185 -- If so, get the body of the enclosing package, and look in
19186 -- its package body for the package body we are looking for.
19188 PBody := Locate_Corresponding_Body (Scop);
19193 return Find_Body_In (PE, First (Declarations (PBody)));
19196 -- If we are not embedded in a further package, then the body
19197 -- must be in the same declarative part as we are.
19200 return Find_Body_In (PE, Next (Decl));
19202 end Locate_Corresponding_Body;
19204 -- Start of processing for Has_Generic_Body
19207 if Present (Corresponding_Body (Decl)) then
19210 elsif Unit_Requires_Body (Ent) then
19213 -- Compilation units cannot have optional bodies
19215 elsif Is_Compilation_Unit (Ent) then
19218 -- Otherwise look at what scope we are in
19221 Scop := Scope (Ent);
19223 -- Case of entity is in other than a package spec, in this case
19224 -- the body, if present, must be in the same declarative part.
19226 if not Is_Package_Or_Generic_Package (Scop) then
19231 -- Declaration node may get us a spec, so if so, go to
19232 -- the parent declaration.
19234 P := Declaration_Node (Ent);
19235 while not Is_List_Member (P) loop
19239 return Present (Find_Body_In (Ent, Next (P)));
19242 -- If the entity is in a package spec, then we have to locate
19243 -- the corresponding package body, and look there.
19247 PBody : constant Node_Id := Locate_Corresponding_Body (Scop);
19255 (Find_Body_In (Ent, (First (Declarations (PBody)))));
19260 end Has_Generic_Body;
19262 -----------------------
19263 -- Insert_Elab_Check --
19264 -----------------------
19266 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is
19268 Loc : constant Source_Ptr := Sloc (N);
19271 -- The check (N_Raise_Program_Error) node to be inserted
19274 -- If expansion is disabled, do not generate any checks. Also
19275 -- skip checks if any subunits are missing because in either
19276 -- case we lack the full information that we need, and no object
19277 -- file will be created in any case.
19279 if not Expander_Active or else Subunits_Missing then
19283 -- If we have a generic instantiation, where Instance_Spec is set,
19284 -- then this field points to a generic instance spec that has
19285 -- been inserted before the instantiation node itself, so that
19286 -- is where we want to insert a check.
19288 if Nkind (N) in N_Generic_Instantiation
19289 and then Present (Instance_Spec (N))
19291 Nod := Instance_Spec (N);
19296 -- Build check node, possibly with condition
19299 Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration);
19301 if Present (C) then
19302 Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C));
19305 -- If we are inserting at the top level, insert in Aux_Decls
19307 if Nkind (Parent (Nod)) = N_Compilation_Unit then
19309 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
19312 if No (Declarations (ADN)) then
19313 Set_Declarations (ADN, New_List (Chk));
19315 Append_To (Declarations (ADN), Chk);
19321 -- Otherwise just insert as an action on the node in question
19324 Insert_Action (Nod, Chk);
19326 end Insert_Elab_Check;
19328 -------------------------------
19329 -- Is_Call_Of_Generic_Formal --
19330 -------------------------------
19332 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is
19334 return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
19336 -- Always return False if debug flag -gnatd.G is set
19338 and then not Debug_Flag_Dot_GG
19340 -- For now, we detect this by looking for the strange identifier
19341 -- node, whose Chars reflect the name of the generic formal, but
19342 -- the Chars of the Entity references the generic actual.
19344 and then Nkind (Name (N)) = N_Identifier
19345 and then Chars (Name (N)) /= Chars (Entity (Name (N)));
19346 end Is_Call_Of_Generic_Formal;
19348 -------------------------------
19349 -- Is_Finalization_Procedure --
19350 -------------------------------
19352 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is
19354 -- Check whether Id is a procedure with at least one parameter
19356 if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then
19358 Typ : constant Entity_Id := Etype (First_Formal (Id));
19359 Deep_Fin : Entity_Id := Empty;
19360 Fin : Entity_Id := Empty;
19363 -- If the type of the first formal does not require finalization
19364 -- actions, then this is definitely not [Deep_]Finalize.
19366 if not Needs_Finalization (Typ) then
19370 -- At this point we have the following scenario:
19372 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
19374 -- Recover the two possible versions of [Deep_]Finalize using the
19375 -- type of the first parameter and compare with the input.
19377 Deep_Fin := TSS (Typ, TSS_Deep_Finalize);
19379 if Is_Controlled (Typ) then
19380 Fin := Find_Prim_Op (Typ, Name_Finalize);
19383 return (Present (Deep_Fin) and then Id = Deep_Fin)
19384 or else (Present (Fin) and then Id = Fin);
19389 end Is_Finalization_Procedure;
19395 procedure Output_Calls
19397 Check_Elab_Flag : Boolean)
19399 function Emit (Flag : Boolean) return Boolean;
19400 -- Determine whether to emit an error message based on the combination
19401 -- of flags Check_Elab_Flag and Flag.
19403 function Is_Printable_Error_Name return Boolean;
19404 -- An internal function, used to determine if a name, stored in the
19405 -- Name_Buffer, is either a non-internal name, or is an internal name
19406 -- that is printable by the error message circuits (i.e. it has a single
19407 -- upper case letter at the end).
19413 function Emit (Flag : Boolean) return Boolean is
19415 if Check_Elab_Flag then
19422 -----------------------------
19423 -- Is_Printable_Error_Name --
19424 -----------------------------
19426 function Is_Printable_Error_Name return Boolean is
19428 if not Is_Internal_Name then
19431 elsif Name_Len = 1 then
19435 Name_Len := Name_Len - 1;
19436 return not Is_Internal_Name;
19438 end Is_Printable_Error_Name;
19444 -- Start of processing for Output_Calls
19447 for J in reverse 1 .. Elab_Call.Last loop
19448 Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
19450 Ent := Elab_Call.Table (J).Ent;
19451 Get_Name_String (Chars (Ent));
19453 -- Dynamic elaboration model, warnings controlled by -gnatwl
19455 if Dynamic_Elaboration_Checks then
19456 if Emit (Elab_Warnings) then
19457 if Is_Generic_Unit (Ent) then
19458 Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
19459 elsif Is_Init_Proc (Ent) then
19460 Error_Msg_N ("\\?l?initialization procedure called #", N);
19461 elsif Is_Printable_Error_Name then
19462 Error_Msg_NE ("\\?l?& called #", N, Ent);
19464 Error_Msg_N ("\\?l?called #", N);
19468 -- Static elaboration model, info messages controlled by -gnatel
19471 if Emit (Elab_Info_Messages) then
19472 if Is_Generic_Unit (Ent) then
19473 Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
19474 elsif Is_Init_Proc (Ent) then
19475 Error_Msg_N ("\\?$?initialization procedure called #", N);
19476 elsif Is_Printable_Error_Name then
19477 Error_Msg_NE ("\\?$?& called #", N, Ent);
19479 Error_Msg_N ("\\?$?called #", N);
19486 ----------------------------
19487 -- Same_Elaboration_Scope --
19488 ----------------------------
19490 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
19495 -- Find elaboration scope for Scop1
19496 -- This is either a subprogram or a compilation unit.
19499 while S1 /= Standard_Standard
19500 and then not Is_Compilation_Unit (S1)
19501 and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block)
19506 -- Find elaboration scope for Scop2
19509 while S2 /= Standard_Standard
19510 and then not Is_Compilation_Unit (S2)
19511 and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block)
19517 end Same_Elaboration_Scope;
19523 procedure Set_C_Scope is
19525 while not Is_Compilation_Unit (C_Scope) loop
19526 C_Scope := Scope (C_Scope);
19530 --------------------------------
19531 -- Set_Elaboration_Constraint --
19532 --------------------------------
19534 procedure Set_Elaboration_Constraint
19539 Elab_Unit : Entity_Id;
19541 -- Check whether this is a call to an Initialize subprogram for a
19542 -- controlled type. Note that Call can also be a 'Access attribute
19543 -- reference, which now generates an elaboration check.
19545 Init_Call : constant Boolean :=
19546 Nkind (Call) = N_Procedure_Call_Statement
19547 and then Chars (Subp) = Name_Initialize
19548 and then Comes_From_Source (Subp)
19549 and then Present (Parameter_Associations (Call))
19550 and then Is_Controlled (Etype (First_Actual (Call)));
19553 -- If the unit is mentioned in a with_clause of the current unit, it is
19554 -- visible, and we can set the elaboration flag.
19556 if Is_Immediately_Visible (Scop)
19557 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop))
19559 Activate_Elaborate_All_Desirable (Call, Scop);
19560 Set_Suppress_Elaboration_Warnings (Scop);
19564 -- If this is not an initialization call or a call using object notation
19565 -- we know that the unit of the called entity is in the context, and we
19566 -- can set the flag as well. The unit need not be visible if the call
19567 -- occurs within an instantiation.
19569 if Is_Init_Proc (Subp)
19571 or else Nkind (Original_Node (Call)) = N_Selected_Component
19573 null; -- detailed processing follows.
19576 Activate_Elaborate_All_Desirable (Call, Scop);
19577 Set_Suppress_Elaboration_Warnings (Scop);
19581 -- If the unit is not in the context, there must be an intermediate unit
19582 -- that is, on which we need to place to elaboration flag. This happens
19583 -- with init proc calls.
19585 if Is_Init_Proc (Subp) or else Init_Call then
19587 -- The initialization call is on an object whose type is not declared
19588 -- in the same scope as the subprogram. The type of the object must
19589 -- be a subtype of the type of operation. This object is the first
19590 -- actual in the call.
19593 Typ : constant Entity_Id :=
19594 Etype (First (Parameter_Associations (Call)));
19596 Elab_Unit := Scope (Typ);
19597 while (Present (Elab_Unit))
19598 and then not Is_Compilation_Unit (Elab_Unit)
19600 Elab_Unit := Scope (Elab_Unit);
19604 -- If original node uses selected component notation, the prefix is
19605 -- visible and determines the scope that must be elaborated. After
19606 -- rewriting, the prefix is the first actual in the call.
19608 elsif Nkind (Original_Node (Call)) = N_Selected_Component then
19609 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call))));
19611 -- Not one of special cases above
19614 -- Using previously computed scope. If the elaboration check is
19615 -- done after analysis, the scope is not visible any longer, but
19616 -- must still be in the context.
19621 Activate_Elaborate_All_Desirable (Call, Elab_Unit);
19622 Set_Suppress_Elaboration_Warnings (Elab_Unit);
19623 end Set_Elaboration_Constraint;
19629 function Spec_Entity (E : Entity_Id) return Entity_Id is
19633 -- Check for case of body entity
19634 -- Why is the check for E_Void needed???
19636 if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then
19640 Decl := Parent (Decl);
19641 exit when Nkind (Decl) in N_Proper_Body;
19644 return Corresponding_Spec (Decl);
19655 function Within (E1, E2 : Entity_Id) return Boolean is
19662 elsif Scop = Standard_Standard then
19665 Scop := Scope (Scop);
19670 --------------------------
19671 -- Within_Elaborate_All --
19672 --------------------------
19674 function Within_Elaborate_All
19675 (Unit : Unit_Number_Type;
19676 E : Entity_Id) return Boolean
19678 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
19679 pragma Pack (Unit_Number_Set);
19681 Seen : Unit_Number_Set := (others => False);
19682 -- Seen (X) is True after we have seen unit X in the walk. This is used
19683 -- to prevent processing the same unit more than once.
19685 Result : Boolean := False;
19687 procedure Helper (Unit : Unit_Number_Type);
19688 -- This helper procedure does all the work for Within_Elaborate_All. It
19689 -- walks the dependency graph, and sets Result to True if it finds an
19690 -- appropriate Elaborate_All.
19696 procedure Helper (Unit : Unit_Number_Type) is
19697 CU : constant Node_Id := Cunit (Unit);
19701 Elab_Id : Entity_Id;
19705 if Seen (Unit) then
19708 Seen (Unit) := True;
19711 -- First, check for Elaborate_Alls on this unit
19713 Item := First (Context_Items (CU));
19714 while Present (Item) loop
19715 if Nkind (Item) = N_Pragma
19716 and then Pragma_Name (Item) = Name_Elaborate_All
19718 -- Return if some previous error on the pragma itself. The
19719 -- pragma may be unanalyzed, because of a previous error, or
19720 -- if it is the context of a subunit, inherited by its parent.
19722 if Error_Posted (Item) or else not Analyzed (Item) then
19728 (Expression (First (Pragma_Argument_Associations (Item))));
19730 if E = Elab_Id then
19735 Par := Parent (Unit_Declaration_Node (Elab_Id));
19737 Item2 := First (Context_Items (Par));
19738 while Present (Item2) loop
19739 if Nkind (Item2) = N_With_Clause
19740 and then Entity (Name (Item2)) = E
19741 and then not Limited_Present (Item2)
19754 -- Second, recurse on with's. We could do this as part of the above
19755 -- loop, but it's probably more efficient to have two loops, because
19756 -- the relevant Elaborate_All is likely to be on the initial unit. In
19757 -- other words, we're walking the with's breadth-first. This part is
19758 -- only necessary in the dynamic elaboration model.
19760 if Dynamic_Elaboration_Checks then
19761 Item := First (Context_Items (CU));
19762 while Present (Item) loop
19763 if Nkind (Item) = N_With_Clause
19764 and then not Limited_Present (Item)
19766 -- Note: the following call to Get_Cunit_Unit_Number does a
19767 -- linear search, which could be slow, but it's OK because
19768 -- we're about to give a warning anyway. Also, there might
19769 -- be hundreds of units, but not millions. If it turns out
19770 -- to be a problem, we could store the Get_Cunit_Unit_Number
19771 -- in each N_Compilation_Unit node, but that would involve
19772 -- rearranging N_Compilation_Unit_Aux to make room.
19774 Helper (Get_Cunit_Unit_Number (Library_Unit (Item)));
19786 -- Start of processing for Within_Elaborate_All
19791 end Within_Elaborate_All;