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_Prag; use Sem_Prag;
53 with Sem_Util; use Sem_Util;
54 with Sinfo; use Sinfo;
55 with Sinput; use Sinput;
56 with Snames; use Snames;
57 with Stand; use Stand;
59 with Tbuild; use Tbuild;
60 with Uintp; use Uintp;
61 with Uname; use Uname;
64 with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
65 with GNAT.Lists; use GNAT.Lists;
66 with GNAT.Sets; use GNAT.Sets;
68 package body Sem_Elab is
70 -----------------------------------------
71 -- Access-before-elaboration mechanism --
72 -----------------------------------------
74 -- The access-before-elaboration (ABE) mechanism implemented in this unit
75 -- has the following objectives:
77 -- * Diagnose at compile-time or install run-time checks to prevent ABE
78 -- access to data and behaviour.
80 -- The high-level idea is to accurately diagnose ABE issues within a
81 -- single unit because the ABE mechanism can inspect the whole unit.
82 -- As soon as the elaboration graph extends to an external unit, the
83 -- diagnostics stop because the body of the unit may not be available.
84 -- Due to control and data flow, the ABE mechanism cannot accurately
85 -- determine whether a particular scenario will be elaborated or not.
86 -- Conditional ABE checks are therefore used to verify the elaboration
87 -- status of local and external targets at run time.
89 -- * Supply implicit elaboration dependencies for a unit to binde
91 -- The ABE mechanism creates implicit dependencies in the form of with
92 -- clauses subject to pragma Elaborate[_All] when the elaboration graph
93 -- reaches into an external unit. The implicit dependencies are encoded
94 -- in the ALI file of the main unit. GNATbind and binde then use these
95 -- dependencies to augment the library item graph and determine the
96 -- elaboration order of all units in the compilation.
98 -- * Supply pieces of the invocation graph for a unit to bindo
100 -- The ABE mechanism captures paths starting from elaboration code or
101 -- top level constructs that reach into an external unit. The paths are
102 -- encoded in the ALI file of the main unit in the form of declarations
103 -- which represent nodes, and relations which represent edges. GNATbind
104 -- and bindo then build the full invocation graph in order to augment
105 -- the library item graph and determine the elaboration order of all
106 -- units in the compilation.
108 -- The ABE mechanism supports three models of elaboration:
110 -- * Dynamic model - This is the most permissive of the three models.
111 -- When the dynamic model is in effect, the mechanism diagnoses and
112 -- installs run-time checks to detect ABE issues in the main unit.
113 -- The behaviour of this model is identical to that specified by the
114 -- Ada RM. This model is enabled with switch -gnatE.
116 -- Static model - This is the middle ground of the three models. When
117 -- the static model is in effect, the mechanism diagnoses and installs
118 -- run-time checks to detect ABE issues in the main unit. In addition,
119 -- the mechanism generates implicit dependencies between units in the
120 -- form of with clauses subject to pragma Elaborate[_All] to ensure
121 -- the prior elaboration of withed units. This is the default model.
123 -- * SPARK model - This is the most conservative of the three models and
124 -- impelements the semantics defined in SPARK RM 7.7. The SPARK model
125 -- is in effect only when a context resides in a SPARK_Mode On region,
126 -- otherwise the mechanism falls back to one of the previous models.
128 -- The ABE mechanism consists of a "recording" phase and a "processing"
135 -- * ABE - An attempt to invoke a scenario which has not been elaborated
138 -- * Bridge target - A type of target. A bridge target is a link between
139 -- scenarios. It is usually a byproduct of expansion and does not have
140 -- any direct ABE ramifications.
142 -- * Call marker - A special node used to indicate the presence of a call
143 -- in the tree in case expansion transforms or eliminates the original
144 -- call. N_Call_Marker nodes do not have static and run-time semantics.
146 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the
147 -- invocation of a target by a scenario within the main unit causes an
148 -- ABE, but does not cause an ABE for another scenarios within the main
151 -- * Declaration level - A type of enclosing level. A scenario or target is
152 -- at the declaration level when it appears within the declarations of a
153 -- block statement, entry body, subprogram body, or task body, ignoring
154 -- enclosing packages.
156 -- * Early call region - A section of code which ends at a subprogram body
157 -- and starts from the nearest non-preelaborable construct which precedes
158 -- the subprogram body. The early call region extends from a package body
159 -- to a package spec when the spec carries pragma Elaborate_Body.
161 -- * Generic library level - A type of enclosing level. A scenario or
162 -- target is at the generic library level if it appears in a generic
163 -- package library unit, ignoring enclosing packages.
165 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the
166 -- invocation of a target by all scenarios within the main unit causes
169 -- * Instantiation library level - A type of enclosing level. A scenario
170 -- or target is at the instantiation library level if it appears in an
171 -- instantiation library unit, ignoring enclosing packages.
173 -- * Invocation - The act of activating a task, calling a subprogram, or
174 -- instantiating a generic.
176 -- * Invocation construct - An entry declaration, [single] protected type,
177 -- subprogram declaration, subprogram instantiation, or a [single] task
178 -- type declared in the visible, private, or body declarations of the
181 -- * Invocation relation - A flow link between two invocation constructs
183 -- * Invocation signature - A set of attributes that uniquely identify an
184 -- invocation construct within the namespace of all ALI files.
186 -- * Library level - A type of enclosing level. A scenario or target is at
187 -- the library level if it appears in a package library unit, ignoring
188 -- enclosng packages.
190 -- * Non-library-level encapsulator - A construct that cannot be elaborated
191 -- on its own and requires elaboration by a top-level scenario.
193 -- * Scenario - A construct or context which is invoked by elaboration code
194 -- or invocation construct. The scenarios recognized by the ABE mechanism
197 -- - '[Unrestricted_]Access of entries, operators, and subprograms
199 -- - Assignments to variables
201 -- - Calls to entries, operators, and subprograms
203 -- - Derived type declarations
207 -- - Pragma Refined_State
209 -- - Reads of variables
213 -- * Target - A construct invoked by a scenario. The targets recognized by
214 -- the ABE mechanism are as follows:
216 -- - For '[Unrestricted_]Access of entries, operators, and subprograms,
217 -- the target is the entry, operator, or subprogram.
219 -- - For assignments to variables, the target is the variable
221 -- - For calls, the target is the entry, operator, or subprogram
223 -- - For derived type declarations, the target is the derived type
225 -- - For instantiations, the target is the generic template
227 -- - For pragma Refined_State, the targets are the constituents
229 -- - For reads of variables, the target is the variable
231 -- - For task activation, the target is the task body
237 -- Analysis/Resolution
239 -- +- Build_Call_Marker
241 -- +- Build_Variable_Reference_Marker
243 -- +- | -------------------- Recording phase ---------------------------+
245 -- | Record_Elaboration_Scenario |
247 -- | +--> Check_Preelaborated_Call |
249 -- | +--> Process_Guaranteed_ABE |
251 -- | | +--> Process_Guaranteed_ABE_Activation |
252 -- | | +--> Process_Guaranteed_ABE_Call |
253 -- | | +--> Process_Guaranteed_ABE_Instantiation |
255 -- +- | ----------------------------------------------------------------+
258 -- +--> Internal_Representation
260 -- +--> Scenario_Storage
262 -- End of Compilation
264 -- +- | --------------------- Processing phase -------------------------+
266 -- | Check_Elaboration_Scenarios |
268 -- | +--> Check_Conditional_ABE_Scenarios |
270 -- | | +--> Process_Conditional_ABE <----------------------+ |
272 -- | | +--> Process_Conditional_ABE_Activation | |
274 -- | | | +-----------------------------+ | |
276 -- | | +--> Process_Conditional_ABE_Call +---> Traverse_Body |
278 -- | | | +-----------------------------+ |
280 -- | | +--> Process_Conditional_ABE_Access_Taken |
281 -- | | +--> Process_Conditional_ABE_Instantiation |
282 -- | | +--> Process_Conditional_ABE_Variable_Assignment |
283 -- | | +--> Process_Conditional_ABE_Variable_Reference |
285 -- | +--> Check_SPARK_Scenario |
287 -- | | +--> Process_SPARK_Scenario |
289 -- | | +--> Process_SPARK_Derived_Type |
290 -- | | +--> Process_SPARK_Instantiation |
291 -- | | +--> Process_SPARK_Refined_State_Pragma |
293 -- | +--> Record_Invocation_Graph |
295 -- | +--> Process_Invocation_Body_Scenarios |
296 -- | +--> Process_Invocation_Spec_Scenarios |
297 -- | +--> Process_Main_Unit |
299 -- | +--> Process_Invocation_Scenario <-------------+ |
301 -- | +--> Process_Invocation_Activation | |
303 -- | | +------------------------+ | |
305 -- | +--> Process_Invocation_Call +---> Traverse_Body |
307 -- | +------------------------+ |
309 -- +--------------------------------------------------------------------+
311 ---------------------
312 -- Recording phase --
313 ---------------------
315 -- The Recording phase coincides with the analysis/resolution phase of the
316 -- compiler. It has the following objectives:
318 -- * Record all suitable scenarios for examination by the Processing
321 -- Saving only a certain number of nodes improves the performance of
322 -- the ABE mechanism. This eliminates the need to examine the whole
323 -- tree in a separate pass.
325 -- * Record certain SPARK scenarios which are not necessarily invoked
326 -- during elaboration, but still require elaboration-related checks.
328 -- Saving only a certain number of nodes improves the performance of
329 -- the ABE mechanism. This eliminates the need to examine the whole
330 -- tree in a separate pass.
332 -- * Detect and diagnose calls in preelaborable or pure units, including
335 -- This diagnostic is carried out during the Recording phase because it
336 -- does not need the heavy recursive traversal done by the Processing
339 -- * Detect and diagnose guaranteed ABEs caused by instantiations, calls,
340 -- and task activation.
342 -- The issues detected by the ABE mechanism are reported as warnings
343 -- because they do not violate Ada semantics. Forward instantiations
344 -- may thus reach gigi, however gigi cannot handle certain kinds of
345 -- premature instantiations and may crash. To avoid this limitation,
346 -- the ABE mechanism must identify forward instantiations as early as
347 -- possible and suppress their bodies. Calls and task activations are
348 -- included in this category for completeness.
350 ----------------------
351 -- Processing phase --
352 ----------------------
354 -- The Processing phase is a separate pass which starts after instantiating
355 -- and/or inlining of bodies, but before the removal of Ghost code. It has
356 -- the following objectives:
358 -- * Examine all scenarios saved during the Recording phase, and perform
359 -- the following actions:
363 -- Diagnose conditional ABEs, and install run-time conditional ABE
364 -- checks for all scenarios.
368 -- Enforce the SPARK elaboration rules
372 -- Diagnose conditional ABEs, install run-time conditional ABE
373 -- checks only for scenarios are reachable from elaboration code,
374 -- and guarantee the elaboration of external units by creating
375 -- implicit with clauses subject to pragma Elaborate[_All].
377 -- * Examine library-level scenarios and invocation constructs, and
378 -- perform the following actions:
380 -- - Determine whether the flow of execution reaches into an external
381 -- unit. If this is the case, encode the path in the ALI file of
384 -- - Create declarations for invocation constructs in the ALI file of
387 ----------------------
388 -- Important points --
389 ----------------------
391 -- The Processing phase starts after the analysis, resolution, expansion
392 -- phase has completed. As a result, no current semantic information is
393 -- available. The scope stack is empty, global flags such as In_Instance
394 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism
395 -- must either save or recompute semantic information.
397 -- Expansion heavily transforms calls and to some extent instantiations. To
398 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to
399 -- capture the target and relevant attributes of the original call.
401 -- The diagnostics of the ABE mechanism depend on accurate source locations
402 -- to determine the spacial relation of nodes.
404 -----------------------------------------
405 -- Suppression of elaboration warnings --
406 -----------------------------------------
408 -- Elaboration warnings along multiple traversal paths rooted at a scenario
409 -- are suppressed when the scenario has elaboration warnings suppressed.
413 -- +-- Child scenario 1
415 -- | +-- Grandchild scenario 1
417 -- | +-- Grandchild scenario N
419 -- +-- Child scenario N
421 -- If the root scenario has elaboration warnings suppressed, then all its
422 -- child, grandchild, etc. scenarios will have their elaboration warnings
425 -- In addition to switch -gnatwL, pragma Warnings may be used to suppress
426 -- elaboration-related warnings when used in the following manner:
428 -- pragma Warnings ("L");
429 -- <scenario-or-target>
432 -- pragma Warnings (Off, target);
434 -- pragma Warnings (Off);
435 -- <scenario-or-target>
437 -- * To suppress elaboration warnings for '[Unrestricted_]Access of
438 -- entries, operators, and subprograms, either:
440 -- - Suppress the entry, operator, or subprogram, or
441 -- - Suppress the attribute, or
442 -- - Use switch -gnatw.f
444 -- * To suppress elaboration warnings for calls to entries, operators,
445 -- and subprograms, either:
447 -- - Suppress the entry, operator, or subprogram, or
448 -- - Suppress the call
450 -- * To suppress elaboration warnings for instantiations, suppress the
453 -- * To suppress elaboration warnings for task activations, either:
455 -- - Suppress the task object, or
456 -- - Suppress the task type, or
457 -- - Suppress the activation call
463 -- The following switches may be used to control the behavior of the ABE
466 -- -gnatd_a stop elaboration checks on accept or select statement
468 -- The ABE mechanism stops the traversal of a task body when it
469 -- encounters an accept or a select statement. This behavior is
470 -- equivalent to restriction No_Entry_Calls_In_Elaboration_Code,
471 -- but without penalizing actual entry calls during elaboration.
473 -- -gnatd_e ignore entry calls and requeue statements for elaboration
475 -- The ABE mechanism does not generate N_Call_Marker nodes for
476 -- protected or task entry calls as well as requeue statements.
477 -- As a result, the calls and requeues are not recorded or
480 -- -gnatdE elaboration checks on predefined units
482 -- The ABE mechanism considers scenarios which appear in internal
483 -- units (Ada, GNAT, Interfaces, System).
485 -- -gnatd_F encode full invocation paths in ALI files
487 -- The ABE mechanism encodes the full path from an elaboration
488 -- procedure or invocable construct to an external target. The
489 -- path contains all intermediate activations, instantiations,
492 -- -gnatd.G ignore calls through generic formal parameters for elaboration
494 -- The ABE mechanism does not generate N_Call_Marker nodes for
495 -- calls which occur in expanded instances, and invoke generic
496 -- actual subprograms through generic formal subprograms. As a
497 -- result, the calls are not recorded or processed.
499 -- -gnatd_G encode invocation graph in ALI files
501 -- The ABE mechanism encodes the invocation graph of the main
502 -- unit. This includes elaboration code, as well as invocation
505 -- -gnatd_i ignore activations and calls to instances for elaboration
507 -- The ABE mechanism ignores calls and task activations when they
508 -- target a subprogram or task type defined an external instance.
509 -- As a result, the calls and task activations are not processed.
511 -- -gnatdL ignore external calls from instances for elaboration
513 -- The ABE mechanism does not generate N_Call_Marker nodes for
514 -- calls which occur in expanded instances, do not invoke generic
515 -- actual subprograms through formal subprograms, and the target
516 -- is external to the instance. As a result, the calls are not
517 -- recorded or processed.
519 -- -gnatd.o conservative elaboration order for indirect calls
521 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
522 -- operator, or subprogram as an immediate invocation of the
523 -- target. As a result, it performs ABE checks and diagnostics on
524 -- the immediate call.
526 -- -gnatd_p ignore assertion pragmas for elaboration
528 -- The ABE mechanism does not generate N_Call_Marker nodes for
529 -- calls to subprograms which verify the run-time semantics of
530 -- the following assertion pragmas:
532 -- Default_Initial_Condition
540 -- Type_Invariant_Class
542 -- As a result, the assertion expressions of the pragmas are not
545 -- -gnatd_s stop elaboration checks on synchronous suspension
547 -- The ABE mechanism stops the traversal of a task body when it
548 -- encounters a call to one of the following routines:
550 -- Ada.Synchronous_Barriers.Wait_For_Release
551 -- Ada.Synchronous_Task_Control.Suspend_Until_True
553 -- -gnatd_T output trace information on invocation relation construction
555 -- The ABE mechanism outputs text information concerning relation
556 -- construction to standard output.
558 -- -gnatd.U ignore indirect calls for static elaboration
560 -- The ABE mechanism does not consider '[Unrestricted_]Access of
561 -- entries, operators, and subprograms. As a result, the scenarios
562 -- are not recorder or processed.
564 -- -gnatd.v enforce SPARK elaboration rules in SPARK code
566 -- The ABE mechanism applies some of the SPARK elaboration rules
567 -- defined in the SPARK reference manual, chapter 7.7. Note that
568 -- certain rules are always enforced, regardless of whether the
571 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies
573 -- The ABE mechanism does not generate implicit Elaborate_All when
574 -- the need for the pragma came from a task body.
576 -- -gnatE dynamic elaboration checking mode enabled
578 -- The ABE mechanism assumes that any scenario is elaborated or
579 -- invoked by elaboration code. The ABE mechanism performs very
580 -- little diagnostics and generates condintional ABE checks to
581 -- detect ABE issues at run-time.
583 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas
585 -- The ABE mechanism produces information messages on generated
586 -- implicit Elabote[_All] pragmas along with traceback showing
587 -- why the pragma was generated. In addition, the ABE mechanism
588 -- produces information messages for each scenario elaborated or
589 -- invoked by elaboration code.
591 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas
593 -- The complementary switch for -gnatel.
595 -- -gnatH legacy elaboration checking mode enabled
597 -- When this switch is in effect, the pre-18.x ABE model becomes
598 -- the defacto ABE model. This ammounts to cutting off all entry
599 -- points into the new ABE mechanism, and giving full control to
600 -- the old ABE mechanism.
602 -- -gnatJ permissive elaboration checking mode enabled
604 -- This switch activates the following switches:
616 -- IMPORTANT: The behavior of the ABE mechanism becomes more
617 -- permissive at the cost of accurate diagnostics and runtime
620 -- -gnatw.f turn on warnings for suspicious Subp'Access
622 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
623 -- operator, or subprogram as a pseudo invocation of the target.
624 -- As a result, it performs ABE diagnostics on the pseudo call.
626 -- -gnatw.F turn off warnings for suspicious Subp'Access
628 -- The complementary switch for -gnatw.f.
630 -- -gnatwl turn on warnings for elaboration problems
632 -- The ABE mechanism produces warnings on detected ABEs along with
633 -- a traceback showing the graph of the ABE.
635 -- -gnatwL turn off warnings for elaboration problems
637 -- The complementary switch for -gnatwl.
639 --------------------------
640 -- Debugging ABE issues --
641 --------------------------
643 -- * If the issue involves a call, ensure that the call is eligible for ABE
644 -- processing and receives a corresponding call marker. The routines of
648 -- Record_Elaboration_Scenario
650 -- * If the issue involves an arbitrary scenario, ensure that the scenario
651 -- is either recorded, or is successfully recognized while traversing a
652 -- body. The routines of interest are
654 -- Record_Elaboration_Scenario
655 -- Process_Conditional_ABE
656 -- Process_Guaranteed_ABE
659 -- * If the issue involves a circularity in the elaboration order, examine
660 -- the ALI files and look for the following encodings next to units:
662 -- E indicates a source Elaborate
664 -- EA indicates a source Elaborate_All
666 -- AD indicates an implicit Elaborate_All
668 -- ED indicates an implicit Elaborate
670 -- If possible, compare these encodings with those generated by the old
671 -- ABE mechanism. The routines of interest are
673 -- Ensure_Prior_Elaboration
679 -- The following type enumerates all possible elaboration phase statutes
681 type Elaboration_Phase_Status is
683 -- The elaboration phase of the compiler has not started yet
686 -- The elaboration phase of the compiler is currently in progress
689 -- The elaboration phase of the compiler has finished
691 Elaboration_Phase : Elaboration_Phase_Status := Inactive;
692 -- The status of the elaboration phase. Use routine Set_Elaboration_Phase
693 -- to alter its value.
695 -- The following type enumerates all subprogram body traversal modes
697 type Body_Traversal_Kind is
699 -- The traversal examines the internals of a subprogram
703 -- The following type enumerates all operation modes
705 type Processing_Kind is
706 (Conditional_ABE_Processing,
707 -- The ABE mechanism detects and diagnoses conditional ABEs for library
708 -- and declaration-level scenarios.
710 Dynamic_Model_Processing,
711 -- The ABE mechanism installs conditional ABE checks for all eligible
712 -- scenarios when the dynamic model is in effect.
714 Guaranteed_ABE_Processing,
715 -- The ABE mechanism detects and diagnoses guaranteed ABEs caused by
716 -- calls, instantiations, and task activations.
718 Invocation_Construct_Processing,
719 -- The ABE mechanism locates all invocation constructs within the main
720 -- unit and utilizes them as roots of miltiple DFS traversals aimed at
721 -- detecting transitions from the main unit to an external unit.
723 Invocation_Body_Processing,
724 -- The ABE mechanism utilizes all library-level body scenarios as roots
725 -- of miltiple DFS traversals aimed at detecting transitions from the
726 -- main unit to an external unit.
728 Invocation_Spec_Processing,
729 -- The ABE mechanism utilizes all library-level spec scenarios as roots
730 -- of miltiple DFS traversals aimed at detecting transitions from the
731 -- main unit to an external unit.
734 -- The ABE mechanism detects and diagnoses violations of the SPARK
735 -- elaboration rules for SPARK-specific scenarios.
739 -- The following type enumerates all possible scenario kinds
741 type Scenario_Kind is
742 (Access_Taken_Scenario,
743 -- An attribute reference which takes 'Access or 'Unrestricted_Access of
744 -- an entry, operator, or subprogram.
747 -- A call which invokes an entry, operator, or subprogram
749 Derived_Type_Scenario,
750 -- A declaration of a derived type. This is a SPARK-specific scenario.
752 Instantiation_Scenario,
753 -- An instantiation which instantiates a generic package or subprogram.
754 -- This scenario is also subject to SPARK-specific rules.
756 Refined_State_Pragma_Scenario,
757 -- A Refined_State pragma. This is a SPARK-specific scenario.
759 Task_Activation_Scenario,
760 -- A call which activates objects of various task types
762 Variable_Assignment_Scenario,
763 -- An assignment statement which modifies the value of some variable
765 Variable_Reference_Scenario,
766 -- A reference to a variable. This is a SPARK-specific scenario.
770 -- The following type enumerates all possible consistency models of target
771 -- and scenario representations.
773 type Representation_Kind is
774 (Inconsistent_Representation,
775 -- A representation is said to be "inconsistent" when it is created from
776 -- a partially analyzed tree. In such an environment, certain attributes
777 -- such as a completing body may not be available yet.
779 Consistent_Representation,
780 -- A representation is said to be "consistent" when it is created from a
781 -- fully analyzed tree, where all attributes are available.
785 -- The following type enumerates all possible target kinds
789 -- A generic unit being instantiated
792 -- An entry, operator, or subprogram being invoked, or aliased through
793 -- 'Access or 'Unrestricted_Access.
796 -- A task being activated by an activation call
799 -- A variable being updated through an assignment statement, or read
800 -- through a variable reference.
808 procedure Destroy (NE : in out Node_Or_Entity_Id);
809 pragma Inline (Destroy);
810 -- Destroy node or entity NE
812 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type;
813 pragma Inline (Hash);
814 -- Obtain the hash value of key NE
816 -- The following is a general purpose list for nodes and entities
818 package NE_List is new Doubly_Linked_Lists
819 (Element_Type => Node_Or_Entity_Id,
821 Destroy_Element => Destroy);
823 -- The following is a general purpose map which relates nodes and entities
824 -- to lists of nodes and entities.
826 package NE_List_Map is new Dynamic_Hash_Tables
827 (Key_Type => Node_Or_Entity_Id,
828 Value_Type => NE_List.Doubly_Linked_List,
829 No_Value => NE_List.Nil,
830 Expansion_Threshold => 1.5,
831 Expansion_Factor => 2,
832 Compression_Threshold => 0.3,
833 Compression_Factor => 2,
835 Destroy_Value => NE_List.Destroy,
838 -- The following is a general purpose membership set for nodes and entities
840 package NE_Set is new Membership_Sets
841 (Element_Type => Node_Or_Entity_Id,
845 -- The following type captures relevant attributes which pertain to the
846 -- in state of the Processing phase.
848 type Processing_In_State is record
849 Processing : Processing_Kind := No_Processing;
850 -- Operation mode of the Processing phase. Once set, this value should
853 Representation : Representation_Kind := No_Representation;
854 -- Required level of scenario and target representation. Once set, this
855 -- value should not be changed.
857 Suppress_Checks : Boolean := False;
858 -- This flag is set when the Processing phase must not generate any ABE
861 Suppress_Implicit_Pragmas : Boolean := False;
862 -- This flag is set when the Processing phase must not generate any
863 -- implicit Elaborate[_All] pragmas.
865 Suppress_Info_Messages : Boolean := False;
866 -- This flag is set when the Processing phase must not emit any info
869 Suppress_Up_Level_Targets : Boolean := False;
870 -- This flag is set when the Processing phase must ignore up-level
873 Suppress_Warnings : Boolean := False;
874 -- This flag is set when the Processing phase must not emit any warnings
875 -- on elaboration problems.
877 Traversal : Body_Traversal_Kind := No_Traversal;
878 -- The subprogram body traversal mode. Once set, this value should not
881 Within_Generic : Boolean := False;
882 -- This flag is set when the Processing phase is currently within a
885 Within_Initial_Condition : Boolean := False;
886 -- This flag is set when the Processing phase is currently examining a
887 -- scenario which was reached from an initial condition procedure.
889 Within_Partial_Finalization : Boolean := False;
890 -- This flag is set when the Processing phase is currently examining a
891 -- scenario which was reached from a partial finalization procedure.
893 Within_Task_Body : Boolean := False;
894 -- This flag is set when the Processing phase is currently examining a
895 -- scenario which was reached from a task body.
898 -- The following constants define the various operational states of the
901 -- The conditional ABE state is used when processing scenarios that appear
902 -- at the declaration, instantiation, and library levels to detect errors
903 -- and install conditional ABE checks.
905 Conditional_ABE_State : constant Processing_In_State :=
906 (Processing => Conditional_ABE_Processing,
907 Representation => Consistent_Representation,
908 Traversal => Deep_Traversal,
911 -- The dynamic model state is used to install conditional ABE checks when
912 -- switch -gnatE (dynamic elaboration checking mode enabled) is in effect.
914 Dynamic_Model_State : constant Processing_In_State :=
915 (Processing => Dynamic_Model_Processing,
916 Representation => Consistent_Representation,
917 Suppress_Implicit_Pragmas => True,
918 Suppress_Info_Messages => True,
919 Suppress_Up_Level_Targets => True,
920 Suppress_Warnings => True,
921 Traversal => No_Traversal,
924 -- The guaranteed ABE state is used when processing scenarios that appear
925 -- at the declaration, instantiation, and library levels to detect errors
926 -- and install guarateed ABE failures.
928 Guaranteed_ABE_State : constant Processing_In_State :=
929 (Processing => Guaranteed_ABE_Processing,
930 Representation => Inconsistent_Representation,
931 Suppress_Implicit_Pragmas => True,
932 Traversal => No_Traversal,
935 -- The invocation body state is used when processing scenarios that appear
936 -- at the body library level to encode paths that start from elaboration
937 -- code and ultimately reach into external units.
939 Invocation_Body_State : constant Processing_In_State :=
940 (Processing => Invocation_Body_Processing,
941 Representation => Consistent_Representation,
942 Suppress_Checks => True,
943 Suppress_Implicit_Pragmas => True,
944 Suppress_Info_Messages => True,
945 Suppress_Up_Level_Targets => True,
946 Suppress_Warnings => True,
947 Traversal => Deep_Traversal,
950 -- The invocation construct state is used when processing constructs that
951 -- appear within the spec and body of the main unit and eventually reach
952 -- into external units.
954 Invocation_Construct_State : constant Processing_In_State :=
955 (Processing => Invocation_Construct_Processing,
956 Representation => Consistent_Representation,
957 Suppress_Checks => True,
958 Suppress_Implicit_Pragmas => True,
959 Suppress_Info_Messages => True,
960 Suppress_Up_Level_Targets => True,
961 Suppress_Warnings => True,
962 Traversal => Deep_Traversal,
965 -- The invocation spec state is used when processing scenarios that appear
966 -- at the spec library level to encode paths that start from elaboration
967 -- code and ultimately reach into external units.
969 Invocation_Spec_State : constant Processing_In_State :=
970 (Processing => Invocation_Spec_Processing,
971 Representation => Consistent_Representation,
972 Suppress_Checks => True,
973 Suppress_Implicit_Pragmas => True,
974 Suppress_Info_Messages => True,
975 Suppress_Up_Level_Targets => True,
976 Suppress_Warnings => True,
977 Traversal => Deep_Traversal,
980 -- The SPARK state is used when verying SPARK-specific semantics of certain
983 SPARK_State : constant Processing_In_State :=
984 (Processing => SPARK_Processing,
985 Representation => Consistent_Representation,
986 Traversal => No_Traversal,
989 -- The following type identifies a scenario representation
991 type Scenario_Rep_Id is new Natural;
993 No_Scenario_Rep : constant Scenario_Rep_Id := Scenario_Rep_Id'First;
994 First_Scenario_Rep : constant Scenario_Rep_Id := No_Scenario_Rep + 1;
996 -- The following type identifies a target representation
998 type Target_Rep_Id is new Natural;
1000 No_Target_Rep : constant Target_Rep_Id := Target_Rep_Id'First;
1001 First_Target_Rep : constant Target_Rep_Id := No_Target_Rep + 1;
1007 -- The following package keeps track of all active scenarios during a DFS
1010 package Active_Scenarios is
1016 -- The following type defines the position within the active scenario
1019 type Active_Scenario_Pos is new Natural;
1021 ---------------------
1022 -- Data structures --
1023 ---------------------
1025 -- The following table stores all active scenarios in a DFS traversal.
1026 -- This table must be maintained in a FIFO fashion.
1028 package Active_Scenario_Stack is new Table.Table
1029 (Table_Index_Type => Active_Scenario_Pos,
1030 Table_Component_Type => Node_Id,
1031 Table_Low_Bound => 1,
1032 Table_Initial => 50,
1033 Table_Increment => 200,
1034 Table_Name => "Active_Scenario_Stack");
1040 procedure Output_Active_Scenarios
1041 (Error_Nod : Node_Id;
1042 In_State : Processing_In_State);
1043 pragma Inline (Output_Active_Scenarios);
1044 -- Output the contents of the active scenario stack from earliest to
1045 -- latest to supplement an earlier error emitted for node Error_Nod.
1046 -- In_State denotes the current state of the Processing phase.
1048 procedure Pop_Active_Scenario (N : Node_Id);
1049 pragma Inline (Pop_Active_Scenario);
1050 -- Pop the top of the scenario stack. A check is made to ensure that the
1051 -- scenario being removed is the same as N.
1053 procedure Push_Active_Scenario (N : Node_Id);
1054 pragma Inline (Push_Active_Scenario);
1055 -- Push scenario N on top of the scenario stack
1057 function Root_Scenario return Node_Id;
1058 pragma Inline (Root_Scenario);
1059 -- Return the scenario which started a DFS traversal
1061 end Active_Scenarios;
1062 use Active_Scenarios;
1064 -- The following package provides the main entry point for task activation
1067 package Activation_Processor is
1073 type Activation_Processor_Ptr is access procedure
1075 Call_Rep : Scenario_Rep_Id;
1077 Obj_Rep : Target_Rep_Id;
1078 Task_Typ : Entity_Id;
1079 Task_Rep : Target_Rep_Id;
1080 In_State : Processing_In_State);
1081 -- Reference to a procedure that takes all attributes of an activation
1082 -- and performs a desired action. Call is the activation call. Call_Rep
1083 -- is the representation of the call. Obj_Id is the task object being
1084 -- activated. Obj_Rep is the representation of the object. Task_Typ is
1085 -- the task type whose body is being activated. Task_Rep denotes the
1086 -- representation of the task type. In_State is the current state of
1087 -- the Processing phase.
1093 procedure Process_Activation
1095 Call_Rep : Scenario_Rep_Id;
1096 Processor : Activation_Processor_Ptr;
1097 In_State : Processing_In_State);
1098 -- Find all task objects activated by activation call Call and invoke
1099 -- Processor on them. Call_Rep denotes the representation of the call.
1100 -- In_State is the current state of the Processing phase.
1102 end Activation_Processor;
1103 use Activation_Processor;
1105 -- The following package profides functionality for traversing subprogram
1106 -- bodies in DFS manner and processing of eligible scenarios within.
1108 package Body_Processor is
1114 type Scenario_Predicate_Ptr is access function
1115 (N : Node_Id) return Boolean;
1116 -- Reference to a function which determines whether arbitrary node N
1117 -- denotes a suitable scenario for processing.
1119 type Scenario_Processor_Ptr is access procedure
1120 (N : Node_Id; In_State : Processing_In_State);
1121 -- Reference to a procedure which processes scenario N. In_State is the
1122 -- current state of the Processing phase.
1128 procedure Traverse_Body
1130 Requires_Processing : Scenario_Predicate_Ptr;
1131 Processor : Scenario_Processor_Ptr;
1132 In_State : Processing_In_State);
1133 pragma Inline (Traverse_Body);
1134 -- Traverse the declarations and handled statements of subprogram body
1135 -- N, looking for scenarios that satisfy predicate Requires_Processing.
1136 -- Routine Processor is invoked for each such scenario.
1138 procedure Reset_Traversed_Bodies;
1139 pragma Inline (Reset_Traversed_Bodies);
1140 -- Reset the visited status of all subprogram bodies that have already
1141 -- been processed by routine Traverse_Body.
1147 procedure Finalize_Body_Processor;
1148 pragma Inline (Finalize_Body_Processor);
1149 -- Finalize all internal data structures
1151 procedure Initialize_Body_Processor;
1152 pragma Inline (Initialize_Body_Processor);
1153 -- Initialize all internal data structures
1158 -- The following package provides functionality for installing ABE-related
1159 -- checks and failures.
1161 package Check_Installer is
1167 function Check_Or_Failure_Generation_OK return Boolean;
1168 pragma Inline (Check_Or_Failure_Generation_OK);
1169 -- Determine whether a conditional ABE check or guaranteed ABE failure
1170 -- can be generated.
1172 procedure Install_Dynamic_ABE_Checks;
1173 pragma Inline (Install_Dynamic_ABE_Checks);
1174 -- Install conditional ABE checks for all saved scenarios when the
1175 -- dynamic model is in effect.
1177 procedure Install_Scenario_ABE_Check
1179 Targ_Id : Entity_Id;
1180 Targ_Rep : Target_Rep_Id;
1181 Disable : Scenario_Rep_Id);
1182 pragma Inline (Install_Scenario_ABE_Check);
1183 -- Install a conditional ABE check for scenario N to ensure that target
1184 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
1185 -- target. If the check is installed, disable the elaboration checks of
1186 -- scenario Disable.
1188 procedure Install_Scenario_ABE_Check
1190 Targ_Id : Entity_Id;
1191 Targ_Rep : Target_Rep_Id;
1192 Disable : Target_Rep_Id);
1193 pragma Inline (Install_Scenario_ABE_Check);
1194 -- Install a conditional ABE check for scenario N to ensure that target
1195 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
1196 -- target. If the check is installed, disable the elaboration checks of
1199 procedure Install_Scenario_ABE_Failure
1201 Targ_Id : Entity_Id;
1202 Targ_Rep : Target_Rep_Id;
1203 Disable : Scenario_Rep_Id);
1204 pragma Inline (Install_Scenario_ABE_Failure);
1205 -- Install a guaranteed ABE failure for scenario N with target Targ_Id.
1206 -- Targ_Rep denotes the representation of the target. If the failure is
1207 -- installed, disable the elaboration checks of scenario Disable.
1209 procedure Install_Scenario_ABE_Failure
1211 Targ_Id : Entity_Id;
1212 Targ_Rep : Target_Rep_Id;
1213 Disable : Target_Rep_Id);
1214 pragma Inline (Install_Scenario_ABE_Failure);
1215 -- Install a guaranteed ABE failure for scenario N with target Targ_Id.
1216 -- Targ_Rep denotes the representation of the target. If the failure is
1217 -- installed, disable the elaboration checks of target Disable.
1219 procedure Install_Unit_ABE_Check
1221 Unit_Id : Entity_Id;
1222 Disable : Scenario_Rep_Id);
1223 pragma Inline (Install_Unit_ABE_Check);
1224 -- Install a conditional ABE check for scenario N to ensure that unit
1225 -- Unit_Id is properly elaborated. If the check is installed, disable
1226 -- the elaboration checks of scenario Disable.
1228 procedure Install_Unit_ABE_Check
1230 Unit_Id : Entity_Id;
1231 Disable : Target_Rep_Id);
1232 pragma Inline (Install_Unit_ABE_Check);
1233 -- Install a conditional ABE check for scenario N to ensure that unit
1234 -- Unit_Id is properly elaborated. If the check is installed, disable
1235 -- the elaboration checks of target Disable.
1237 end Check_Installer;
1238 use Check_Installer;
1240 -- The following package provides the main entry point for conditional ABE
1241 -- checks and diagnostics.
1243 package Conditional_ABE_Processor is
1249 procedure Check_Conditional_ABE_Scenarios
1250 (Iter : in out NE_Set.Iterator);
1251 pragma Inline (Check_Conditional_ABE_Scenarios);
1252 -- Perform conditional ABE checks and diagnostics for all scenarios
1253 -- available through iterator Iter.
1255 procedure Process_Conditional_ABE
1257 In_State : Processing_In_State);
1258 pragma Inline (Process_Conditional_ABE);
1259 -- Perform conditional ABE checks and diagnostics for scenario N.
1260 -- In_State denotes the current state of the Processing phase.
1262 end Conditional_ABE_Processor;
1263 use Conditional_ABE_Processor;
1265 -- The following package provides functionality to emit errors, information
1266 -- messages, and warnings.
1268 package Diagnostics is
1274 procedure Elab_Msg_NE
1279 In_SPARK : Boolean);
1280 pragma Inline (Elab_Msg_NE);
1281 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary
1282 -- node N and entity. If flag Info_Msg is set, the routine emits an
1283 -- information message, otherwise it emits an error. If flag In_SPARK
1284 -- is set, then string " in SPARK" is added to the end of the message.
1288 Subp_Id : Entity_Id;
1290 In_SPARK : Boolean);
1291 pragma Inline (Info_Call);
1292 -- Output information concerning call Call that invokes subprogram
1293 -- Subp_Id. When flag Info_Msg is set, the routine emits an information
1294 -- message, otherwise it emits an error. When flag In_SPARK is set, " in
1295 -- SPARK" is added to the end of the message.
1297 procedure Info_Instantiation
1301 In_SPARK : Boolean);
1302 pragma Inline (Info_Instantiation);
1303 -- Output information concerning instantiation Inst which instantiates
1304 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an
1305 -- information message, otherwise it emits an error. If flag In_SPARK
1306 -- is set, then string " in SPARK" is added to the end of the message.
1308 procedure Info_Variable_Reference
1312 In_SPARK : Boolean);
1313 pragma Inline (Info_Variable_Reference);
1314 -- Output information concerning reference Ref which mentions variable
1315 -- Var_Id. If flag Info_Msg is set, the routine emits an information
1316 -- message, otherwise it emits an error. If flag In_SPARK is set, then
1317 -- string " in SPARK" is added to the end of the message.
1322 -- The following package provides functionality to locate the early call
1323 -- region of a subprogram body.
1325 package Early_Call_Region_Processor is
1331 function Find_Early_Call_Region
1332 (Body_Decl : Node_Id;
1333 Assume_Elab_Body : Boolean := False;
1334 Skip_Memoization : Boolean := False) return Node_Id;
1335 pragma Inline (Find_Early_Call_Region);
1336 -- Find the start of the early call region that belongs to subprogram
1337 -- body Body_Decl as defined in SPARK RM 7.7. This routine finds the
1338 -- early call region, memoizes it, and returns it, but this behavior
1339 -- can be altered. Flag Assume_Elab_Body should be set when a package
1340 -- spec may lack pragma Elaborate_Body, but the routine must still
1341 -- examine that spec. Flag Skip_Memoization should be set when the
1342 -- routine must avoid memoizing the region.
1348 procedure Finalize_Early_Call_Region_Processor;
1349 pragma Inline (Finalize_Early_Call_Region_Processor);
1350 -- Finalize all internal data structures
1352 procedure Initialize_Early_Call_Region_Processor;
1353 pragma Inline (Initialize_Early_Call_Region_Processor);
1354 -- Initialize all internal data structures
1356 end Early_Call_Region_Processor;
1357 use Early_Call_Region_Processor;
1359 -- The following package provides access to the elaboration statuses of all
1360 -- units withed by the main unit.
1362 package Elaborated_Units is
1368 procedure Collect_Elaborated_Units;
1369 pragma Inline (Collect_Elaborated_Units);
1370 -- Save the elaboration statuses of all units withed by the main unit
1372 procedure Ensure_Prior_Elaboration
1374 Unit_Id : Entity_Id;
1376 In_State : Processing_In_State);
1377 pragma Inline (Ensure_Prior_Elaboration);
1378 -- Guarantee the elaboration of unit Unit_Id with respect to the main
1379 -- unit by either suggesting or installing an Elaborate[_All] pragma
1380 -- denoted by Prag_Nam. N denotes the related scenario. In_State is the
1381 -- current state of the Processing phase.
1383 function Has_Prior_Elaboration
1384 (Unit_Id : Entity_Id;
1385 Context_OK : Boolean := False;
1386 Elab_Body_OK : Boolean := False;
1387 Same_Unit_OK : Boolean := False) return Boolean;
1388 pragma Inline (Has_Prior_Elaboration);
1389 -- Determine whether unit Unit_Id is elaborated prior to the main unit.
1390 -- If flag Context_OK is set, the routine considers the following case
1391 -- as valid prior elaboration:
1393 -- * Unit_Id is in the elaboration context of the main unit
1395 -- If flag Elab_Body_OK is set, the routine considers the following case
1396 -- as valid prior elaboration:
1398 -- * Unit_Id has pragma Elaborate_Body and is not the main unit
1400 -- If flag Same_Unit_OK is set, the routine considers the following
1401 -- cases as valid prior elaboration:
1403 -- * Unit_Id is the main unit
1405 -- * Unit_Id denotes the spec of the main unit body
1407 procedure Meet_Elaboration_Requirement
1409 Targ_Id : Entity_Id;
1411 In_State : Processing_In_State);
1412 pragma Inline (Meet_Elaboration_Requirement);
1413 -- Determine whether elaboration requirement Req_Nam for scenario N with
1414 -- target Targ_Id is met by the context of the main unit using the SPARK
1415 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an
1416 -- error if this is not the case. In_State denotes the current state of
1417 -- the Processing phase.
1423 procedure Finalize_Elaborated_Units;
1424 pragma Inline (Finalize_Elaborated_Units);
1425 -- Finalize all internal data structures
1427 procedure Initialize_Elaborated_Units;
1428 pragma Inline (Initialize_Elaborated_Units);
1429 -- Initialize all internal data structures
1431 end Elaborated_Units;
1432 use Elaborated_Units;
1434 -- The following package provides the main entry point for guaranteed ABE
1435 -- checks and diagnostics.
1437 package Guaranteed_ABE_Processor is
1443 procedure Process_Guaranteed_ABE
1445 In_State : Processing_In_State);
1446 pragma Inline (Process_Guaranteed_ABE);
1447 -- Perform guaranteed ABE checks and diagnostics for scenario N.
1448 -- In_State is the current state of the Processing phase.
1450 end Guaranteed_ABE_Processor;
1451 use Guaranteed_ABE_Processor;
1453 -- The following package provides access to the internal representation of
1454 -- scenarios and targets.
1456 package Internal_Representation is
1462 -- The following type enumerates all possible Ghost mode mode kinds
1464 type Extended_Ghost_Mode is
1466 Is_Checked_Or_Not_Specified);
1468 -- The following type enumerates all possible SPARK mode kinds
1470 type Extended_SPARK_Mode is
1472 Is_Off_Or_Not_Specified);
1478 function Scenario_Representation_Of
1480 In_State : Processing_In_State) return Scenario_Rep_Id;
1481 pragma Inline (Scenario_Representation_Of);
1482 -- Obtain the id of elaboration scenario N's representation. The routine
1483 -- constructs the representation if it is not available. In_State is the
1484 -- current state of the Processing phase.
1486 function Target_Representation_Of
1488 In_State : Processing_In_State) return Target_Rep_Id;
1489 pragma Inline (Target_Representation_Of);
1490 -- Obtain the id of elaboration target Id's representation. The routine
1491 -- constructs the representation if it is not available. In_State is the
1492 -- current state of the Processing phase.
1494 -------------------------
1495 -- Scenario attributes --
1496 -------------------------
1498 function Activated_Task_Objects
1499 (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List;
1500 pragma Inline (Activated_Task_Objects);
1501 -- For Task_Activation_Scenario S_Id, obtain the list of task objects
1502 -- the scenario is activating.
1504 function Activated_Task_Type (S_Id : Scenario_Rep_Id) return Entity_Id;
1505 pragma Inline (Activated_Task_Type);
1506 -- For Task_Activation_Scenario S_Id, obtain the currently activated
1509 procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id);
1510 pragma Inline (Disable_Elaboration_Checks);
1511 -- Disable elaboration checks of scenario S_Id
1513 function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean;
1514 pragma Inline (Elaboration_Checks_OK);
1515 -- Determine whether scenario S_Id may be subjected to elaboration
1518 function Elaboration_Warnings_OK (S_Id : Scenario_Rep_Id) return Boolean;
1519 pragma Inline (Elaboration_Warnings_OK);
1520 -- Determine whether scenario S_Id may be subjected to elaboration
1523 function Ghost_Mode_Of
1524 (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode;
1525 pragma Inline (Ghost_Mode_Of);
1526 -- Obtain the Ghost mode of scenario S_Id
1528 function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean;
1529 pragma Inline (Is_Dispatching_Call);
1530 -- For Call_Scenario S_Id, determine whether the call is dispatching
1532 function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean;
1533 pragma Inline (Is_Read_Reference);
1534 -- For Variable_Reference_Scenario S_Id, determine whether the reference
1537 function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind;
1538 pragma Inline (Kind);
1539 -- Obtain the nature of scenario S_Id
1541 function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind;
1542 pragma Inline (Level);
1543 -- Obtain the enclosing level of scenario S_Id
1545 procedure Set_Activated_Task_Objects
1546 (S_Id : Scenario_Rep_Id;
1547 Task_Objs : NE_List.Doubly_Linked_List);
1548 pragma Inline (Set_Activated_Task_Objects);
1549 -- For Task_Activation_Scenario S_Id, set the list of task objects
1550 -- activated by the scenario to Task_Objs.
1552 procedure Set_Activated_Task_Type
1553 (S_Id : Scenario_Rep_Id;
1554 Task_Typ : Entity_Id);
1555 pragma Inline (Set_Activated_Task_Type);
1556 -- For Task_Activation_Scenario S_Id, set the currently activated task
1557 -- type to Task_Typ.
1559 function SPARK_Mode_Of
1560 (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode;
1561 pragma Inline (SPARK_Mode_Of);
1562 -- Obtain the SPARK mode of scenario S_Id
1564 function Target (S_Id : Scenario_Rep_Id) return Entity_Id;
1565 pragma Inline (Target);
1566 -- Obtain the target of scenario S_Id
1568 -----------------------
1569 -- Target attributes --
1570 -----------------------
1572 function Barrier_Body_Declaration (T_Id : Target_Rep_Id) return Node_Id;
1573 pragma Inline (Barrier_Body_Declaration);
1574 -- For Subprogram_Target T_Id, obtain the declaration of the barrier
1577 function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id;
1578 pragma Inline (Body_Declaration);
1579 -- Obtain the declaration of the body which belongs to target T_Id
1581 procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id);
1582 pragma Inline (Disable_Elaboration_Checks);
1583 -- Disable elaboration checks of target T_Id
1585 function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean;
1586 pragma Inline (Elaboration_Checks_OK);
1587 -- Determine whether target T_Id may be subjected to elaboration checks
1589 function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean;
1590 pragma Inline (Elaboration_Warnings_OK);
1591 -- Determine whether target T_Id may be subjected to elaboration
1594 function Ghost_Mode_Of (T_Id : Target_Rep_Id) return Extended_Ghost_Mode;
1595 pragma Inline (Ghost_Mode_Of);
1596 -- Obtain the Ghost mode of target T_Id
1598 function Kind (T_Id : Target_Rep_Id) return Target_Kind;
1599 pragma Inline (Kind);
1600 -- Obtain the nature of target T_Id
1602 function SPARK_Mode_Of (T_Id : Target_Rep_Id) return Extended_SPARK_Mode;
1603 pragma Inline (SPARK_Mode_Of);
1604 -- Obtain the SPARK mode of target T_Id
1606 function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id;
1607 pragma Inline (Spec_Declaration);
1608 -- Obtain the declaration of the spec which belongs to target T_Id
1610 function Unit (T_Id : Target_Rep_Id) return Entity_Id;
1611 pragma Inline (Unit);
1612 -- Obtain the unit where the target is defined
1614 function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id;
1615 pragma Inline (Variable_Declaration);
1616 -- For Variable_Target T_Id, obtain the declaration of the variable
1622 procedure Finalize_Internal_Representation;
1623 pragma Inline (Finalize_Internal_Representation);
1624 -- Finalize all internal data structures
1626 procedure Initialize_Internal_Representation;
1627 pragma Inline (Initialize_Internal_Representation);
1628 -- Initialize all internal data structures
1630 end Internal_Representation;
1631 use Internal_Representation;
1633 -- The following package provides functionality for recording pieces of the
1634 -- invocation graph in the ALI file of the main unit.
1636 package Invocation_Graph is
1642 procedure Record_Invocation_Graph;
1643 pragma Inline (Record_Invocation_Graph);
1644 -- Process all declaration, instantiation, and library level scenarios,
1645 -- along with invocation construct within the spec and body of the main
1646 -- unit to determine whether any of these reach into an external unit.
1647 -- If such a path exists, encode in the ALI file of the main unit.
1653 procedure Finalize_Invocation_Graph;
1654 pragma Inline (Finalize_Invocation_Graph);
1655 -- Finalize all internal data structures
1657 procedure Initialize_Invocation_Graph;
1658 pragma Inline (Initialize_Invocation_Graph);
1659 -- Initialize all internal data structures
1661 end Invocation_Graph;
1662 use Invocation_Graph;
1664 -- The following package stores scenarios
1666 package Scenario_Storage is
1672 procedure Add_Declaration_Scenario (N : Node_Id);
1673 pragma Inline (Add_Declaration_Scenario);
1674 -- Save declaration level scenario N
1676 procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id);
1677 pragma Inline (Add_Dynamic_ABE_Check_Scenario);
1678 -- Save scenario N for conditional ABE check installation purposes when
1679 -- the dynamic model is in effect.
1681 procedure Add_Library_Body_Scenario (N : Node_Id);
1682 pragma Inline (Add_Library_Body_Scenario);
1683 -- Save library-level body scenario N
1685 procedure Add_Library_Spec_Scenario (N : Node_Id);
1686 pragma Inline (Add_Library_Spec_Scenario);
1687 -- Save library-level spec scenario N
1689 procedure Add_SPARK_Scenario (N : Node_Id);
1690 pragma Inline (Add_SPARK_Scenario);
1691 -- Save SPARK scenario N
1693 procedure Delete_Scenario (N : Node_Id);
1694 pragma Inline (Delete_Scenario);
1695 -- Delete arbitrary scenario N
1697 function Iterate_Declaration_Scenarios return NE_Set.Iterator;
1698 pragma Inline (Iterate_Declaration_Scenarios);
1699 -- Obtain an iterator over all declaration level scenarios
1701 function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator;
1702 pragma Inline (Iterate_Dynamic_ABE_Check_Scenarios);
1703 -- Obtain an iterator over all scenarios that require a conditional ABE
1704 -- check when the dynamic model is in effect.
1706 function Iterate_Library_Body_Scenarios return NE_Set.Iterator;
1707 pragma Inline (Iterate_Library_Body_Scenarios);
1708 -- Obtain an iterator over all library level body scenarios
1710 function Iterate_Library_Spec_Scenarios return NE_Set.Iterator;
1711 pragma Inline (Iterate_Library_Spec_Scenarios);
1712 -- Obtain an iterator over all library level spec scenarios
1714 function Iterate_SPARK_Scenarios return NE_Set.Iterator;
1715 pragma Inline (Iterate_SPARK_Scenarios);
1716 -- Obtain an iterator over all SPARK scenarios
1718 procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id);
1719 pragma Inline (Replace_Scenario);
1720 -- Replace scenario Old_N with scenario New_N
1726 procedure Finalize_Scenario_Storage;
1727 pragma Inline (Finalize_Scenario_Storage);
1728 -- Finalize all internal data structures
1730 procedure Initialize_Scenario_Storage;
1731 pragma Inline (Initialize_Scenario_Storage);
1732 -- Initialize all internal data structures
1734 end Scenario_Storage;
1735 use Scenario_Storage;
1737 -- The following package provides various semantic predicates
1739 package Semantics is
1745 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean;
1746 pragma Inline (Is_Accept_Alternative_Proc);
1747 -- Determine whether arbitrary entity Id denotes an internally generated
1748 -- procedure which encapsulates the statements of an accept alternative.
1750 function Is_Activation_Proc (Id : Entity_Id) return Boolean;
1751 pragma Inline (Is_Activation_Proc);
1752 -- Determine whether arbitrary entity Id denotes a runtime procedure in
1753 -- charge with activating tasks.
1755 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean;
1756 pragma Inline (Is_Ada_Semantic_Target);
1757 -- Determine whether arbitrary entity Id denodes a source or internally
1758 -- generated subprogram which emulates Ada semantics.
1760 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean;
1761 pragma Inline (Is_Assertion_Pragma_Target);
1762 -- Determine whether arbitrary entity Id denotes a procedure which
1763 -- varifies the run-time semantics of an assertion pragma.
1765 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean;
1766 pragma Inline (Is_Bodiless_Subprogram);
1767 -- Determine whether subprogram Subp_Id will never have a body
1769 function Is_Bridge_Target (Id : Entity_Id) return Boolean;
1770 pragma Inline (Is_Bridge_Target);
1771 -- Determine whether arbitrary entity Id denotes a bridge target
1773 function Is_Controlled_Proc
1774 (Subp_Id : Entity_Id;
1775 Subp_Nam : Name_Id) return Boolean;
1776 pragma Inline (Is_Controlled_Proc);
1777 -- Determine whether subprogram Subp_Id denotes controlled type
1778 -- primitives Adjust, Finalize, or Initialize as denoted by name
1781 function Is_Default_Initial_Condition_Proc
1782 (Id : Entity_Id) return Boolean;
1783 pragma Inline (Is_Default_Initial_Condition_Proc);
1784 -- Determine whether arbitrary entity Id denotes internally generated
1785 -- routine Default_Initial_Condition.
1787 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean;
1788 pragma Inline (Is_Finalizer_Proc);
1789 -- Determine whether arbitrary entity Id denotes internally generated
1790 -- routine _Finalizer.
1792 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean;
1793 pragma Inline (Is_Initial_Condition_Proc);
1794 -- Determine whether arbitrary entity Id denotes internally generated
1795 -- routine Initial_Condition.
1797 function Is_Initialized (Obj_Decl : Node_Id) return Boolean;
1798 pragma Inline (Is_Initialized);
1799 -- Determine whether object declaration Obj_Decl is initialized
1801 function Is_Invariant_Proc (Id : Entity_Id) return Boolean;
1802 pragma Inline (Is_Invariant_Proc);
1803 -- Determine whether arbitrary entity Id denotes an invariant procedure
1805 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean;
1806 pragma Inline (Is_Non_Library_Level_Encapsulator);
1807 -- Determine whether arbitrary node N is a non-library encapsulator
1809 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean;
1810 pragma Inline (Is_Partial_Invariant_Proc);
1811 -- Determine whether arbitrary entity Id denotes a partial invariant
1814 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean;
1815 pragma Inline (Is_Postconditions_Proc);
1816 -- Determine whether arbitrary entity Id denotes internally generated
1817 -- routine _Postconditions.
1819 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean;
1820 pragma Inline (Is_Preelaborated_Unit);
1821 -- Determine whether arbitrary entity Id denotes a unit which is subject
1822 -- to one of the following pragmas:
1826 -- * Remote_Call_Interface
1830 function Is_Protected_Entry (Id : Entity_Id) return Boolean;
1831 pragma Inline (Is_Protected_Entry);
1832 -- Determine whether arbitrary entity Id denotes a protected entry
1834 function Is_Protected_Subp (Id : Entity_Id) return Boolean;
1835 pragma Inline (Is_Protected_Subp);
1836 -- Determine whether entity Id denotes a protected subprogram
1838 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean;
1839 pragma Inline (Is_Protected_Body_Subp);
1840 -- Determine whether entity Id denotes the protected or unprotected
1841 -- version of a protected subprogram.
1843 function Is_Scenario (N : Node_Id) return Boolean;
1844 pragma Inline (Is_Scenario);
1845 -- Determine whether attribute node N denotes a scenario. The scenario
1846 -- may not necessarily be eligible for ABE processing.
1848 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean;
1849 pragma Inline (Is_SPARK_Semantic_Target);
1850 -- Determine whether arbitrary entity Id nodes a source or internally
1851 -- generated subprogram which emulates SPARK semantics.
1853 function Is_Subprogram_Inst (Id : Entity_Id) return Boolean;
1854 pragma Inline (Is_Subprogram_Inst);
1855 -- Determine whether arbitrary entity Id denotes a subprogram instance
1857 function Is_Suitable_Access_Taken (N : Node_Id) return Boolean;
1858 pragma Inline (Is_Suitable_Access_Taken);
1859 -- Determine whether arbitrary node N denotes a suitable attribute for
1862 function Is_Suitable_Call (N : Node_Id) return Boolean;
1863 pragma Inline (Is_Suitable_Call);
1864 -- Determine whether arbitrary node N denotes a suitable call for ABE
1867 function Is_Suitable_Instantiation (N : Node_Id) return Boolean;
1868 pragma Inline (Is_Suitable_Instantiation);
1869 -- Determine whether arbitrary node N is a suitable instantiation for
1872 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean;
1873 pragma Inline (Is_Suitable_SPARK_Derived_Type);
1874 -- Determine whether arbitrary node N denotes a suitable derived type
1875 -- declaration for ABE processing using the SPARK rules.
1877 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean;
1878 pragma Inline (Is_Suitable_SPARK_Instantiation);
1879 -- Determine whether arbitrary node N denotes a suitable instantiation
1880 -- for ABE processing using the SPARK rules.
1882 function Is_Suitable_SPARK_Refined_State_Pragma
1883 (N : Node_Id) return Boolean;
1884 pragma Inline (Is_Suitable_SPARK_Refined_State_Pragma);
1885 -- Determine whether arbitrary node N denotes a suitable Refined_State
1886 -- pragma for ABE processing using the SPARK rules.
1888 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean;
1889 pragma Inline (Is_Suitable_Variable_Assignment);
1890 -- Determine whether arbitrary node N denotes a suitable assignment for
1893 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean;
1894 pragma Inline (Is_Suitable_Variable_Reference);
1895 -- Determine whether arbitrary node N is a suitable variable reference
1896 -- for ABE processing.
1898 function Is_Task_Entry (Id : Entity_Id) return Boolean;
1899 pragma Inline (Is_Task_Entry);
1900 -- Determine whether arbitrary entity Id denotes a task entry
1902 function Is_Up_Level_Target
1903 (Targ_Decl : Node_Id;
1904 In_State : Processing_In_State) return Boolean;
1905 pragma Inline (Is_Up_Level_Target);
1906 -- Determine whether the current root resides at the declaration level.
1907 -- If this is the case, determine whether a target with by declaration
1908 -- Target_Decl is within a context which encloses the current root or is
1909 -- in a different unit. In_State is the current state of the Processing
1915 -- The following package provides the main entry point for SPARK-related
1916 -- checks and diagnostics.
1918 package SPARK_Processor is
1924 procedure Check_SPARK_Model_In_Effect;
1925 pragma Inline (Check_SPARK_Model_In_Effect);
1926 -- Determine whether a suitable elaboration model is currently in effect
1927 -- for verifying SPARK rules. Emit a warning if this is not the case.
1929 procedure Check_SPARK_Scenarios;
1930 pragma Inline (Check_SPARK_Scenarios);
1931 -- Examine SPARK scenarios which are not necessarily executable during
1932 -- elaboration, but still requires elaboration-related checks.
1934 end SPARK_Processor;
1935 use SPARK_Processor;
1937 -----------------------
1938 -- Local subprograms --
1939 -----------------------
1941 function Assignment_Target (Asmt : Node_Id) return Node_Id;
1942 pragma Inline (Assignment_Target);
1943 -- Obtain the target of assignment statement Asmt
1945 function Call_Name (Call : Node_Id) return Node_Id;
1946 pragma Inline (Call_Name);
1947 -- Obtain the name of an entry, operator, or subprogram call Call
1949 function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id;
1950 pragma Inline (Canonical_Subprogram);
1951 -- Obtain the uniform canonical entity of subprogram Subp_Id
1953 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id;
1954 pragma Inline (Compilation_Unit);
1955 -- Return the N_Compilation_Unit node of unit Unit_Id
1957 function Find_Enclosing_Instance (N : Node_Id) return Node_Id;
1958 pragma Inline (Find_Enclosing_Instance);
1959 -- Find the declaration or body of the nearest expanded instance which
1960 -- encloses arbitrary node N. Return Empty if no such instance exists.
1962 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id;
1963 pragma Inline (Find_Top_Unit);
1964 -- Return the top unit which contains arbitrary node or entity N. The unit
1965 -- is obtained by logically unwinding instantiations and subunits when N
1966 -- resides within one.
1968 function Find_Unit_Entity (N : Node_Id) return Entity_Id;
1969 pragma Inline (Find_Unit_Entity);
1970 -- Return the entity of unit N
1972 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id;
1973 pragma Inline (First_Formal_Type);
1974 -- Return the type of subprogram Subp_Id's first formal parameter. If the
1975 -- subprogram lacks formal parameters, return Empty.
1977 function Elaboration_Phase_Active return Boolean;
1978 pragma Inline (Elaboration_Phase_Active);
1979 -- Determine whether the elaboration phase of the compilation has started
1981 procedure Finalize_All_Data_Structures;
1982 pragma Inline (Finalize_All_Data_Structures);
1983 -- Destroy all internal data structures
1985 function Has_Body (Pack_Decl : Node_Id) return Boolean;
1986 pragma Inline (Has_Body);
1987 -- Determine whether package declaration Pack_Decl has a corresponding body
1988 -- or would eventually have one.
1990 function In_External_Instance
1992 Target_Decl : Node_Id) return Boolean;
1993 pragma Inline (In_External_Instance);
1994 -- Determine whether a target desctibed by its declaration Target_Decl
1995 -- resides in a package instance which is external to scenario N.
1997 function In_Main_Context (N : Node_Id) return Boolean;
1998 pragma Inline (In_Main_Context);
1999 -- Determine whether arbitrary node N appears within the main compilation
2002 function In_Same_Context
2005 Nested_OK : Boolean := False) return Boolean;
2006 pragma Inline (In_Same_Context);
2007 -- Determine whether two arbitrary nodes N1 and N2 appear within the same
2008 -- context ignoring enclosing library levels. Nested_OK should be set when
2009 -- the context of N1 can enclose that of N2.
2011 procedure Initialize_All_Data_Structures;
2012 pragma Inline (Initialize_All_Data_Structures);
2013 -- Create all internal data structures
2015 function Instantiated_Generic (Inst : Node_Id) return Entity_Id;
2016 pragma Inline (Instantiated_Generic);
2017 -- Obtain the generic instantiated by instance Inst
2019 function Is_Safe_Activation
2021 Task_Rep : Target_Rep_Id) return Boolean;
2022 pragma Inline (Is_Safe_Activation);
2023 -- Determine whether activation call Call which activates an object of a
2024 -- task type described by representation Task_Rep is always ABE-safe.
2026 function Is_Safe_Call
2028 Subp_Id : Entity_Id;
2029 Subp_Rep : Target_Rep_Id) return Boolean;
2030 pragma Inline (Is_Safe_Call);
2031 -- Determine whether call Call which invokes entry, operator, or subprogram
2032 -- Subp_Id is always ABE-safe. Subp_Rep is the representation of the entry,
2033 -- operator, or subprogram.
2035 function Is_Safe_Instantiation
2038 Gen_Rep : Target_Rep_Id) return Boolean;
2039 pragma Inline (Is_Safe_Instantiation);
2040 -- Determine whether instantiation Inst which instantiates generic Gen_Id
2041 -- is always ABE-safe. Gen_Rep is the representation of the generic.
2043 function Is_Same_Unit
2044 (Unit_1 : Entity_Id;
2045 Unit_2 : Entity_Id) return Boolean;
2046 pragma Inline (Is_Same_Unit);
2047 -- Determine whether entities Unit_1 and Unit_2 denote the same unit
2049 function Non_Private_View (Typ : Entity_Id) return Entity_Id;
2050 pragma Inline (Non_Private_View);
2051 -- Return the full view of private type Typ if available, otherwise return
2054 function Scenario (N : Node_Id) return Node_Id;
2055 pragma Inline (Scenario);
2056 -- Return the appropriate scenario node for scenario N
2058 procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status);
2059 pragma Inline (Set_Elaboration_Phase);
2060 -- Change the status of the elaboration phase of the compiler to Status
2062 procedure Spec_And_Body_From_Entity
2064 Spec_Decl : out Node_Id;
2065 Body_Decl : out Node_Id);
2066 pragma Inline (Spec_And_Body_From_Entity);
2067 -- Given arbitrary entity Id representing a construct with a spec and body,
2068 -- retrieve declaration of the spec in Spec_Decl and the declaration of the
2069 -- body in Body_Decl.
2071 procedure Spec_And_Body_From_Node
2073 Spec_Decl : out Node_Id;
2074 Body_Decl : out Node_Id);
2075 pragma Inline (Spec_And_Body_From_Node);
2076 -- Given arbitrary node N representing a construct with a spec and body,
2077 -- retrieve declaration of the spec in Spec_Decl and the declaration of
2078 -- the body in Body_Decl.
2080 function Static_Elaboration_Checks return Boolean;
2081 pragma Inline (Static_Elaboration_Checks);
2082 -- Determine whether the static model is in effect
2084 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id;
2085 pragma Inline (Unit_Entity);
2086 -- Return the entity of the initial declaration for unit Unit_Id
2088 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id);
2089 pragma Inline (Update_Elaboration_Scenario);
2090 -- Update all relevant internal data structures when scenario Old_N is
2091 -- transformed into scenario New_N by Atree.Rewrite.
2093 ----------------------
2094 -- Active_Scenarios --
2095 ----------------------
2097 package body Active_Scenarios is
2099 -----------------------
2100 -- Local subprograms --
2101 -----------------------
2103 procedure Output_Access_Taken
2105 Attr_Rep : Scenario_Rep_Id;
2106 Error_Nod : Node_Id);
2107 pragma Inline (Output_Access_Taken);
2108 -- Emit a specific diagnostic message for 'Access attribute reference
2109 -- Attr with representation Attr_Rep. The message is associated with
2112 procedure Output_Active_Scenario
2114 Error_Nod : Node_Id;
2115 In_State : Processing_In_State);
2116 pragma Inline (Output_Active_Scenario);
2117 -- Top level dispatcher for outputting a scenario. Emit a specific
2118 -- diagnostic message for scenario N. The message is associated with
2119 -- node Error_Nod. In_State is the current state of the Processing
2122 procedure Output_Call
2124 Call_Rep : Scenario_Rep_Id;
2125 Error_Nod : Node_Id);
2126 pragma Inline (Output_Call);
2127 -- Emit a diagnostic message for call Call with representation Call_Rep.
2128 -- The message is associated with node Error_Nod.
2130 procedure Output_Header (Error_Nod : Node_Id);
2131 pragma Inline (Output_Header);
2132 -- Emit a specific diagnostic message for the unit of the root scenario.
2133 -- The message is associated with node Error_Nod.
2135 procedure Output_Instantiation
2137 Inst_Rep : Scenario_Rep_Id;
2138 Error_Nod : Node_Id);
2139 pragma Inline (Output_Instantiation);
2140 -- Emit a specific diagnostic message for instantiation Inst with
2141 -- representation Inst_Rep. The message is associated with node
2144 procedure Output_Refined_State_Pragma
2146 Prag_Rep : Scenario_Rep_Id;
2147 Error_Nod : Node_Id);
2148 pragma Inline (Output_Refined_State_Pragma);
2149 -- Emit a specific diagnostic message for Refined_State pragma Prag
2150 -- with representation Prag_Rep. The message is associated with node
2153 procedure Output_Task_Activation
2155 Call_Rep : Scenario_Rep_Id;
2156 Error_Nod : Node_Id);
2157 pragma Inline (Output_Task_Activation);
2158 -- Emit a specific diagnostic message for activation call Call
2159 -- with representation Call_Rep. The message is associated with
2162 procedure Output_Variable_Assignment
2164 Asmt_Rep : Scenario_Rep_Id;
2165 Error_Nod : Node_Id);
2166 pragma Inline (Output_Variable_Assignment);
2167 -- Emit a specific diagnostic message for assignment statement Asmt
2168 -- with representation Asmt_Rep. The message is associated with node
2171 procedure Output_Variable_Reference
2173 Ref_Rep : Scenario_Rep_Id;
2174 Error_Nod : Node_Id);
2175 pragma Inline (Output_Variable_Reference);
2176 -- Emit a specific diagnostic message for read reference Ref with
2177 -- representation Ref_Rep. The message is associated with node
2184 procedure Output_Access_Taken
2186 Attr_Rep : Scenario_Rep_Id;
2187 Error_Nod : Node_Id)
2189 Subp_Id : constant Entity_Id := Target (Attr_Rep);
2192 Error_Msg_Name_1 := Attribute_Name (Attr);
2193 Error_Msg_Sloc := Sloc (Attr);
2194 Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id);
2195 end Output_Access_Taken;
2197 ----------------------------
2198 -- Output_Active_Scenario --
2199 ----------------------------
2201 procedure Output_Active_Scenario
2203 Error_Nod : Node_Id;
2204 In_State : Processing_In_State)
2206 Scen : constant Node_Id := Scenario (N);
2207 Scen_Rep : Scenario_Rep_Id;
2212 if Is_Suitable_Access_Taken (Scen) then
2215 Attr_Rep => Scenario_Representation_Of (Scen, In_State),
2216 Error_Nod => Error_Nod);
2218 -- Call or task activation
2220 elsif Is_Suitable_Call (Scen) then
2221 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
2223 if Kind (Scen_Rep) = Call_Scenario then
2226 Call_Rep => Scen_Rep,
2227 Error_Nod => Error_Nod);
2230 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario);
2232 Output_Task_Activation
2234 Call_Rep => Scen_Rep,
2235 Error_Nod => Error_Nod);
2240 elsif Is_Suitable_Instantiation (Scen) then
2241 Output_Instantiation
2243 Inst_Rep => Scenario_Representation_Of (Scen, In_State),
2244 Error_Nod => Error_Nod);
2246 -- Pragma Refined_State
2248 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then
2249 Output_Refined_State_Pragma
2251 Prag_Rep => Scenario_Representation_Of (Scen, In_State),
2252 Error_Nod => Error_Nod);
2254 -- Variable assignment
2256 elsif Is_Suitable_Variable_Assignment (Scen) then
2257 Output_Variable_Assignment
2259 Asmt_Rep => Scenario_Representation_Of (Scen, In_State),
2260 Error_Nod => Error_Nod);
2262 -- Variable reference
2264 elsif Is_Suitable_Variable_Reference (Scen) then
2265 Output_Variable_Reference
2267 Ref_Rep => Scenario_Representation_Of (Scen, In_State),
2268 Error_Nod => Error_Nod);
2270 end Output_Active_Scenario;
2272 -----------------------------
2273 -- Output_Active_Scenarios --
2274 -----------------------------
2276 procedure Output_Active_Scenarios
2277 (Error_Nod : Node_Id;
2278 In_State : Processing_In_State)
2280 package Scenarios renames Active_Scenario_Stack;
2282 Header_Posted : Boolean := False;
2285 -- Output the contents of the active scenario stack starting from the
2286 -- bottom, or the least recent scenario.
2288 for Index in Scenarios.First .. Scenarios.Last loop
2289 if not Header_Posted then
2290 Output_Header (Error_Nod);
2291 Header_Posted := True;
2294 Output_Active_Scenario
2295 (N => Scenarios.Table (Index),
2296 Error_Nod => Error_Nod,
2297 In_State => In_State);
2299 end Output_Active_Scenarios;
2305 procedure Output_Call
2307 Call_Rep : Scenario_Rep_Id;
2308 Error_Nod : Node_Id)
2310 procedure Output_Accept_Alternative (Alt_Id : Entity_Id);
2311 pragma Inline (Output_Accept_Alternative);
2312 -- Emit a specific diagnostic message concerning accept alternative
2313 -- with entity Alt_Id.
2315 procedure Output_Call (Subp_Id : Entity_Id; Kind : String);
2316 pragma Inline (Output_Call);
2317 -- Emit a specific diagnostic message concerning a call of kind Kind
2318 -- which invokes subprogram Subp_Id.
2320 procedure Output_Type_Actions (Subp_Id : Entity_Id; Action : String);
2321 pragma Inline (Output_Type_Actions);
2322 -- Emit a specific diagnostic message concerning action Action of a
2323 -- type performed by subprogram Subp_Id.
2325 procedure Output_Verification_Call
2329 pragma Inline (Output_Verification_Call);
2330 -- Emit a specific diagnostic message concerning the verification of
2331 -- predicate Pred applied to related entity Id with kind Id_Kind.
2333 -------------------------------
2334 -- Output_Accept_Alternative --
2335 -------------------------------
2337 procedure Output_Accept_Alternative (Alt_Id : Entity_Id) is
2338 Entry_Id : constant Entity_Id := Receiving_Entry (Alt_Id);
2341 pragma Assert (Present (Entry_Id));
2343 Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id);
2344 end Output_Accept_Alternative;
2350 procedure Output_Call (Subp_Id : Entity_Id; Kind : String) is
2352 Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Subp_Id);
2355 -------------------------
2356 -- Output_Type_Actions --
2357 -------------------------
2359 procedure Output_Type_Actions
2360 (Subp_Id : Entity_Id;
2363 Typ : constant Entity_Id := First_Formal_Type (Subp_Id);
2366 pragma Assert (Present (Typ));
2369 ("\\ " & Action & " actions for type & #", Error_Nod, Typ);
2370 end Output_Type_Actions;
2372 ------------------------------
2373 -- Output_Verification_Call --
2374 ------------------------------
2376 procedure Output_Verification_Call
2382 pragma Assert (Present (Id));
2385 ("\\ " & Pred & " of " & Id_Kind & " & verified #",
2387 end Output_Verification_Call;
2391 Subp_Id : constant Entity_Id := Target (Call_Rep);
2393 -- Start of processing for Output_Call
2396 Error_Msg_Sloc := Sloc (Call);
2398 -- Accept alternative
2400 if Is_Accept_Alternative_Proc (Subp_Id) then
2401 Output_Accept_Alternative (Subp_Id);
2405 elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then
2406 Output_Type_Actions (Subp_Id, "adjustment");
2408 -- Default_Initial_Condition
2410 elsif Is_Default_Initial_Condition_Proc (Subp_Id) then
2411 Output_Verification_Call
2412 (Pred => "Default_Initial_Condition",
2413 Id => First_Formal_Type (Subp_Id),
2418 elsif Is_Protected_Entry (Subp_Id) then
2419 Output_Call (Subp_Id, "entry");
2421 -- Task entry calls are never processed because the entry being
2422 -- invoked does not have a corresponding "body", it has a select. A
2423 -- task entry call appears in the stack of active scenarios for the
2424 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
2427 elsif Is_Task_Entry (Subp_Id) then
2432 elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then
2433 Output_Type_Actions (Subp_Id, "finalization");
2435 -- Calls to _Finalizer procedures must not appear in the output
2436 -- because this creates confusing noise.
2438 elsif Is_Finalizer_Proc (Subp_Id) then
2441 -- Initial_Condition
2443 elsif Is_Initial_Condition_Proc (Subp_Id) then
2444 Output_Verification_Call
2445 (Pred => "Initial_Condition",
2446 Id => Find_Enclosing_Scope (Call),
2447 Id_Kind => "package");
2451 elsif Is_Init_Proc (Subp_Id)
2452 or else Is_TSS (Subp_Id, TSS_Deep_Initialize)
2454 Output_Type_Actions (Subp_Id, "initialization");
2458 elsif Is_Invariant_Proc (Subp_Id) then
2459 Output_Verification_Call
2460 (Pred => "invariants",
2461 Id => First_Formal_Type (Subp_Id),
2464 -- Partial invariant calls must not appear in the output because this
2465 -- creates confusing noise. Note that a partial invariant is always
2466 -- invoked by the "full" invariant which is already placed on the
2469 elsif Is_Partial_Invariant_Proc (Subp_Id) then
2474 elsif Is_Postconditions_Proc (Subp_Id) then
2475 Output_Verification_Call
2476 (Pred => "postconditions",
2477 Id => Find_Enclosing_Scope (Call),
2478 Id_Kind => "subprogram");
2480 -- Subprograms must come last because some of the previous cases fall
2481 -- under this category.
2483 elsif Ekind (Subp_Id) = E_Function then
2484 Output_Call (Subp_Id, "function");
2486 elsif Ekind (Subp_Id) = E_Procedure then
2487 Output_Call (Subp_Id, "procedure");
2490 pragma Assert (False);
2499 procedure Output_Header (Error_Nod : Node_Id) is
2500 Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario);
2503 if Ekind (Unit_Id) = E_Package then
2504 Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id);
2506 elsif Ekind (Unit_Id) = E_Package_Body then
2507 Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id);
2510 Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id);
2514 --------------------------
2515 -- Output_Instantiation --
2516 --------------------------
2518 procedure Output_Instantiation
2520 Inst_Rep : Scenario_Rep_Id;
2521 Error_Nod : Node_Id)
2523 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String);
2524 pragma Inline (Output_Instantiation);
2525 -- Emit a specific diagnostic message concerning an instantiation of
2526 -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
2528 --------------------------
2529 -- Output_Instantiation --
2530 --------------------------
2532 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is
2535 ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id);
2536 end Output_Instantiation;
2540 Gen_Id : constant Entity_Id := Target (Inst_Rep);
2542 -- Start of processing for Output_Instantiation
2545 Error_Msg_Node_2 := Defining_Entity (Inst);
2546 Error_Msg_Sloc := Sloc (Inst);
2548 if Nkind (Inst) = N_Function_Instantiation then
2549 Output_Instantiation (Gen_Id, "function");
2551 elsif Nkind (Inst) = N_Package_Instantiation then
2552 Output_Instantiation (Gen_Id, "package");
2554 elsif Nkind (Inst) = N_Procedure_Instantiation then
2555 Output_Instantiation (Gen_Id, "procedure");
2558 pragma Assert (False);
2561 end Output_Instantiation;
2563 ---------------------------------
2564 -- Output_Refined_State_Pragma --
2565 ---------------------------------
2567 procedure Output_Refined_State_Pragma
2569 Prag_Rep : Scenario_Rep_Id;
2570 Error_Nod : Node_Id)
2572 pragma Unreferenced (Prag_Rep);
2575 Error_Msg_Sloc := Sloc (Prag);
2576 Error_Msg_N ("\\ refinement constituents read #", Error_Nod);
2577 end Output_Refined_State_Pragma;
2579 ----------------------------
2580 -- Output_Task_Activation --
2581 ----------------------------
2583 procedure Output_Task_Activation
2585 Call_Rep : Scenario_Rep_Id;
2586 Error_Nod : Node_Id)
2588 pragma Unreferenced (Call_Rep);
2590 function Find_Activator return Entity_Id;
2591 -- Find the nearest enclosing construct which houses call Call
2593 --------------------
2594 -- Find_Activator --
2595 --------------------
2597 function Find_Activator return Entity_Id is
2601 -- Climb the parent chain looking for a package [body] or a
2602 -- construct with a statement sequence.
2604 Par := Parent (Call);
2605 while Present (Par) loop
2606 if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then
2607 return Defining_Entity (Par);
2609 elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then
2610 return Defining_Entity (Parent (Par));
2613 Par := Parent (Par);
2621 Activator : constant Entity_Id := Find_Activator;
2623 -- Start of processing for Output_Task_Activation
2626 pragma Assert (Present (Activator));
2628 Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator);
2629 end Output_Task_Activation;
2631 --------------------------------
2632 -- Output_Variable_Assignment --
2633 --------------------------------
2635 procedure Output_Variable_Assignment
2637 Asmt_Rep : Scenario_Rep_Id;
2638 Error_Nod : Node_Id)
2640 Var_Id : constant Entity_Id := Target (Asmt_Rep);
2643 Error_Msg_Sloc := Sloc (Asmt);
2644 Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id);
2645 end Output_Variable_Assignment;
2647 -------------------------------
2648 -- Output_Variable_Reference --
2649 -------------------------------
2651 procedure Output_Variable_Reference
2653 Ref_Rep : Scenario_Rep_Id;
2654 Error_Nod : Node_Id)
2656 Var_Id : constant Entity_Id := Target (Ref_Rep);
2659 Error_Msg_Sloc := Sloc (Ref);
2660 Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id);
2661 end Output_Variable_Reference;
2663 -------------------------
2664 -- Pop_Active_Scenario --
2665 -------------------------
2667 procedure Pop_Active_Scenario (N : Node_Id) is
2668 package Scenarios renames Active_Scenario_Stack;
2669 Top : Node_Id renames Scenarios.Table (Scenarios.Last);
2672 pragma Assert (Top = N);
2673 Scenarios.Decrement_Last;
2674 end Pop_Active_Scenario;
2676 --------------------------
2677 -- Push_Active_Scenario --
2678 --------------------------
2680 procedure Push_Active_Scenario (N : Node_Id) is
2682 Active_Scenario_Stack.Append (N);
2683 end Push_Active_Scenario;
2689 function Root_Scenario return Node_Id is
2690 package Scenarios renames Active_Scenario_Stack;
2693 -- Ensure that the scenario stack has at least one active scenario in
2694 -- it. The one at the bottom (index First) is the root scenario.
2696 pragma Assert (Scenarios.Last >= Scenarios.First);
2697 return Scenarios.Table (Scenarios.First);
2699 end Active_Scenarios;
2701 --------------------------
2702 -- Activation_Processor --
2703 --------------------------
2705 package body Activation_Processor is
2707 ------------------------
2708 -- Process_Activation --
2709 ------------------------
2711 procedure Process_Activation
2713 Call_Rep : Scenario_Rep_Id;
2714 Processor : Activation_Processor_Ptr;
2715 In_State : Processing_In_State)
2717 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id);
2718 pragma Inline (Process_Task_Object);
2719 -- Invoke Processor for task object Obj_Id of type Typ
2721 procedure Process_Task_Objects
2722 (Task_Objs : NE_List.Doubly_Linked_List);
2723 pragma Inline (Process_Task_Objects);
2724 -- Invoke Processor for all task objects found in list Task_Objs
2726 procedure Traverse_List
2728 Task_Objs : NE_List.Doubly_Linked_List);
2729 pragma Inline (Traverse_List);
2730 -- Traverse declarative or statement list List while searching for
2731 -- objects of a task type, or containing task components. If such an
2732 -- object is found, first save it in list Task_Objs and then invoke
2735 -------------------------
2736 -- Process_Task_Object --
2737 -------------------------
2739 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is
2740 Root_Typ : constant Entity_Id :=
2741 Non_Private_View (Root_Type (Typ));
2742 Comp_Id : Entity_Id;
2743 Obj_Rep : Target_Rep_Id;
2744 Root_Rep : Target_Rep_Id;
2746 New_In_State : Processing_In_State := In_State;
2747 -- Each step of the Processing phase constitutes a new state
2750 if Is_Task_Type (Typ) then
2751 Obj_Rep := Target_Representation_Of (Obj_Id, New_In_State);
2752 Root_Rep := Target_Representation_Of (Root_Typ, New_In_State);
2754 -- Warnings are suppressed when a prior scenario is already in
2755 -- that mode, or when the object, activation call, or task type
2756 -- have warnings suppressed. Update the state of the Processing
2757 -- phase to reflect this.
2759 New_In_State.Suppress_Warnings :=
2760 New_In_State.Suppress_Warnings
2761 or else not Elaboration_Warnings_OK (Call_Rep)
2762 or else not Elaboration_Warnings_OK (Obj_Rep)
2763 or else not Elaboration_Warnings_OK (Root_Rep);
2765 -- Update the state of the Processing phase to indicate that
2766 -- any further traversal is now within a task body.
2768 New_In_State.Within_Task_Body := True;
2770 -- Associate the current task type with the activation call
2772 Set_Activated_Task_Type (Call_Rep, Root_Typ);
2774 -- Process the activation of the current task object by calling
2775 -- the supplied processor.
2779 Call_Rep => Call_Rep,
2782 Task_Typ => Root_Typ,
2783 Task_Rep => Root_Rep,
2784 In_State => New_In_State);
2786 -- Reset the association between the current task and the
2789 Set_Activated_Task_Type (Call_Rep, Empty);
2791 -- Examine the component type when the object is an array
2793 elsif Is_Array_Type (Typ) and then Has_Task (Root_Typ) then
2796 Typ => Component_Type (Typ));
2798 -- Examine individual component types when the object is a record
2800 elsif Is_Record_Type (Typ) and then Has_Task (Root_Typ) then
2801 Comp_Id := First_Component (Typ);
2802 while Present (Comp_Id) loop
2805 Typ => Etype (Comp_Id));
2807 Next_Component (Comp_Id);
2810 end Process_Task_Object;
2812 --------------------------
2813 -- Process_Task_Objects --
2814 --------------------------
2816 procedure Process_Task_Objects
2817 (Task_Objs : NE_List.Doubly_Linked_List)
2819 Iter : NE_List.Iterator;
2823 Iter := NE_List.Iterate (Task_Objs);
2824 while NE_List.Has_Next (Iter) loop
2825 NE_List.Next (Iter, Obj_Id);
2829 Typ => Etype (Obj_Id));
2831 end Process_Task_Objects;
2837 procedure Traverse_List
2839 Task_Objs : NE_List.Doubly_Linked_List)
2842 Item_Id : Entity_Id;
2843 Item_Typ : Entity_Id;
2846 -- Examine the contents of the list looking for an object
2847 -- declaration of a task type or one that contains a task
2850 Item := First (List);
2851 while Present (Item) loop
2852 if Nkind (Item) = N_Object_Declaration then
2853 Item_Id := Defining_Entity (Item);
2854 Item_Typ := Etype (Item_Id);
2856 if Has_Task (Item_Typ) then
2858 -- The object is either of a task type, or contains a
2859 -- task component. Save it in the list of task objects
2860 -- associated with the activation call.
2862 NE_List.Append (Task_Objs, Item_Id);
2878 Task_Objs : NE_List.Doubly_Linked_List;
2880 -- Start of processing for Process_Activation
2883 -- Nothing to do when the activation is a guaranteed ABE
2885 if Is_Known_Guaranteed_ABE (Call) then
2889 Task_Objs := Activated_Task_Objects (Call_Rep);
2891 -- The activation call has been processed at least once, and all
2892 -- task objects have already been collected. Directly process the
2893 -- objects without having to reexamine the context of the call.
2895 if NE_List.Present (Task_Objs) then
2896 Process_Task_Objects (Task_Objs);
2898 -- Otherwise the activation call is being processed for the first
2899 -- time. Collect all task objects in case the call is reprocessed
2903 Task_Objs := NE_List.Create;
2904 Set_Activated_Task_Objects (Call_Rep, Task_Objs);
2906 -- Find the context of the activation call where all task objects
2907 -- being activated are declared. This is usually the parent of the
2910 Context := Parent (Call);
2912 -- Handle the case where the activation call appears within the
2913 -- handled statements of a block or a body.
2915 if Nkind (Context) = N_Handled_Sequence_Of_Statements then
2916 Context := Parent (Context);
2919 -- Process all task objects in both the spec and body when the
2920 -- activation call appears in a package body.
2922 if Nkind (Context) = N_Package_Body then
2925 (Unit_Declaration_Node (Corresponding_Spec (Context)));
2928 (List => Visible_Declarations (Spec),
2929 Task_Objs => Task_Objs);
2932 (List => Private_Declarations (Spec),
2933 Task_Objs => Task_Objs);
2936 (List => Declarations (Context),
2937 Task_Objs => Task_Objs);
2939 -- Process all task objects in the spec when the activation call
2940 -- appears in a package spec.
2942 elsif Nkind (Context) = N_Package_Specification then
2944 (List => Visible_Declarations (Context),
2945 Task_Objs => Task_Objs);
2948 (List => Private_Declarations (Context),
2949 Task_Objs => Task_Objs);
2951 -- Otherwise the context must be a block or a body. Process all
2952 -- task objects found in the declarations.
2955 pragma Assert (Nkind_In (Context, N_Block_Statement,
2962 (List => Declarations (Context),
2963 Task_Objs => Task_Objs);
2966 end Process_Activation;
2967 end Activation_Processor;
2969 -----------------------
2970 -- Assignment_Target --
2971 -----------------------
2973 function Assignment_Target (Asmt : Node_Id) return Node_Id is
2979 -- When the name denotes an array or record component, find the whole
2982 while Nkind_In (Nam, N_Explicit_Dereference,
2983 N_Indexed_Component,
2984 N_Selected_Component,
2987 Nam := Prefix (Nam);
2991 end Assignment_Target;
2993 --------------------
2994 -- Body_Processor --
2995 --------------------
2997 package body Body_Processor is
2999 ---------------------
3000 -- Data structures --
3001 ---------------------
3003 -- The following map relates scenario lists to subprogram bodies
3005 Nested_Scenarios_Map : NE_List_Map.Dynamic_Hash_Table := NE_List_Map.Nil;
3007 -- The following set contains all subprogram bodies that have been
3008 -- processed by routine Traverse_Body.
3010 Traversed_Bodies_Set : NE_Set.Membership_Set := NE_Set.Nil;
3012 -----------------------
3013 -- Local subprograms --
3014 -----------------------
3016 function Is_Traversed_Body (N : Node_Id) return Boolean;
3017 pragma Inline (Is_Traversed_Body);
3018 -- Determine whether subprogram body N has already been traversed
3020 function Nested_Scenarios
3021 (N : Node_Id) return NE_List.Doubly_Linked_List;
3022 pragma Inline (Nested_Scenarios);
3023 -- Obtain the list of scenarios associated with subprogram body N
3025 procedure Set_Is_Traversed_Body
3027 Val : Boolean := True);
3028 pragma Inline (Set_Is_Traversed_Body);
3029 -- Mark subprogram body N as traversed depending on value Val
3031 procedure Set_Nested_Scenarios
3033 Scenarios : NE_List.Doubly_Linked_List);
3034 pragma Inline (Set_Nested_Scenarios);
3035 -- Associate scenario list Scenarios with subprogram body N
3037 -----------------------------
3038 -- Finalize_Body_Processor --
3039 -----------------------------
3041 procedure Finalize_Body_Processor is
3043 NE_List_Map.Destroy (Nested_Scenarios_Map);
3044 NE_Set.Destroy (Traversed_Bodies_Set);
3045 end Finalize_Body_Processor;
3047 -------------------------------
3048 -- Initialize_Body_Processor --
3049 -------------------------------
3051 procedure Initialize_Body_Processor is
3053 Nested_Scenarios_Map := NE_List_Map.Create (250);
3054 Traversed_Bodies_Set := NE_Set.Create (250);
3055 end Initialize_Body_Processor;
3057 -----------------------
3058 -- Is_Traversed_Body --
3059 -----------------------
3061 function Is_Traversed_Body (N : Node_Id) return Boolean is
3062 pragma Assert (Present (N));
3064 return NE_Set.Contains (Traversed_Bodies_Set, N);
3065 end Is_Traversed_Body;
3067 ----------------------
3068 -- Nested_Scenarios --
3069 ----------------------
3071 function Nested_Scenarios
3072 (N : Node_Id) return NE_List.Doubly_Linked_List
3074 pragma Assert (Present (N));
3075 pragma Assert (Nkind (N) = N_Subprogram_Body);
3078 return NE_List_Map.Get (Nested_Scenarios_Map, N);
3079 end Nested_Scenarios;
3081 ----------------------------
3082 -- Reset_Traversed_Bodies --
3083 ----------------------------
3085 procedure Reset_Traversed_Bodies is
3087 NE_Set.Reset (Traversed_Bodies_Set);
3088 end Reset_Traversed_Bodies;
3090 ---------------------------
3091 -- Set_Is_Traversed_Body --
3092 ---------------------------
3094 procedure Set_Is_Traversed_Body
3096 Val : Boolean := True)
3098 pragma Assert (Present (N));
3102 NE_Set.Insert (Traversed_Bodies_Set, N);
3104 NE_Set.Delete (Traversed_Bodies_Set, N);
3106 end Set_Is_Traversed_Body;
3108 --------------------------
3109 -- Set_Nested_Scenarios --
3110 --------------------------
3112 procedure Set_Nested_Scenarios
3114 Scenarios : NE_List.Doubly_Linked_List)
3116 pragma Assert (Present (N));
3118 NE_List_Map.Put (Nested_Scenarios_Map, N, Scenarios);
3119 end Set_Nested_Scenarios;
3125 procedure Traverse_Body
3127 Requires_Processing : Scenario_Predicate_Ptr;
3128 Processor : Scenario_Processor_Ptr;
3129 In_State : Processing_In_State)
3131 Scenarios : NE_List.Doubly_Linked_List := NE_List.Nil;
3132 -- The list of scenarios that appear within the declarations and
3133 -- statement of subprogram body N. The variable is intentionally
3134 -- global because Is_Potential_Scenario needs to populate it.
3136 function In_Task_Body (Nod : Node_Id) return Boolean;
3137 pragma Inline (In_Task_Body);
3138 -- Determine whether arbitrary node Nod appears within a task body
3140 function Is_Synchronous_Suspension_Call
3141 (Nod : Node_Id) return Boolean;
3142 pragma Inline (Is_Synchronous_Suspension_Call);
3143 -- Determine whether arbitrary node Nod denotes a call to one of
3146 -- Ada.Synchronous_Barriers.Wait_For_Release
3147 -- Ada.Synchronous_Task_Control.Suspend_Until_True
3149 procedure Traverse_Collected_Scenarios;
3150 pragma Inline (Traverse_Collected_Scenarios);
3151 -- Traverse the already collected scenarios in list Scenarios by
3152 -- invoking Processor on each individual one.
3154 procedure Traverse_List (List : List_Id);
3155 pragma Inline (Traverse_List);
3156 -- Invoke Traverse_Potential_Scenarios on each node in list List
3158 function Traverse_Potential_Scenario
3159 (Scen : Node_Id) return Traverse_Result;
3160 pragma Inline (Traverse_Potential_Scenario);
3161 -- Determine whether arbitrary node Scen is a suitable scenario using
3162 -- predicate Is_Scenario and traverse it by invoking Processor on it.
3164 procedure Traverse_Potential_Scenarios is
3165 new Traverse_Proc (Traverse_Potential_Scenario);
3171 function In_Task_Body (Nod : Node_Id) return Boolean is
3175 -- Climb the parent chain looking for a task body [procedure]
3178 while Present (Par) loop
3179 if Nkind (Par) = N_Task_Body then
3182 elsif Nkind (Par) = N_Subprogram_Body
3183 and then Is_Task_Body_Procedure (Par)
3187 -- Prevent the search from going too far. Note that this test
3188 -- shares nodes with the two cases above, and must come last.
3190 elsif Is_Body_Or_Package_Declaration (Par) then
3194 Par := Parent (Par);
3200 ------------------------------------
3201 -- Is_Synchronous_Suspension_Call --
3202 ------------------------------------
3204 function Is_Synchronous_Suspension_Call
3205 (Nod : Node_Id) return Boolean
3207 Subp_Id : Entity_Id;
3210 -- To qualify, the call must invoke one of the runtime routines
3211 -- which perform synchronous suspension.
3213 if Is_Suitable_Call (Nod) then
3214 Subp_Id := Target (Nod);
3217 Is_RTE (Subp_Id, RE_Suspend_Until_True)
3219 Is_RTE (Subp_Id, RE_Wait_For_Release);
3223 end Is_Synchronous_Suspension_Call;
3225 ----------------------------------
3226 -- Traverse_Collected_Scenarios --
3227 ----------------------------------
3229 procedure Traverse_Collected_Scenarios is
3230 Iter : NE_List.Iterator;
3234 Iter := NE_List.Iterate (Scenarios);
3235 while NE_List.Has_Next (Iter) loop
3236 NE_List.Next (Iter, Scen);
3238 -- The current scenario satisfies the input predicate, process
3241 if Requires_Processing.all (Scen) then
3242 Processor.all (Scen, In_State);
3245 end Traverse_Collected_Scenarios;
3251 procedure Traverse_List (List : List_Id) is
3255 Scen := First (List);
3256 while Present (Scen) loop
3257 Traverse_Potential_Scenarios (Scen);
3262 ---------------------------------
3263 -- Traverse_Potential_Scenario --
3264 ---------------------------------
3266 function Traverse_Potential_Scenario
3267 (Scen : Node_Id) return Traverse_Result
3272 -- Skip constructs which do not have elaboration of their own and
3273 -- need to be elaborated by other means such as invocation, task
3276 if Is_Non_Library_Level_Encapsulator (Scen) then
3279 -- Terminate the traversal of a task body when encountering an
3280 -- accept or select statement, and
3282 -- * Entry calls during elaboration are not allowed. In this
3283 -- case the accept or select statement will cause the task
3284 -- to block at elaboration time because there are no entry
3285 -- calls to unblock it.
3289 -- * Switch -gnatd_a (stop elaboration checks on accept or
3290 -- select statement) is in effect.
3292 elsif (Debug_Flag_Underscore_A
3293 or else Restriction_Active
3294 (No_Entry_Calls_In_Elaboration_Code))
3295 and then Nkind_In (Original_Node (Scen), N_Accept_Statement,
3300 -- Terminate the traversal of a task body when encountering a
3301 -- suspension call, and
3303 -- * Entry calls during elaboration are not allowed. In this
3304 -- case the suspension call emulates an entry call and will
3305 -- cause the task to block at elaboration time.
3309 -- * Switch -gnatd_s (stop elaboration checks on synchronous
3310 -- suspension) is in effect.
3312 -- Note that the guard should not be checking the state of flag
3313 -- Within_Task_Body because only suspension calls which appear
3314 -- immediately within the statements of the task are supported.
3315 -- Flag Within_Task_Body carries over to deeper levels of the
3318 elsif (Debug_Flag_Underscore_S
3319 or else Restriction_Active
3320 (No_Entry_Calls_In_Elaboration_Code))
3321 and then Is_Synchronous_Suspension_Call (Scen)
3322 and then In_Task_Body (Scen)
3326 -- Certain nodes carry semantic lists which act as repositories
3327 -- until expansion transforms the node and relocates the contents.
3328 -- Examine these lists in case expansion is disabled.
3330 elsif Nkind_In (Scen, N_And_Then, N_Or_Else) then
3331 Traverse_List (Actions (Scen));
3333 elsif Nkind_In (Scen, N_Elsif_Part, N_Iteration_Scheme) then
3334 Traverse_List (Condition_Actions (Scen));
3336 elsif Nkind (Scen) = N_If_Expression then
3337 Traverse_List (Then_Actions (Scen));
3338 Traverse_List (Else_Actions (Scen));
3340 elsif Nkind_In (Scen, N_Component_Association,
3341 N_Iterated_Component_Association)
3343 Traverse_List (Loop_Actions (Scen));
3347 -- The current node satisfies the input predicate, process it
3349 elsif Requires_Processing.all (Scen) then
3350 Processor.all (Scen, In_State);
3353 -- Save a general scenario regardless of whether it satisfies the
3354 -- input predicate. This allows for quick subsequent traversals of
3355 -- general scenarios, even with different predicates.
3357 if Is_Suitable_Access_Taken (Scen)
3358 or else Is_Suitable_Call (Scen)
3359 or else Is_Suitable_Instantiation (Scen)
3360 or else Is_Suitable_Variable_Assignment (Scen)
3361 or else Is_Suitable_Variable_Reference (Scen)
3363 NE_List.Append (Scenarios, Scen);
3367 end Traverse_Potential_Scenario;
3369 -- Start of processing for Traverse_Body
3372 -- Nothing to do when the traversal is suppressed
3374 if In_State.Traversal = No_Traversal then
3377 -- Nothing to do when there is no input
3382 -- Nothing to do when the input is not a subprogram body
3384 elsif Nkind (N) /= N_Subprogram_Body then
3387 -- Nothing to do if the subprogram body was already traversed
3389 elsif Is_Traversed_Body (N) then
3393 -- Mark the subprogram body as traversed
3395 Set_Is_Traversed_Body (N);
3397 Scenarios := Nested_Scenarios (N);
3399 -- The subprogram body has been traversed at least once, and all
3400 -- scenarios that appear within its declarations and statements
3401 -- have already been collected. Directly retraverse the scenarios
3402 -- without having to retraverse the subprogram body subtree.
3404 if NE_List.Present (Scenarios) then
3405 Traverse_Collected_Scenarios;
3407 -- Otherwise the subprogram body is being traversed for the first
3408 -- time. Collect all scenarios that appear within its declarations
3409 -- and statements in case the subprogram body has to be retraversed
3413 Scenarios := NE_List.Create;
3414 Set_Nested_Scenarios (N, Scenarios);
3416 Traverse_List (Declarations (N));
3417 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N));
3422 -----------------------
3423 -- Build_Call_Marker --
3424 -----------------------
3426 procedure Build_Call_Marker (N : Node_Id) is
3427 function In_External_Context
3429 Subp_Id : Entity_Id) return Boolean;
3430 pragma Inline (In_External_Context);
3431 -- Determine whether entry, operator, or subprogram Subp_Id is external
3432 -- to call Call which must reside within an instance.
3434 function In_Premature_Context (Call : Node_Id) return Boolean;
3435 pragma Inline (In_Premature_Context);
3436 -- Determine whether call Call appears within a premature context
3438 function Is_Default_Expression (Call : Node_Id) return Boolean;
3439 pragma Inline (Is_Default_Expression);
3440 -- Determine whether call Call acts as the expression of a defaulted
3441 -- parameter within a source call.
3443 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean;
3444 pragma Inline (Is_Generic_Formal_Subp);
3445 -- Determine whether subprogram Subp_Id denotes a generic formal
3446 -- subprogram which appears in the "prologue" of an instantiation.
3448 -------------------------
3449 -- In_External_Context --
3450 -------------------------
3452 function In_External_Context
3454 Subp_Id : Entity_Id) return Boolean
3456 Spec_Decl : constant Entity_Id := Unit_Declaration_Node (Subp_Id);
3459 Inst_Body : Node_Id;
3460 Inst_Spec : Node_Id;
3463 Inst := Find_Enclosing_Instance (Call);
3465 -- The call appears within an instance
3467 if Present (Inst) then
3469 -- The call comes from the main unit and the target does not
3471 if In_Extended_Main_Code_Unit (Call)
3472 and then not In_Extended_Main_Code_Unit (Spec_Decl)
3476 -- Otherwise the target declaration must not appear within the
3477 -- instance spec or body.
3480 Spec_And_Body_From_Node
3482 Spec_Decl => Inst_Spec,
3483 Body_Decl => Inst_Body);
3485 return not In_Subtree
3488 Root2 => Inst_Body);
3493 end In_External_Context;
3495 --------------------------
3496 -- In_Premature_Context --
3497 --------------------------
3499 function In_Premature_Context (Call : Node_Id) return Boolean is
3503 -- Climb the parent chain looking for premature contexts
3505 Par := Parent (Call);
3506 while Present (Par) loop
3508 -- Aspect specifications and generic associations are premature
3509 -- contexts because nested calls has not been relocated to their
3512 if Nkind_In (Par, N_Aspect_Specification,
3513 N_Generic_Association)
3517 -- Prevent the search from going too far
3519 elsif Is_Body_Or_Package_Declaration (Par) then
3523 Par := Parent (Par);
3527 end In_Premature_Context;
3529 ---------------------------
3530 -- Is_Default_Expression --
3531 ---------------------------
3533 function Is_Default_Expression (Call : Node_Id) return Boolean is
3534 Outer_Call : constant Node_Id := Parent (Call);
3535 Outer_Nam : Node_Id;
3538 -- To qualify, the node must appear immediately within a source call
3539 -- which invokes a source target.
3541 if Nkind_In (Outer_Call, N_Entry_Call_Statement,
3543 N_Procedure_Call_Statement)
3544 and then Comes_From_Source (Outer_Call)
3546 Outer_Nam := Call_Name (Outer_Call);
3549 Is_Entity_Name (Outer_Nam)
3550 and then Present (Entity (Outer_Nam))
3551 and then Is_Subprogram_Or_Entry (Entity (Outer_Nam))
3552 and then Comes_From_Source (Entity (Outer_Nam));
3556 end Is_Default_Expression;
3558 ----------------------------
3559 -- Is_Generic_Formal_Subp --
3560 ----------------------------
3562 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is
3563 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
3564 Context : constant Node_Id := Parent (Subp_Decl);
3567 -- To qualify, the subprogram must rename a generic actual subprogram
3568 -- where the enclosing context is an instantiation.
3571 Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
3572 and then not Comes_From_Source (Subp_Decl)
3573 and then Nkind_In (Context, N_Function_Specification,
3574 N_Package_Specification,
3575 N_Procedure_Specification)
3576 and then Present (Generic_Parent (Context));
3577 end Is_Generic_Formal_Subp;
3583 Subp_Id : Entity_Id;
3585 -- Start of processing for Build_Call_Marker
3588 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
3589 -- enabled) is in effect because the legacy ABE mechanism does not need
3590 -- to carry out this action.
3592 if Legacy_Elaboration_Checks then
3595 -- Nothing to do for ASIS because ABE checks and diagnostics are not
3596 -- performed in this mode.
3598 elsif ASIS_Mode then
3601 -- Nothing to do when the call is being preanalyzed as the marker will
3602 -- be inserted in the wrong place.
3604 elsif Preanalysis_Active then
3607 -- Nothing to do when the elaboration phase of the compiler is not
3610 elsif not Elaboration_Phase_Active then
3613 -- Nothing to do when the input does not denote a call or a requeue
3615 elsif not Nkind_In (N, N_Entry_Call_Statement,
3617 N_Procedure_Call_Statement,
3618 N_Requeue_Statement)
3622 -- Nothing to do when the input denotes entry call or requeue statement,
3623 -- and switch -gnatd_e (ignore entry calls and requeue statements for
3624 -- elaboration) is in effect.
3626 elsif Debug_Flag_Underscore_E
3627 and then Nkind_In (N, N_Entry_Call_Statement, N_Requeue_Statement)
3631 -- Nothing to do when the call is analyzed/resolved too early within an
3632 -- intermediate context. This check is saved for last because it incurs
3633 -- a performance penalty.
3635 elsif In_Premature_Context (N) then
3639 Call_Nam := Call_Name (N);
3641 -- Nothing to do when the call is erroneous or left in a bad state
3643 if not (Is_Entity_Name (Call_Nam)
3644 and then Present (Entity (Call_Nam))
3645 and then Is_Subprogram_Or_Entry (Entity (Call_Nam)))
3650 Subp_Id := Canonical_Subprogram (Entity (Call_Nam));
3652 -- Nothing to do when the call invokes a generic formal subprogram and
3653 -- switch -gnatd.G (ignore calls through generic formal parameters for
3654 -- elaboration) is in effect. This check must be performed with the
3655 -- direct target of the call to avoid the side effects of mapping
3656 -- actuals to formals using renamings.
3658 if Debug_Flag_Dot_GG
3659 and then Is_Generic_Formal_Subp (Entity (Call_Nam))
3663 -- Nothing to do when the call appears within the expanded spec or
3664 -- body of an instantiated generic, the call does not invoke a generic
3665 -- formal subprogram, the target is external to the instance, and switch
3666 -- -gnatdL (ignore external calls from instances for elaboration) is in
3667 -- effect. This check must be performed with the direct target of the
3668 -- call to avoid the side effects of mapping actuals to formals using
3672 and then not Is_Generic_Formal_Subp (Entity (Call_Nam))
3673 and then In_External_Context
3679 -- Nothing to do when the call invokes an assertion pragma procedure
3680 -- and switch -gnatd_p (ignore assertion pragmas for elaboration) is
3683 elsif Debug_Flag_Underscore_P
3684 and then Is_Assertion_Pragma_Target (Subp_Id)
3688 -- Source calls to source targets are always considered because they
3689 -- reflect the original call graph.
3691 elsif Comes_From_Source (N) and then Comes_From_Source (Subp_Id) then
3694 -- A call to a source function which acts as the default expression in
3695 -- another call requires special detection.
3697 elsif Comes_From_Source (Subp_Id)
3698 and then Nkind (N) = N_Function_Call
3699 and then Is_Default_Expression (N)
3703 -- The target emulates Ada semantics
3705 elsif Is_Ada_Semantic_Target (Subp_Id) then
3708 -- The target acts as a link between scenarios
3710 elsif Is_Bridge_Target (Subp_Id) then
3713 -- The target emulates SPARK semantics
3715 elsif Is_SPARK_Semantic_Target (Subp_Id) then
3718 -- Otherwise the call is not suitable for ABE processing. This prevents
3719 -- the generation of call markers which will never play a role in ABE
3726 -- At this point it is known that the call will play some role in ABE
3727 -- checks and diagnostics. Create a corresponding call marker in case
3728 -- the original call is heavily transformed by expansion later on.
3730 Marker := Make_Call_Marker (Sloc (N));
3732 -- Inherit the attributes of the original call
3734 Set_Is_Declaration_Level_Node
3735 (Marker, Find_Enclosing_Level (N) = Declaration_Level);
3737 Set_Is_Dispatching_Call
3738 (Marker, Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
3739 and then Present (Controlling_Argument (N)));
3741 Set_Is_Elaboration_Checks_OK_Node
3742 (Marker, Is_Elaboration_Checks_OK_Node (N));
3744 Set_Is_Elaboration_Warnings_OK_Node
3745 (Marker, Is_Elaboration_Warnings_OK_Node (N));
3747 Set_Is_Ignored_Ghost_Node (Marker, Is_Ignored_Ghost_Node (N));
3748 Set_Is_Source_Call (Marker, Comes_From_Source (N));
3749 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N));
3750 Set_Target (Marker, Subp_Id);
3752 -- The marker is inserted prior to the original call. This placement has
3753 -- several desirable effects:
3755 -- 1) The marker appears in the same context, in close proximity to
3761 -- 2) Inserting the marker prior to the call ensures that an ABE check
3762 -- will take effect prior to the call.
3768 -- 3) The above two properties are preserved even when the call is a
3769 -- function which is subsequently relocated in order to capture its
3770 -- result. Note that if the call is relocated to a new context, the
3771 -- relocated call will receive a marker of its own.
3775 -- Temp : ... := Func_Call ...;
3778 -- The insertion must take place even when the call does not occur in
3779 -- the main unit to keep the tree symmetric. This ensures that internal
3780 -- name serialization is consistent in case the call marker causes the
3781 -- tree to transform in some way.
3783 Insert_Action (N, Marker);
3785 -- The marker becomes the "corresponding" scenario for the call. Save
3786 -- the marker for later processing by the ABE phase.
3788 Record_Elaboration_Scenario (Marker);
3789 end Build_Call_Marker;
3791 -------------------------------------
3792 -- Build_Variable_Reference_Marker --
3793 -------------------------------------
3795 procedure Build_Variable_Reference_Marker
3800 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id;
3801 pragma Inline (Ultimate_Variable);
3802 -- Obtain the ultimate renamed variable of variable Var_Id
3804 -----------------------
3805 -- Ultimate_Variable --
3806 -----------------------
3808 function Ultimate_Variable (Var_Id : Entity_Id) return Entity_Id is
3813 while Present (Renamed_Entity (Ren_Id))
3814 and then Nkind (Renamed_Entity (Ren_Id)) in N_Entity
3816 Ren_Id := Renamed_Entity (Ren_Id);
3820 end Ultimate_Variable;
3824 Var_Id : constant Entity_Id := Ultimate_Variable (Entity (N));
3827 -- Start of processing for Build_Variable_Reference_Marker
3830 -- Nothing to do when the elaboration phase of the compiler is not
3833 if not Elaboration_Phase_Active then
3837 Marker := Make_Variable_Reference_Marker (Sloc (N));
3839 -- Inherit the attributes of the original variable reference
3841 Set_Is_Elaboration_Checks_OK_Node
3842 (Marker, Is_Elaboration_Checks_OK_Node (N));
3844 Set_Is_Elaboration_Warnings_OK_Node
3845 (Marker, Is_Elaboration_Warnings_OK_Node (N));
3847 Set_Is_Read (Marker, Read);
3848 Set_Is_SPARK_Mode_On_Node (Marker, Is_SPARK_Mode_On_Node (N));
3849 Set_Is_Write (Marker, Write);
3850 Set_Target (Marker, Var_Id);
3852 -- The marker is inserted prior to the original variable reference. The
3853 -- insertion must take place even when the reference does not occur in
3854 -- the main unit to keep the tree symmetric. This ensures that internal
3855 -- name serialization is consistent in case the variable marker causes
3856 -- the tree to transform in some way.
3858 Insert_Action (N, Marker);
3860 -- The marker becomes the "corresponding" scenario for the reference.
3861 -- Save the marker for later processing for the ABE phase.
3863 Record_Elaboration_Scenario (Marker);
3864 end Build_Variable_Reference_Marker;
3870 function Call_Name (Call : Node_Id) return Node_Id is
3876 -- When the call invokes an entry family, the name appears as an indexed
3879 if Nkind (Nam) = N_Indexed_Component then
3880 Nam := Prefix (Nam);
3883 -- When the call employs the object.operation form, the name appears as
3884 -- a selected component.
3886 if Nkind (Nam) = N_Selected_Component then
3887 Nam := Selector_Name (Nam);
3893 --------------------------
3894 -- Canonical_Subprogram --
3895 --------------------------
3897 function Canonical_Subprogram (Subp_Id : Entity_Id) return Entity_Id is
3898 Canon_Id : Entity_Id;
3901 Canon_Id := Subp_Id;
3903 -- Use the original protected subprogram when dealing with one of the
3904 -- specialized lock-manipulating versions.
3906 if Is_Protected_Body_Subp (Canon_Id) then
3907 Canon_Id := Protected_Subprogram (Canon_Id);
3910 -- Obtain the original subprogram except when the subprogram is also
3911 -- an instantiation. In this case the alias is the internally generated
3912 -- subprogram which appears within the anonymous package created for the
3913 -- instantiation, making it unuitable.
3915 if not Is_Generic_Instance (Canon_Id) then
3916 Canon_Id := Get_Renamed_Entity (Canon_Id);
3920 end Canonical_Subprogram;
3922 ---------------------------------
3923 -- Check_Elaboration_Scenarios --
3924 ---------------------------------
3926 procedure Check_Elaboration_Scenarios is
3927 Iter : NE_Set.Iterator;
3930 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
3931 -- enabled) is in effect because the legacy ABE mechanism does not need
3932 -- to carry out this action.
3934 if Legacy_Elaboration_Checks then
3935 Finalize_All_Data_Structures;
3938 -- Nothing to do for ASIS because ABE checks and diagnostics are not
3939 -- performed in this mode.
3941 elsif ASIS_Mode then
3942 Finalize_All_Data_Structures;
3945 -- Nothing to do when the elaboration phase of the compiler is not
3948 elsif not Elaboration_Phase_Active then
3949 Finalize_All_Data_Structures;
3953 -- Restore the original elaboration model which was in effect when the
3954 -- scenarios were first recorded. The model may be specified by pragma
3955 -- Elaboration_Checks which appears on the initial declaration of the
3958 Install_Elaboration_Model (Unit_Entity (Cunit_Entity (Main_Unit)));
3960 -- Examine the context of the main unit and record all units with prior
3961 -- elaboration with respect to it.
3963 Collect_Elaborated_Units;
3965 -- Examine all scenarios saved during the Recording phase applying the
3966 -- Ada or SPARK elaboration rules in order to detect and diagnose ABE
3967 -- issues, install conditional ABE checks, and ensure the elaboration
3970 Iter := Iterate_Declaration_Scenarios;
3971 Check_Conditional_ABE_Scenarios (Iter);
3973 Iter := Iterate_Library_Body_Scenarios;
3974 Check_Conditional_ABE_Scenarios (Iter);
3976 Iter := Iterate_Library_Spec_Scenarios;
3977 Check_Conditional_ABE_Scenarios (Iter);
3979 -- Examine each SPARK scenario saved during the Recording phase which
3980 -- is not necessarily executable during elaboration, but still requires
3981 -- elaboration-related checks.
3983 Check_SPARK_Scenarios;
3985 -- Add conditional ABE checks for all scenarios that require one when
3986 -- the dynamic model is in effect.
3988 Install_Dynamic_ABE_Checks;
3990 -- Examine all scenarios saved during the Recording phase along with
3991 -- invocation constructs within the spec and body of the main unit.
3992 -- Record the declarations and paths that reach into an external unit
3993 -- in the ALI file of the main unit.
3995 Record_Invocation_Graph;
3997 -- Destroy all internal data structures and complete the elaboration
3998 -- phase of the compiler.
4000 Finalize_All_Data_Structures;
4001 Set_Elaboration_Phase (Completed);
4002 end Check_Elaboration_Scenarios;
4004 ---------------------
4005 -- Check_Installer --
4006 ---------------------
4008 package body Check_Installer is
4010 -----------------------
4011 -- Local subprograms --
4012 -----------------------
4014 function ABE_Check_Or_Failure_OK
4016 Targ_Id : Entity_Id;
4017 Unit_Id : Entity_Id) return Boolean;
4018 pragma Inline (ABE_Check_Or_Failure_OK);
4019 -- Determine whether a conditional ABE check or guaranteed ABE failure
4020 -- can be installed for scenario N with target Targ_Id which resides in
4023 function Insertion_Node (N : Node_Id) return Node_Id;
4024 pragma Inline (Insertion_Node);
4025 -- Obtain the proper insertion node of an ABE check or failure for
4028 procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id);
4029 pragma Inline (Insert_ABE_Check_Or_Failure);
4030 -- Insert conditional ABE check or guaranteed ABE failure Check prior to
4033 procedure Install_Scenario_ABE_Check_Common
4035 Targ_Id : Entity_Id;
4036 Targ_Rep : Target_Rep_Id);
4037 pragma Inline (Install_Scenario_ABE_Check_Common);
4038 -- Install a conditional ABE check for scenario N to ensure that target
4039 -- Targ_Id is properly elaborated. Targ_Rep is the representation of the
4042 procedure Install_Scenario_ABE_Failure_Common (N : Node_Id);
4043 pragma Inline (Install_Scenario_ABE_Failure_Common);
4044 -- Install a guaranteed ABE failure for scenario N
4046 procedure Install_Unit_ABE_Check_Common
4048 Unit_Id : Entity_Id);
4049 pragma Inline (Install_Unit_ABE_Check_Common);
4050 -- Install a conditional ABE check for scenario N to ensure that unit
4051 -- Unit_Id is properly elaborated.
4053 -----------------------------
4054 -- ABE_Check_Or_Failure_OK --
4055 -----------------------------
4057 function ABE_Check_Or_Failure_OK
4059 Targ_Id : Entity_Id;
4060 Unit_Id : Entity_Id) return Boolean
4062 pragma Unreferenced (Targ_Id);
4064 Ins_Node : constant Node_Id := Insertion_Node (N);
4067 if not Check_Or_Failure_Generation_OK then
4070 -- Nothing to do when the scenario denots a compilation unit because
4071 -- there is no executable environment at that level.
4073 elsif Nkind (Parent (Ins_Node)) = N_Compilation_Unit then
4076 -- An ABE check or failure is not needed when the target is defined
4077 -- in a unit which is elaborated prior to the main unit. This check
4078 -- must also consider the following cases:
4080 -- * The unit of the target appears in the context of the main unit
4082 -- * The unit of the target is subject to pragma Elaborate_Body. An
4083 -- ABE check MUST NOT be generated because the unit is always
4084 -- elaborated prior to the main unit.
4086 -- * The unit of the target is the main unit. An ABE check MUST be
4087 -- added in this case because a conditional ABE may be raised
4088 -- depending on the flow of execution within the main unit (flag
4089 -- Same_Unit_OK is False).
4091 elsif Has_Prior_Elaboration
4092 (Unit_Id => Unit_Id,
4094 Elab_Body_OK => True)
4100 end ABE_Check_Or_Failure_OK;
4102 ------------------------------------
4103 -- Check_Or_Failure_Generation_OK --
4104 ------------------------------------
4106 function Check_Or_Failure_Generation_OK return Boolean is
4108 -- An ABE check or failure is not needed when the compilation will
4109 -- not produce an executable.
4111 if Serious_Errors_Detected > 0 then
4114 -- An ABE check or failure must not be installed when compiling for
4115 -- GNATprove because raise statements are not supported.
4117 elsif GNATprove_Mode then
4122 end Check_Or_Failure_Generation_OK;
4124 --------------------
4125 -- Insertion_Node --
4126 --------------------
4128 function Insertion_Node (N : Node_Id) return Node_Id is
4130 -- When the scenario denotes an instantiation, the proper insertion
4131 -- node is the instance spec. This ensures that the generic actuals
4132 -- will not be evaluated prior to a potential ABE.
4134 if Nkind (N) in N_Generic_Instantiation
4135 and then Present (Instance_Spec (N))
4137 return Instance_Spec (N);
4139 -- Otherwise the proper insertion node is the scenario itself
4146 ---------------------------------
4147 -- Insert_ABE_Check_Or_Failure --
4148 ---------------------------------
4150 procedure Insert_ABE_Check_Or_Failure (N : Node_Id; Check : Node_Id) is
4151 Ins_Nod : constant Node_Id := Insertion_Node (N);
4152 Scop_Id : constant Entity_Id := Find_Enclosing_Scope (Ins_Nod);
4155 -- Install the nearest enclosing scope of the scenario as there must
4156 -- be something on the scope stack.
4158 Push_Scope (Scop_Id);
4160 Insert_Action (Ins_Nod, Check);
4163 end Insert_ABE_Check_Or_Failure;
4165 --------------------------------
4166 -- Install_Dynamic_ABE_Checks --
4167 --------------------------------
4169 procedure Install_Dynamic_ABE_Checks is
4170 Iter : NE_Set.Iterator;
4174 if not Check_Or_Failure_Generation_OK then
4177 -- Nothing to do if the dynamic model is not in effect
4179 elsif not Dynamic_Elaboration_Checks then
4183 -- Install a conditional ABE check for each saved scenario
4185 Iter := Iterate_Dynamic_ABE_Check_Scenarios;
4186 while NE_Set.Has_Next (Iter) loop
4187 NE_Set.Next (Iter, N);
4189 Process_Conditional_ABE
4191 In_State => Dynamic_Model_State);
4193 end Install_Dynamic_ABE_Checks;
4195 --------------------------------
4196 -- Install_Scenario_ABE_Check --
4197 --------------------------------
4199 procedure Install_Scenario_ABE_Check
4201 Targ_Id : Entity_Id;
4202 Targ_Rep : Target_Rep_Id;
4203 Disable : Scenario_Rep_Id)
4206 -- Nothing to do when the scenario does not need an ABE check
4208 if not ABE_Check_Or_Failure_OK
4211 Unit_Id => Unit (Targ_Rep))
4216 -- Prevent multiple attempts to install the same ABE check
4218 Disable_Elaboration_Checks (Disable);
4220 Install_Scenario_ABE_Check_Common
4223 Targ_Rep => Targ_Rep);
4224 end Install_Scenario_ABE_Check;
4226 --------------------------------
4227 -- Install_Scenario_ABE_Check --
4228 --------------------------------
4230 procedure Install_Scenario_ABE_Check
4232 Targ_Id : Entity_Id;
4233 Targ_Rep : Target_Rep_Id;
4234 Disable : Target_Rep_Id)
4237 -- Nothing to do when the scenario does not need an ABE check
4239 if not ABE_Check_Or_Failure_OK
4242 Unit_Id => Unit (Targ_Rep))
4247 -- Prevent multiple attempts to install the same ABE check
4249 Disable_Elaboration_Checks (Disable);
4251 Install_Scenario_ABE_Check_Common
4254 Targ_Rep => Targ_Rep);
4255 end Install_Scenario_ABE_Check;
4257 ---------------------------------------
4258 -- Install_Scenario_ABE_Check_Common --
4259 ---------------------------------------
4261 procedure Install_Scenario_ABE_Check_Common
4263 Targ_Id : Entity_Id;
4264 Targ_Rep : Target_Rep_Id)
4266 Targ_Body : constant Node_Id := Body_Declaration (Targ_Rep);
4267 Targ_Decl : constant Node_Id := Spec_Declaration (Targ_Rep);
4269 pragma Assert (Present (Targ_Body));
4270 pragma Assert (Present (Targ_Decl));
4272 procedure Build_Elaboration_Entity;
4273 pragma Inline (Build_Elaboration_Entity);
4274 -- Create a new elaboration flag for Targ_Id, insert it prior to
4275 -- Targ_Decl, and set it after Targ_Body.
4277 ------------------------------
4278 -- Build_Elaboration_Entity --
4279 ------------------------------
4281 procedure Build_Elaboration_Entity is
4282 Loc : constant Source_Ptr := Sloc (Targ_Id);
4283 Flag_Id : Entity_Id;
4286 -- Nothing to do if the target has an elaboration flag
4288 if Present (Elaboration_Entity (Targ_Id)) then
4292 -- Create the declaration of the elaboration flag. The name
4293 -- carries a unique counter in case the name is overloaded.
4296 Make_Defining_Identifier (Loc,
4297 Chars => New_External_Name (Chars (Targ_Id), 'E', -1));
4299 Set_Elaboration_Entity (Targ_Id, Flag_Id);
4300 Set_Elaboration_Entity_Required (Targ_Id);
4302 Push_Scope (Scope (Targ_Id));
4305 -- Enn : Short_Integer := 0;
4307 Insert_Action (Targ_Decl,
4308 Make_Object_Declaration (Loc,
4309 Defining_Identifier => Flag_Id,
4310 Object_Definition =>
4311 New_Occurrence_Of (Standard_Short_Integer, Loc),
4312 Expression => Make_Integer_Literal (Loc, Uint_0)));
4317 Set_Elaboration_Flag (Targ_Body, Targ_Id);
4320 end Build_Elaboration_Entity;
4324 Loc : constant Source_Ptr := Sloc (N);
4326 -- Start for processing for Install_Scenario_ABE_Check_Common
4329 -- Create an elaboration flag for the target when it does not have
4332 Build_Elaboration_Entity;
4335 -- if not Targ_Id'Elaborated then
4336 -- raise Program_Error with "access before elaboration";
4339 Insert_ABE_Check_Or_Failure
4342 Make_Raise_Program_Error (Loc,
4346 Make_Attribute_Reference (Loc,
4347 Prefix => New_Occurrence_Of (Targ_Id, Loc),
4348 Attribute_Name => Name_Elaborated)),
4349 Reason => PE_Access_Before_Elaboration));
4350 end Install_Scenario_ABE_Check_Common;
4352 ----------------------------------
4353 -- Install_Scenario_ABE_Failure --
4354 ----------------------------------
4356 procedure Install_Scenario_ABE_Failure
4358 Targ_Id : Entity_Id;
4359 Targ_Rep : Target_Rep_Id;
4360 Disable : Scenario_Rep_Id)
4363 -- Nothing to do when the scenario does not require an ABE failure
4365 if not ABE_Check_Or_Failure_OK
4368 Unit_Id => Unit (Targ_Rep))
4373 -- Prevent multiple attempts to install the same ABE check
4375 Disable_Elaboration_Checks (Disable);
4377 Install_Scenario_ABE_Failure_Common (N);
4378 end Install_Scenario_ABE_Failure;
4380 ----------------------------------
4381 -- Install_Scenario_ABE_Failure --
4382 ----------------------------------
4384 procedure Install_Scenario_ABE_Failure
4386 Targ_Id : Entity_Id;
4387 Targ_Rep : Target_Rep_Id;
4388 Disable : Target_Rep_Id)
4391 -- Nothing to do when the scenario does not require an ABE failure
4393 if not ABE_Check_Or_Failure_OK
4396 Unit_Id => Unit (Targ_Rep))
4401 -- Prevent multiple attempts to install the same ABE check
4403 Disable_Elaboration_Checks (Disable);
4405 Install_Scenario_ABE_Failure_Common (N);
4406 end Install_Scenario_ABE_Failure;
4408 -----------------------------------------
4409 -- Install_Scenario_ABE_Failure_Common --
4410 -----------------------------------------
4412 procedure Install_Scenario_ABE_Failure_Common (N : Node_Id) is
4413 Loc : constant Source_Ptr := Sloc (N);
4417 -- raise Program_Error with "access before elaboration";
4419 Insert_ABE_Check_Or_Failure
4422 Make_Raise_Program_Error (Loc,
4423 Reason => PE_Access_Before_Elaboration));
4424 end Install_Scenario_ABE_Failure_Common;
4426 ----------------------------
4427 -- Install_Unit_ABE_Check --
4428 ----------------------------
4430 procedure Install_Unit_ABE_Check
4432 Unit_Id : Entity_Id;
4433 Disable : Scenario_Rep_Id)
4435 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id);
4438 -- Nothing to do when the scenario does not require an ABE check
4440 if not ABE_Check_Or_Failure_OK
4448 -- Prevent multiple attempts to install the same ABE check
4450 Disable_Elaboration_Checks (Disable);
4452 Install_Unit_ABE_Check_Common
4454 Unit_Id => Unit_Id);
4455 end Install_Unit_ABE_Check;
4457 ----------------------------
4458 -- Install_Unit_ABE_Check --
4459 ----------------------------
4461 procedure Install_Unit_ABE_Check
4463 Unit_Id : Entity_Id;
4464 Disable : Target_Rep_Id)
4466 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id);
4469 -- Nothing to do when the scenario does not require an ABE check
4471 if not ABE_Check_Or_Failure_OK
4479 -- Prevent multiple attempts to install the same ABE check
4481 Disable_Elaboration_Checks (Disable);
4483 Install_Unit_ABE_Check_Common
4485 Unit_Id => Unit_Id);
4486 end Install_Unit_ABE_Check;
4488 -----------------------------------
4489 -- Install_Unit_ABE_Check_Common --
4490 -----------------------------------
4492 procedure Install_Unit_ABE_Check_Common
4494 Unit_Id : Entity_Id)
4496 Loc : constant Source_Ptr := Sloc (N);
4497 Spec_Id : constant Entity_Id := Unique_Entity (Unit_Id);
4501 -- if not Spec_Id'Elaborated then
4502 -- raise Program_Error with "access before elaboration";
4505 Insert_ABE_Check_Or_Failure
4508 Make_Raise_Program_Error (Loc,
4512 Make_Attribute_Reference (Loc,
4513 Prefix => New_Occurrence_Of (Spec_Id, Loc),
4514 Attribute_Name => Name_Elaborated)),
4515 Reason => PE_Access_Before_Elaboration));
4516 end Install_Unit_ABE_Check_Common;
4517 end Check_Installer;
4519 ----------------------
4520 -- Compilation_Unit --
4521 ----------------------
4523 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is
4524 Comp_Unit : Node_Id;
4527 Comp_Unit := Parent (Unit_Id);
4529 -- Handle the case where a concurrent subunit is rewritten as a null
4530 -- statement due to expansion activities.
4532 if Nkind (Comp_Unit) = N_Null_Statement
4533 and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body,
4536 Comp_Unit := Parent (Comp_Unit);
4537 pragma Assert (Nkind (Comp_Unit) = N_Subunit);
4539 -- Otherwise use the declaration node of the unit
4542 Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id));
4545 -- Handle the case where a subprogram instantiation which acts as a
4546 -- compilation unit is expanded into an anonymous package that wraps
4547 -- the instantiated subprogram.
4549 if Nkind (Comp_Unit) = N_Package_Specification
4550 and then Nkind_In (Original_Node (Parent (Comp_Unit)),
4551 N_Function_Instantiation,
4552 N_Procedure_Instantiation)
4554 Comp_Unit := Parent (Parent (Comp_Unit));
4556 -- Handle the case where the compilation unit is a subunit
4558 elsif Nkind (Comp_Unit) = N_Subunit then
4559 Comp_Unit := Parent (Comp_Unit);
4562 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
4565 end Compilation_Unit;
4567 -------------------------------
4568 -- Conditional_ABE_Processor --
4569 -------------------------------
4571 package body Conditional_ABE_Processor is
4573 -----------------------
4574 -- Local subprograms --
4575 -----------------------
4577 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean;
4578 pragma Inline (Is_Conditional_ABE_Scenario);
4579 -- Determine whether node N is a suitable scenario for conditional ABE
4580 -- checks and diagnostics.
4582 procedure Process_Conditional_ABE_Access_Taken
4584 Attr_Rep : Scenario_Rep_Id;
4585 In_State : Processing_In_State);
4586 pragma Inline (Process_Conditional_ABE_Access_Taken);
4587 -- Perform ABE checks and diagnostics for attribute reference Attr with
4588 -- representation Attr_Rep which takes 'Access of an entry, operator, or
4589 -- subprogram. In_State is the current state of the Processing phase.
4591 procedure Process_Conditional_ABE_Activation
4593 Call_Rep : Scenario_Rep_Id;
4595 Obj_Rep : Target_Rep_Id;
4596 Task_Typ : Entity_Id;
4597 Task_Rep : Target_Rep_Id;
4598 In_State : Processing_In_State);
4599 pragma Inline (Process_Conditional_ABE_Activation);
4600 -- Perform common conditional ABE checks and diagnostics for activation
4601 -- call Call which activates object Obj_Id of task type Task_Typ. Formal
4602 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the
4603 -- representation of the object. Task_Rep denotes the representation of
4604 -- the task type. In_State is the current state of the Processing phase.
4606 procedure Process_Conditional_ABE_Call
4608 Call_Rep : Scenario_Rep_Id;
4609 In_State : Processing_In_State);
4610 pragma Inline (Process_Conditional_ABE_Call);
4611 -- Top-level dispatcher for processing of calls. Perform ABE checks and
4612 -- diagnostics for call Call with representation Call_Rep. In_State is
4613 -- the current state of the Processing phase.
4615 procedure Process_Conditional_ABE_Call_Ada
4617 Call_Rep : Scenario_Rep_Id;
4618 Subp_Id : Entity_Id;
4619 Subp_Rep : Target_Rep_Id;
4620 In_State : Processing_In_State);
4621 pragma Inline (Process_Conditional_ABE_Call_Ada);
4622 -- Perform ABE checks and diagnostics for call Call which invokes entry,
4623 -- operator, or subprogram Subp_Id using the Ada rules. Call_Rep denotes
4624 -- the representation of the call. Subp_Rep denotes the representation
4625 -- of the subprogram. In_State is the current state of the Processing
4628 procedure Process_Conditional_ABE_Call_SPARK
4630 Call_Rep : Scenario_Rep_Id;
4631 Subp_Id : Entity_Id;
4632 Subp_Rep : Target_Rep_Id;
4633 In_State : Processing_In_State);
4634 pragma Inline (Process_Conditional_ABE_Call_SPARK);
4635 -- Perform ABE checks and diagnostics for call Call which invokes entry,
4636 -- operator, or subprogram Subp_Id using the SPARK rules. Call_Rep is
4637 -- the representation of the call. Subp_Rep denotes the representation
4638 -- of the subprogram. In_State is the current state of the Processing
4641 procedure Process_Conditional_ABE_Instantiation
4643 Inst_Rep : Scenario_Rep_Id;
4644 In_State : Processing_In_State);
4645 pragma Inline (Process_Conditional_ABE_Instantiation);
4646 -- Top-level dispatcher for processing of instantiations. Perform ABE
4647 -- checks and diagnostics for instantiation Inst with representation
4648 -- Inst_Rep. In_State is the current state of the Processing phase.
4650 procedure Process_Conditional_ABE_Instantiation_Ada
4652 Inst_Rep : Scenario_Rep_Id;
4654 Gen_Rep : Target_Rep_Id;
4655 In_State : Processing_In_State);
4656 pragma Inline (Process_Conditional_ABE_Instantiation_Ada);
4657 -- Perform ABE checks and diagnostics for instantiation Inst of generic
4658 -- Gen_Id using the Ada rules. Inst_Rep denotes the representation of
4659 -- the instnace. Gen_Rep is the representation of the generic. In_State
4660 -- is the current state of the Processing phase.
4662 procedure Process_Conditional_ABE_Instantiation_SPARK
4664 Inst_Rep : Scenario_Rep_Id;
4666 Gen_Rep : Target_Rep_Id;
4667 In_State : Processing_In_State);
4668 pragma Inline (Process_Conditional_ABE_Instantiation_SPARK);
4669 -- Perform ABE checks and diagnostics for instantiation Inst of generic
4670 -- Gen_Id using the SPARK rules. Inst_Rep denotes the representation of
4671 -- the instnace. Gen_Rep is the representation of the generic. In_State
4672 -- is the current state of the Processing phase.
4674 procedure Process_Conditional_ABE_Variable_Assignment
4676 Asmt_Rep : Scenario_Rep_Id;
4677 In_State : Processing_In_State);
4678 pragma Inline (Process_Conditional_ABE_Variable_Assignment);
4679 -- Top-level dispatcher for processing of variable assignments. Perform
4680 -- ABE checks and diagnostics for assignment Asmt with representation
4681 -- Asmt_Rep. In_State denotes the current state of the Processing phase.
4683 procedure Process_Conditional_ABE_Variable_Assignment_Ada
4685 Asmt_Rep : Scenario_Rep_Id;
4687 Var_Rep : Target_Rep_Id;
4688 In_State : Processing_In_State);
4689 pragma Inline (Process_Conditional_ABE_Variable_Assignment_Ada);
4690 -- Perform ABE checks and diagnostics for assignment statement Asmt that
4691 -- modifies the value of variable Var_Id using the Ada rules. Asmt_Rep
4692 -- denotes the representation of the assignment. Var_Rep denotes the
4693 -- representation of the variable. In_State is the current state of the
4694 -- Processing phase.
4696 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
4698 Asmt_Rep : Scenario_Rep_Id;
4700 Var_Rep : Target_Rep_Id;
4701 In_State : Processing_In_State);
4702 pragma Inline (Process_Conditional_ABE_Variable_Assignment_SPARK);
4703 -- Perform ABE checks and diagnostics for assignment statement Asmt that
4704 -- modifies the value of variable Var_Id using the SPARK rules. Asmt_Rep
4705 -- denotes the representation of the assignment. Var_Rep denotes the
4706 -- representation of the variable. In_State is the current state of the
4707 -- Processing phase.
4709 procedure Process_Conditional_ABE_Variable_Reference
4711 Ref_Rep : Scenario_Rep_Id;
4712 In_State : Processing_In_State);
4713 pragma Inline (Process_Conditional_ABE_Variable_Reference);
4714 -- Perform ABE checks and diagnostics for variable reference Ref with
4715 -- representation Ref_Rep. In_State denotes the current state of the
4716 -- Processing phase.
4718 procedure Traverse_Conditional_ABE_Body
4720 In_State : Processing_In_State);
4721 pragma Inline (Traverse_Conditional_ABE_Body);
4722 -- Traverse subprogram body N looking for suitable scenarios that need
4723 -- to be processed for conditional ABE checks and diagnostics. In_State
4724 -- is the current state of the Processing phase.
4726 -------------------------------------
4727 -- Check_Conditional_ABE_Scenarios --
4728 -------------------------------------
4730 procedure Check_Conditional_ABE_Scenarios
4731 (Iter : in out NE_Set.Iterator)
4736 while NE_Set.Has_Next (Iter) loop
4737 NE_Set.Next (Iter, N);
4739 -- Reset the traversed status of all subprogram bodies because the
4740 -- current conditional scenario acts as a new DFS traversal root.
4742 Reset_Traversed_Bodies;
4744 Process_Conditional_ABE
4746 In_State => Conditional_ABE_State);
4748 end Check_Conditional_ABE_Scenarios;
4750 ---------------------------------
4751 -- Is_Conditional_ABE_Scenario --
4752 ---------------------------------
4754 function Is_Conditional_ABE_Scenario (N : Node_Id) return Boolean is
4757 Is_Suitable_Access_Taken (N)
4758 or else Is_Suitable_Call (N)
4759 or else Is_Suitable_Instantiation (N)
4760 or else Is_Suitable_Variable_Assignment (N)
4761 or else Is_Suitable_Variable_Reference (N);
4762 end Is_Conditional_ABE_Scenario;
4764 -----------------------------
4765 -- Process_Conditional_ABE --
4766 -----------------------------
4768 procedure Process_Conditional_ABE
4770 In_State : Processing_In_State)
4772 Scen : constant Node_Id := Scenario (N);
4773 Scen_Rep : Scenario_Rep_Id;
4776 -- Add the current scenario to the stack of active scenarios
4778 Push_Active_Scenario (Scen);
4782 if Is_Suitable_Access_Taken (Scen) then
4783 Process_Conditional_ABE_Access_Taken
4785 Attr_Rep => Scenario_Representation_Of (Scen, In_State),
4786 In_State => In_State);
4788 -- Call or task activation
4790 elsif Is_Suitable_Call (Scen) then
4791 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
4793 -- Routine Build_Call_Marker creates call markers regardless of
4794 -- whether the call occurs within the main unit or not. This way
4795 -- the serialization of internal names is kept consistent. Only
4796 -- call markers found within the main unit must be processed.
4798 if In_Main_Context (Scen) then
4799 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
4801 if Kind (Scen_Rep) = Call_Scenario then
4802 Process_Conditional_ABE_Call
4804 Call_Rep => Scen_Rep,
4805 In_State => In_State);
4808 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario);
4812 Call_Rep => Scen_Rep,
4813 Processor => Process_Conditional_ABE_Activation'Access,
4814 In_State => In_State);
4820 elsif Is_Suitable_Instantiation (Scen) then
4821 Process_Conditional_ABE_Instantiation
4823 Inst_Rep => Scenario_Representation_Of (Scen, In_State),
4824 In_State => In_State);
4826 -- Variable assignments
4828 elsif Is_Suitable_Variable_Assignment (Scen) then
4829 Process_Conditional_ABE_Variable_Assignment
4831 Asmt_Rep => Scenario_Representation_Of (Scen, In_State),
4832 In_State => In_State);
4834 -- Variable references
4836 elsif Is_Suitable_Variable_Reference (Scen) then
4838 -- Routine Build_Variable_Reference_Marker makes variable markers
4839 -- regardless of whether the reference occurs within the main unit
4840 -- or not. This way the serialization of internal names is kept
4841 -- consistent. Only variable markers within the main unit must be
4844 if In_Main_Context (Scen) then
4845 Process_Conditional_ABE_Variable_Reference
4847 Ref_Rep => Scenario_Representation_Of (Scen, In_State),
4848 In_State => In_State);
4852 -- Remove the current scenario from the stack of active scenarios
4853 -- once all ABE diagnostics and checks have been performed.
4855 Pop_Active_Scenario (Scen);
4856 end Process_Conditional_ABE;
4858 ------------------------------------------
4859 -- Process_Conditional_ABE_Access_Taken --
4860 ------------------------------------------
4862 procedure Process_Conditional_ABE_Access_Taken
4864 Attr_Rep : Scenario_Rep_Id;
4865 In_State : Processing_In_State)
4867 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id;
4868 pragma Inline (Build_Access_Marker);
4869 -- Create a suitable call marker which invokes subprogram Subp_Id
4871 -------------------------
4872 -- Build_Access_Marker --
4873 -------------------------
4875 function Build_Access_Marker (Subp_Id : Entity_Id) return Node_Id is
4879 Marker := Make_Call_Marker (Sloc (Attr));
4881 -- Inherit relevant attributes from the attribute
4883 Set_Target (Marker, Subp_Id);
4884 Set_Is_Declaration_Level_Node
4885 (Marker, Level (Attr_Rep) = Declaration_Level);
4886 Set_Is_Dispatching_Call
4888 Set_Is_Elaboration_Checks_OK_Node
4889 (Marker, Elaboration_Checks_OK (Attr_Rep));
4890 Set_Is_Elaboration_Warnings_OK_Node
4891 (Marker, Elaboration_Warnings_OK (Attr_Rep));
4893 (Marker, Comes_From_Source (Attr));
4894 Set_Is_SPARK_Mode_On_Node
4895 (Marker, SPARK_Mode_Of (Attr_Rep) = Is_On);
4897 -- Partially insert the call marker into the tree by setting its
4900 Set_Parent (Marker, Attr);
4903 end Build_Access_Marker;
4907 Root : constant Node_Id := Root_Scenario;
4908 Subp_Id : constant Entity_Id := Target (Attr_Rep);
4909 Subp_Rep : constant Target_Rep_Id :=
4910 Target_Representation_Of (Subp_Id, In_State);
4911 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep);
4913 New_In_State : Processing_In_State := In_State;
4914 -- Each step of the Processing phase constitutes a new state
4916 -- Start of processing for Process_Conditional_ABE_Access
4919 -- Output relevant information when switch -gnatel (info messages on
4920 -- implicit Elaborate[_All] pragmas) is in effect.
4922 if Elab_Info_Messages
4923 and then not New_In_State.Suppress_Info_Messages
4926 ("info: access to & during elaboration", Attr, Subp_Id);
4929 -- Warnings are suppressed when a prior scenario is already in that
4930 -- mode or when the attribute or the target have warnings suppressed.
4931 -- Update the state of the Processing phase to reflect this.
4933 New_In_State.Suppress_Warnings :=
4934 New_In_State.Suppress_Warnings
4935 or else not Elaboration_Warnings_OK (Attr_Rep)
4936 or else not Elaboration_Warnings_OK (Subp_Rep);
4938 -- Do not emit any ABE diagnostics when the current or previous
4939 -- scenario in this traversal has suppressed elaboration warnings.
4941 if New_In_State.Suppress_Warnings then
4944 -- Both the attribute and the corresponding subprogram body are in
4945 -- the same unit. The body must appear prior to the root scenario
4946 -- which started the recursive search. If this is not the case, then
4947 -- there is a potential ABE if the access value is used to call the
4948 -- subprogram. Emit a warning only when switch -gnatw.f (warnings on
4949 -- suspucious 'Access) is in effect.
4951 elsif Warn_On_Elab_Access
4952 and then Present (Body_Decl)
4953 and then In_Extended_Main_Code_Unit (Body_Decl)
4954 and then Earlier_In_Extended_Unit (Root, Body_Decl)
4956 Error_Msg_Name_1 := Attribute_Name (Attr);
4958 ("??% attribute of & before body seen", Attr, Subp_Id);
4959 Error_Msg_N ("\possible Program_Error on later references", Attr);
4961 Output_Active_Scenarios (Attr, New_In_State);
4964 -- Treat the attribute an an immediate invocation of the target when
4965 -- switch -gnatd.o (conservative elaboration order for indirect
4966 -- calls) is in effect. This has the following desirable effects:
4968 -- * Ensure that the unit with the corresponding body is elaborated
4969 -- prior to the main unit.
4971 -- * Perform conditional ABE checks and diagnostics
4973 -- * Traverse the body of the target (if available)
4975 if Debug_Flag_Dot_O then
4976 Process_Conditional_ABE
4977 (N => Build_Access_Marker (Subp_Id),
4978 In_State => New_In_State);
4980 -- Otherwise ensure that the unit with the corresponding body is
4981 -- elaborated prior to the main unit.
4984 Ensure_Prior_Elaboration
4986 Unit_Id => Unit (Subp_Rep),
4987 Prag_Nam => Name_Elaborate_All,
4988 In_State => New_In_State);
4990 end Process_Conditional_ABE_Access_Taken;
4992 ----------------------------------------
4993 -- Process_Conditional_ABE_Activation --
4994 ----------------------------------------
4996 procedure Process_Conditional_ABE_Activation
4998 Call_Rep : Scenario_Rep_Id;
5000 Obj_Rep : Target_Rep_Id;
5001 Task_Typ : Entity_Id;
5002 Task_Rep : Target_Rep_Id;
5003 In_State : Processing_In_State)
5005 pragma Unreferenced (Task_Typ);
5007 Body_Decl : constant Node_Id := Body_Declaration (Task_Rep);
5008 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep);
5009 Root : constant Node_Id := Root_Scenario;
5010 Unit_Id : constant Node_Id := Unit (Task_Rep);
5012 Check_OK : constant Boolean :=
5013 not In_State.Suppress_Checks
5014 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored
5015 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored
5016 and then Elaboration_Checks_OK (Obj_Rep)
5017 and then Elaboration_Checks_OK (Task_Rep);
5018 -- A run-time ABE check may be installed only when the object and the
5019 -- task type have active elaboration checks, and both are not ignored
5020 -- Ghost constructs.
5022 New_In_State : Processing_In_State := In_State;
5023 -- Each step of the Processing phase constitutes a new state
5026 -- Output relevant information when switch -gnatel (info messages on
5027 -- implicit Elaborate[_All] pragmas) is in effect.
5029 if Elab_Info_Messages
5030 and then not New_In_State.Suppress_Info_Messages
5033 ("info: activation of & during elaboration", Call, Obj_Id);
5036 -- Nothing to do when the call activates a task whose type is defined
5037 -- within an instance and switch -gnatd_i (ignore activations and
5038 -- calls to instances for elaboration) is in effect.
5040 if Debug_Flag_Underscore_I
5041 and then In_External_Instance
5043 Target_Decl => Spec_Decl)
5047 -- Nothing to do when the activation is a guaranteed ABE
5049 elsif Is_Known_Guaranteed_ABE (Call) then
5052 -- Nothing to do when the root scenario appears at the declaration
5053 -- level and the task is in the same unit, but outside this context.
5055 -- task type Task_Typ; -- task declaration
5057 -- procedure Proc is
5058 -- function A ... is
5060 -- if Some_Condition then
5064 -- <activation call> -- activation site
5069 -- X : ... := A; -- root scenario
5072 -- task body Task_Typ is
5076 -- In the example above, the context of X is the declarative list of
5077 -- Proc. The "elaboration" of X may reach the activation of T whose
5078 -- body is defined outside of X's context. The task body is relevant
5079 -- only when Proc is invoked, but this happens only during "normal"
5080 -- elaboration, therefore the task body must not be considered if
5081 -- this is not the case.
5083 elsif Is_Up_Level_Target
5084 (Targ_Decl => Spec_Decl,
5085 In_State => New_In_State)
5089 -- Nothing to do when the activation is ABE-safe
5093 -- task type Task_Typ;
5096 -- package body Gen is
5097 -- task body Task_Typ is
5104 -- procedure Main is
5105 -- package Nested is
5106 -- package Inst is new Gen;
5107 -- T : Inst.Task_Typ;
5108 -- <activation call> -- safe activation
5112 elsif Is_Safe_Activation (Call, Task_Rep) then
5114 -- Note that the task body must still be examined for any nested
5119 -- The activation call and the task body are both in the main unit
5121 -- If the root scenario appears prior to the task body, then this is
5122 -- a possible ABE with respect to the root scenario.
5124 -- task type Task_Typ;
5126 -- function A ... is
5128 -- if Some_Condition then
5132 -- end Pack; -- activation of T
5136 -- X : ... := A; -- root scenario
5138 -- task body Task_Typ is -- task body
5142 -- Y : ... := A; -- root scenario
5144 -- IMPORTANT: The activation of T is a possible ABE for X, but
5145 -- not for Y. Intalling an unconditional ABE raise prior to the
5146 -- activation call would be wrong as it will fail for Y as well
5147 -- but in Y's case the activation of T is never an ABE.
5149 elsif Present (Body_Decl)
5150 and then In_Extended_Main_Code_Unit (Body_Decl)
5152 if Earlier_In_Extended_Unit (Root, Body_Decl) then
5154 -- Do not emit any ABE diagnostics when a previous scenario in
5155 -- this traversal has suppressed elaboration warnings.
5157 if New_In_State.Suppress_Warnings then
5160 -- Do not emit any ABE diagnostics when the activation occurs
5161 -- in a partial finalization context because this action leads
5162 -- to confusing noise.
5164 elsif New_In_State.Within_Partial_Finalization then
5167 -- Otherwise emit the ABE disgnostic
5170 Error_Msg_Sloc := Sloc (Call);
5172 ("??task & will be activated # before elaboration of its "
5175 ("\Program_Error may be raised at run time", Obj_Id);
5177 Output_Active_Scenarios (Obj_Id, New_In_State);
5180 -- Install a conditional run-time ABE check to verify that the
5181 -- task body has been elaborated prior to the activation call.
5184 Install_Scenario_ABE_Check
5186 Targ_Id => Defining_Entity (Spec_Decl),
5187 Targ_Rep => Task_Rep,
5188 Disable => Obj_Rep);
5190 -- Update the state of the Processing phase to indicate that
5191 -- no implicit Elaborate[_All] pragma must be generated from
5194 -- task type Task_Typ;
5196 -- function A ... is
5198 -- if Some_Condition then
5203 -- end Pack; -- activation of T
5209 -- task body Task_Typ is
5211 -- External.Subp; -- imparts Elaborate_All
5214 -- If Some_Condition is True, then the ABE check will fail
5215 -- at runtime and the call to External.Subp will never take
5216 -- place, rendering the implicit Elaborate_All useless.
5218 -- If the value of Some_Condition is False, then the call
5219 -- to External.Subp will never take place, rendering the
5220 -- implicit Elaborate_All useless.
5222 New_In_State.Suppress_Implicit_Pragmas := True;
5226 -- Otherwise the task body is not available in this compilation or
5227 -- it resides in an external unit. Install a run-time ABE check to
5228 -- verify that the task body has been elaborated prior to the
5229 -- activation call when the dynamic model is in effect.
5232 and then New_In_State.Processing = Dynamic_Model_Processing
5234 Install_Unit_ABE_Check
5237 Disable => Obj_Rep);
5240 -- Both the activation call and task type are subject to SPARK_Mode
5241 -- On, this triggers the SPARK rules for task activation. Compared
5242 -- to calls and instantiations, task activation in SPARK does not
5243 -- require the presence of Elaborate[_All] pragmas in case the task
5244 -- type is defined outside the main unit. This is because SPARK uses
5245 -- a special policy which activates all tasks after the main unit has
5246 -- finished its elaboration.
5248 if SPARK_Mode_Of (Call_Rep) = Is_On
5249 and then SPARK_Mode_Of (Task_Rep) = Is_On
5253 -- Otherwise the Ada rules are in effect. Ensure that the unit with
5254 -- the task body is elaborated prior to the main unit.
5257 Ensure_Prior_Elaboration
5260 Prag_Nam => Name_Elaborate_All,
5261 In_State => New_In_State);
5264 Traverse_Conditional_ABE_Body
5266 In_State => New_In_State);
5267 end Process_Conditional_ABE_Activation;
5269 ----------------------------------
5270 -- Process_Conditional_ABE_Call --
5271 ----------------------------------
5273 procedure Process_Conditional_ABE_Call
5275 Call_Rep : Scenario_Rep_Id;
5276 In_State : Processing_In_State)
5278 function In_Initialization_Context (N : Node_Id) return Boolean;
5279 pragma Inline (In_Initialization_Context);
5280 -- Determine whether arbitrary node N appears within a type init
5281 -- proc, primitive [Deep_]Initialize, or a block created for
5282 -- initialization purposes.
5284 function Is_Partial_Finalization_Proc
5285 (Subp_Id : Entity_Id) return Boolean;
5286 pragma Inline (Is_Partial_Finalization_Proc);
5287 -- Determine whether subprogram Subp_Id is a partial finalization
5290 -------------------------------
5291 -- In_Initialization_Context --
5292 -------------------------------
5294 function In_Initialization_Context (N : Node_Id) return Boolean is
5296 Spec_Id : Entity_Id;
5299 -- Climb the parent chain looking for initialization actions
5302 while Present (Par) loop
5304 -- A block may be part of the initialization actions of a
5305 -- default initialized object.
5307 if Nkind (Par) = N_Block_Statement
5308 and then Is_Initialization_Block (Par)
5312 -- A subprogram body may denote an initialization routine
5314 elsif Nkind (Par) = N_Subprogram_Body then
5315 Spec_Id := Unique_Defining_Entity (Par);
5317 -- The current subprogram body denotes a type init proc or
5318 -- primitive [Deep_]Initialize.
5320 if Is_Init_Proc (Spec_Id)
5321 or else Is_Controlled_Proc (Spec_Id, Name_Initialize)
5322 or else Is_TSS (Spec_Id, TSS_Deep_Initialize)
5327 -- Prevent the search from going too far
5329 elsif Is_Body_Or_Package_Declaration (Par) then
5333 Par := Parent (Par);
5337 end In_Initialization_Context;
5339 ----------------------------------
5340 -- Is_Partial_Finalization_Proc --
5341 ----------------------------------
5343 function Is_Partial_Finalization_Proc
5344 (Subp_Id : Entity_Id) return Boolean
5347 -- To qualify, the subprogram must denote a finalizer procedure
5348 -- or primitive [Deep_]Finalize, and the call must appear within
5349 -- an initialization context.
5352 (Is_Controlled_Proc (Subp_Id, Name_Finalize)
5353 or else Is_Finalizer_Proc (Subp_Id)
5354 or else Is_TSS (Subp_Id, TSS_Deep_Finalize))
5355 and then In_Initialization_Context (Call);
5356 end Is_Partial_Finalization_Proc;
5360 Subp_Id : constant Entity_Id := Target (Call_Rep);
5361 Subp_Rep : constant Target_Rep_Id :=
5362 Target_Representation_Of (Subp_Id, In_State);
5363 Subp_Decl : constant Node_Id := Spec_Declaration (Subp_Rep);
5365 SPARK_Rules_On : constant Boolean :=
5366 SPARK_Mode_Of (Call_Rep) = Is_On
5367 and then SPARK_Mode_Of (Subp_Rep) = Is_On;
5369 New_In_State : Processing_In_State := In_State;
5370 -- Each step of the Processing phase constitutes a new state
5372 -- Start of processing for Process_Conditional_ABE_Call
5375 -- Output relevant information when switch -gnatel (info messages on
5376 -- implicit Elaborate[_All] pragmas) is in effect.
5378 if Elab_Info_Messages
5379 and then not New_In_State.Suppress_Info_Messages
5385 In_SPARK => SPARK_Rules_On);
5388 -- Check whether the invocation of an entry clashes with an existing
5389 -- restriction. This check is relevant only when the processing was
5390 -- started from some library-level scenario.
5392 if Is_Protected_Entry (Subp_Id) then
5393 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call);
5395 elsif Is_Task_Entry (Subp_Id) then
5396 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call);
5398 -- Task entry calls are never processed because the entry being
5399 -- invoked does not have a corresponding "body", it has a select.
5404 -- Nothing to do when the call invokes a target defined within an
5405 -- instance and switch -gnatd_i (ignore activations and calls to
5406 -- instances for elaboration) is in effect.
5408 if Debug_Flag_Underscore_I
5409 and then In_External_Instance
5411 Target_Decl => Subp_Decl)
5415 -- Nothing to do when the call is a guaranteed ABE
5417 elsif Is_Known_Guaranteed_ABE (Call) then
5420 -- Nothing to do when the root scenario appears at the declaration
5421 -- level and the target is in the same unit but outside this context.
5423 -- function B ...; -- target declaration
5425 -- procedure Proc is
5426 -- function A ... is
5428 -- if Some_Condition then
5429 -- return B; -- call site
5433 -- X : ... := A; -- root scenario
5436 -- function B ... is
5440 -- In the example above, the context of X is the declarative region
5441 -- of Proc. The "elaboration" of X may eventually reach B which is
5442 -- defined outside of X's context. B is relevant only when Proc is
5443 -- invoked, but this happens only by means of "normal" elaboration,
5444 -- therefore B must not be considered if this is not the case.
5446 elsif Is_Up_Level_Target
5447 (Targ_Decl => Subp_Decl,
5448 In_State => New_In_State)
5453 -- Warnings are suppressed when a prior scenario is already in that
5454 -- mode, or the call or target have warnings suppressed. Update the
5455 -- state of the Processing phase to reflect this.
5457 New_In_State.Suppress_Warnings :=
5458 New_In_State.Suppress_Warnings
5459 or else not Elaboration_Warnings_OK (Call_Rep)
5460 or else not Elaboration_Warnings_OK (Subp_Rep);
5462 -- The call occurs in an initial condition context when a prior
5463 -- scenario is already in that mode, or when the target is an
5464 -- Initial_Condition procedure. Update the state of the Processing
5465 -- phase to reflect this.
5467 New_In_State.Within_Initial_Condition :=
5468 New_In_State.Within_Initial_Condition
5469 or else Is_Initial_Condition_Proc (Subp_Id);
5471 -- The call occurs in a partial finalization context when a prior
5472 -- scenario is already in that mode, or when the target denotes a
5473 -- [Deep_]Finalize primitive or a finalizer within an initialization
5474 -- context. Update the state of the Processing phase to reflect this.
5476 New_In_State.Within_Partial_Finalization :=
5477 New_In_State.Within_Partial_Finalization
5478 or else Is_Partial_Finalization_Proc (Subp_Id);
5480 -- The SPARK rules are in effect. Note that -gnatd.v (enforce SPARK
5481 -- elaboration rules in SPARK code) is intentionally not taken into
5482 -- account here because Process_Conditional_ABE_Call_SPARK has two
5483 -- separate modes of operation.
5485 if SPARK_Rules_On then
5486 Process_Conditional_ABE_Call_SPARK
5488 Call_Rep => Call_Rep,
5490 Subp_Rep => Subp_Rep,
5491 In_State => New_In_State);
5493 -- Otherwise the Ada rules are in effect
5496 Process_Conditional_ABE_Call_Ada
5498 Call_Rep => Call_Rep,
5500 Subp_Rep => Subp_Rep,
5501 In_State => New_In_State);
5504 -- Inspect the target body (and barried function) for other suitable
5505 -- elaboration scenarios.
5507 Traverse_Conditional_ABE_Body
5508 (N => Barrier_Body_Declaration (Subp_Rep),
5509 In_State => New_In_State);
5511 Traverse_Conditional_ABE_Body
5512 (N => Body_Declaration (Subp_Rep),
5513 In_State => New_In_State);
5514 end Process_Conditional_ABE_Call;
5516 --------------------------------------
5517 -- Process_Conditional_ABE_Call_Ada --
5518 --------------------------------------
5520 procedure Process_Conditional_ABE_Call_Ada
5522 Call_Rep : Scenario_Rep_Id;
5523 Subp_Id : Entity_Id;
5524 Subp_Rep : Target_Rep_Id;
5525 In_State : Processing_In_State)
5527 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep);
5528 Root : constant Node_Id := Root_Scenario;
5529 Unit_Id : constant Node_Id := Unit (Subp_Rep);
5531 Check_OK : constant Boolean :=
5532 not In_State.Suppress_Checks
5533 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored
5534 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored
5535 and then Elaboration_Checks_OK (Call_Rep)
5536 and then Elaboration_Checks_OK (Subp_Rep);
5537 -- A run-time ABE check may be installed only when both the call
5538 -- and the target have active elaboration checks, and both are not
5539 -- ignored Ghost constructs.
5541 New_In_State : Processing_In_State := In_State;
5542 -- Each step of the Processing phase constitutes a new state
5545 -- Nothing to do for an Ada dispatching call because there are no
5546 -- ABE diagnostics for either models. ABE checks for the dynamic
5547 -- model are handled by Install_Primitive_Elaboration_Check.
5549 if Is_Dispatching_Call (Call_Rep) then
5552 -- Nothing to do when the call is ABE-safe
5555 -- function Gen ...;
5557 -- function Gen ... is
5563 -- procedure Main is
5564 -- function Inst is new Gen;
5565 -- X : ... := Inst; -- safe call
5568 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then
5571 -- The call and the target body are both in the main unit
5573 -- If the root scenario appears prior to the target body, then this
5574 -- is a possible ABE with respect to the root scenario.
5578 -- function A ... is
5580 -- if Some_Condition then
5581 -- return B; -- call site
5585 -- X : ... := A; -- root scenario
5587 -- function B ... is -- target body
5591 -- Y : ... := A; -- root scenario
5593 -- IMPORTANT: The call to B from A is a possible ABE for X, but
5594 -- not for Y. Installing an unconditional ABE raise prior to the
5595 -- call to B would be wrong as it will fail for Y as well, but in
5596 -- Y's case the call to B is never an ABE.
5598 elsif Present (Body_Decl)
5599 and then In_Extended_Main_Code_Unit (Body_Decl)
5601 if Earlier_In_Extended_Unit (Root, Body_Decl) then
5603 -- Do not emit any ABE diagnostics when a previous scenario in
5604 -- this traversal has suppressed elaboration warnings.
5606 if New_In_State.Suppress_Warnings then
5609 -- Do not emit any ABE diagnostics when the call occurs in a
5610 -- partial finalization context because this leads to confusing
5613 elsif New_In_State.Within_Partial_Finalization then
5616 -- Otherwise emit the ABE diagnostic
5620 ("??cannot call & before body seen", Call, Subp_Id);
5622 ("\Program_Error may be raised at run time", Call);
5624 Output_Active_Scenarios (Call, New_In_State);
5627 -- Install a conditional run-time ABE check to verify that the
5628 -- target body has been elaborated prior to the call.
5631 Install_Scenario_ABE_Check
5634 Targ_Rep => Subp_Rep,
5635 Disable => Call_Rep);
5637 -- Update the state of the Processing phase to indicate that
5638 -- no implicit Elaborate[_All] pragma must be generated from
5643 -- function A ... is
5645 -- if Some_Condition then
5653 -- function B ... is
5654 -- External.Subp; -- imparts Elaborate_All
5657 -- If Some_Condition is True, then the ABE check will fail
5658 -- at runtime and the call to External.Subp will never take
5659 -- place, rendering the implicit Elaborate_All useless.
5661 -- If the value of Some_Condition is False, then the call
5662 -- to External.Subp will never take place, rendering the
5663 -- implicit Elaborate_All useless.
5665 New_In_State.Suppress_Implicit_Pragmas := True;
5669 -- Otherwise the target body is not available in this compilation or
5670 -- it resides in an external unit. Install a run-time ABE check to
5671 -- verify that the target body has been elaborated prior to the call
5672 -- site when the dynamic model is in effect.
5675 and then New_In_State.Processing = Dynamic_Model_Processing
5677 Install_Unit_ABE_Check
5680 Disable => Call_Rep);
5683 -- Ensure that the unit with the target body is elaborated prior to
5684 -- the main unit. The implicit Elaborate[_All] is generated only when
5685 -- the call has elaboration checks enabled. This behaviour parallels
5686 -- that of the old ABE mechanism.
5688 if Elaboration_Checks_OK (Call_Rep) then
5689 Ensure_Prior_Elaboration
5692 Prag_Nam => Name_Elaborate_All,
5693 In_State => New_In_State);
5695 end Process_Conditional_ABE_Call_Ada;
5697 ----------------------------------------
5698 -- Process_Conditional_ABE_Call_SPARK --
5699 ----------------------------------------
5701 procedure Process_Conditional_ABE_Call_SPARK
5703 Call_Rep : Scenario_Rep_Id;
5704 Subp_Id : Entity_Id;
5705 Subp_Rep : Target_Rep_Id;
5706 In_State : Processing_In_State)
5708 pragma Unreferenced (Call_Rep);
5710 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep);
5714 -- Ensure that a suitable elaboration model is in effect for SPARK
5715 -- rule verification.
5717 Check_SPARK_Model_In_Effect;
5719 -- The call and the target body are both in the main unit
5721 if Present (Body_Decl)
5722 and then In_Extended_Main_Code_Unit (Body_Decl)
5723 and then Earlier_In_Extended_Unit (Call, Body_Decl)
5725 -- Do not emit any ABE diagnostics when a previous scenario in
5726 -- this traversal has suppressed elaboration warnings.
5728 if In_State.Suppress_Warnings then
5731 -- Do not emit any ABE diagnostics when the call occurs in an
5732 -- initial condition context because this leads to incorrect
5735 elsif In_State.Within_Initial_Condition then
5738 -- Do not emit any ABE diagnostics when the call occurs in a
5739 -- partial finalization context because this leads to confusing
5742 elsif In_State.Within_Partial_Finalization then
5745 -- Ensure that a call that textually precedes the subprogram body
5746 -- it invokes appears within the early call region of the body.
5748 -- IMPORTANT: This check must always be performed even when switch
5749 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
5750 -- specified because the static model cannot guarantee the absence
5751 -- of elaboration issues when dispatching calls are involved.
5754 Region := Find_Early_Call_Region (Body_Decl);
5756 if Earlier_In_Extended_Unit (Call, Region) then
5758 ("call must appear within early call region of subprogram "
5759 & "body & (SPARK RM 7.7(3))",
5762 Error_Msg_Sloc := Sloc (Region);
5763 Error_Msg_N ("\region starts #", Call);
5765 Error_Msg_Sloc := Sloc (Body_Decl);
5766 Error_Msg_N ("\region ends #", Call);
5768 Output_Active_Scenarios (Call, In_State);
5773 -- A call to a source target or to a target which emulates Ada
5774 -- or SPARK semantics imposes an Elaborate_All requirement on the
5775 -- context of the main unit. Determine whether the context has a
5776 -- pragma strong enough to meet the requirement.
5778 -- IMPORTANT: This check must be performed only when switch -gnatd.v
5779 -- (enforce SPARK elaboration rules in SPARK code) is active because
5780 -- the static model can ensure the prior elaboration of the unit
5781 -- which contains a body by installing an implicit Elaborate[_All]
5784 if Debug_Flag_Dot_V then
5785 if Comes_From_Source (Subp_Id)
5786 or else Is_Ada_Semantic_Target (Subp_Id)
5787 or else Is_SPARK_Semantic_Target (Subp_Id)
5789 Meet_Elaboration_Requirement
5792 Req_Nam => Name_Elaborate_All,
5793 In_State => In_State);
5796 -- Otherwise ensure that the unit with the target body is elaborated
5797 -- prior to the main unit.
5800 Ensure_Prior_Elaboration
5802 Unit_Id => Unit (Subp_Rep),
5803 Prag_Nam => Name_Elaborate_All,
5804 In_State => In_State);
5806 end Process_Conditional_ABE_Call_SPARK;
5808 -------------------------------------------
5809 -- Process_Conditional_ABE_Instantiation --
5810 -------------------------------------------
5812 procedure Process_Conditional_ABE_Instantiation
5814 Inst_Rep : Scenario_Rep_Id;
5815 In_State : Processing_In_State)
5817 Gen_Id : constant Entity_Id := Target (Inst_Rep);
5818 Gen_Rep : constant Target_Rep_Id :=
5819 Target_Representation_Of (Gen_Id, In_State);
5821 SPARK_Rules_On : constant Boolean :=
5822 SPARK_Mode_Of (Inst_Rep) = Is_On
5823 and then SPARK_Mode_Of (Gen_Rep) = Is_On;
5825 New_In_State : Processing_In_State := In_State;
5826 -- Each step of the Processing phase constitutes a new state
5829 -- Output relevant information when switch -gnatel (info messages on
5830 -- implicit Elaborate[_All] pragmas) is in effect.
5832 if Elab_Info_Messages
5833 and then not New_In_State.Suppress_Info_Messages
5839 In_SPARK => SPARK_Rules_On);
5842 -- Nothing to do when the instantiation is a guaranteed ABE
5844 if Is_Known_Guaranteed_ABE (Inst) then
5847 -- Nothing to do when the root scenario appears at the declaration
5848 -- level and the generic is in the same unit, but outside this
5852 -- procedure Gen is ...; -- generic declaration
5854 -- procedure Proc is
5855 -- function A ... is
5857 -- if Some_Condition then
5859 -- procedure I is new Gen; -- instantiation site
5864 -- X : ... := A; -- root scenario
5871 -- In the example above, the context of X is the declarative region
5872 -- of Proc. The "elaboration" of X may eventually reach Gen which
5873 -- appears outside of X's context. Gen is relevant only when Proc is
5874 -- invoked, but this happens only by means of "normal" elaboration,
5875 -- therefore Gen must not be considered if this is not the case.
5877 elsif Is_Up_Level_Target
5878 (Targ_Decl => Spec_Declaration (Gen_Rep),
5879 In_State => New_In_State)
5884 -- Warnings are suppressed when a prior scenario is already in that
5885 -- mode, or when the instantiation has warnings suppressed. Update
5886 -- the state of the processing phase to reflect this.
5888 New_In_State.Suppress_Warnings :=
5889 New_In_State.Suppress_Warnings
5890 or else not Elaboration_Warnings_OK (Inst_Rep);
5892 -- The SPARK rules are in effect
5894 if SPARK_Rules_On then
5895 Process_Conditional_ABE_Instantiation_SPARK
5897 Inst_Rep => Inst_Rep,
5900 In_State => New_In_State);
5902 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
5903 -- violate the SPARK rules.
5906 Process_Conditional_ABE_Instantiation_Ada
5908 Inst_Rep => Inst_Rep,
5911 In_State => New_In_State);
5913 end Process_Conditional_ABE_Instantiation;
5915 -----------------------------------------------
5916 -- Process_Conditional_ABE_Instantiation_Ada --
5917 -----------------------------------------------
5919 procedure Process_Conditional_ABE_Instantiation_Ada
5921 Inst_Rep : Scenario_Rep_Id;
5923 Gen_Rep : Target_Rep_Id;
5924 In_State : Processing_In_State)
5926 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep);
5927 Root : constant Node_Id := Root_Scenario;
5928 Unit_Id : constant Entity_Id := Unit (Gen_Rep);
5930 Check_OK : constant Boolean :=
5931 not In_State.Suppress_Checks
5932 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored
5933 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored
5934 and then Elaboration_Checks_OK (Inst_Rep)
5935 and then Elaboration_Checks_OK (Gen_Rep);
5936 -- A run-time ABE check may be installed only when both the instance
5937 -- and the generic have active elaboration checks and both are not
5938 -- ignored Ghost constructs.
5940 New_In_State : Processing_In_State := In_State;
5941 -- Each step of the Processing phase constitutes a new state
5944 -- Nothing to do when the instantiation is ABE-safe
5951 -- package body Gen is
5956 -- procedure Main is
5957 -- package Inst is new Gen (ABE); -- safe instantiation
5960 if Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then
5963 -- The instantiation and the generic body are both in the main unit
5965 -- If the root scenario appears prior to the generic body, then this
5966 -- is a possible ABE with respect to the root scenario.
5973 -- function A ... is
5975 -- if Some_Condition then
5977 -- package Inst is new Gen; -- instantiation site
5981 -- X : ... := A; -- root scenario
5983 -- package body Gen is -- generic body
5987 -- Y : ... := A; -- root scenario
5989 -- IMPORTANT: The instantiation of Gen is a possible ABE for X,
5990 -- but not for Y. Installing an unconditional ABE raise prior to
5991 -- the instance site would be wrong as it will fail for Y as well,
5992 -- but in Y's case the instantiation of Gen is never an ABE.
5994 elsif Present (Body_Decl)
5995 and then In_Extended_Main_Code_Unit (Body_Decl)
5997 if Earlier_In_Extended_Unit (Root, Body_Decl) then
5999 -- Do not emit any ABE diagnostics when a previous scenario in
6000 -- this traversal has suppressed elaboration warnings.
6002 if New_In_State.Suppress_Warnings then
6005 -- Do not emit any ABE diagnostics when the instantiation
6006 -- occurs in partial finalization context because this leads
6007 -- to unwanted noise.
6009 elsif New_In_State.Within_Partial_Finalization then
6012 -- Otherwise output the diagnostic
6016 ("??cannot instantiate & before body seen", Inst, Gen_Id);
6018 ("\Program_Error may be raised at run time", Inst);
6020 Output_Active_Scenarios (Inst, New_In_State);
6023 -- Install a conditional run-time ABE check to verify that the
6024 -- generic body has been elaborated prior to the instantiation.
6027 Install_Scenario_ABE_Check
6030 Targ_Rep => Gen_Rep,
6031 Disable => Inst_Rep);
6033 -- Update the state of the Processing phase to indicate that
6034 -- no implicit Elaborate[_All] pragma must be generated from
6042 -- function A ... is
6044 -- if Some_Condition then
6046 -- declare Inst is new Gen;
6052 -- package body Gen is
6054 -- External.Subp; -- imparts Elaborate_All
6057 -- If Some_Condition is True, then the ABE check will fail
6058 -- at runtime and the call to External.Subp will never take
6059 -- place, rendering the implicit Elaborate_All useless.
6061 -- If the value of Some_Condition is False, then the call
6062 -- to External.Subp will never take place, rendering the
6063 -- implicit Elaborate_All useless.
6065 New_In_State.Suppress_Implicit_Pragmas := True;
6069 -- Otherwise the generic body is not available in this compilation
6070 -- or it resides in an external unit. Install a run-time ABE check
6071 -- to verify that the generic body has been elaborated prior to the
6072 -- instantiation when the dynamic model is in effect.
6075 and then New_In_State.Processing = Dynamic_Model_Processing
6077 Install_Unit_ABE_Check
6080 Disable => Inst_Rep);
6083 -- Ensure that the unit with the generic body is elaborated prior
6084 -- to the main unit. No implicit pragma has to be generated if the
6085 -- instantiation has elaboration checks suppressed. This behaviour
6086 -- parallels that of the old ABE mechanism.
6088 if Elaboration_Checks_OK (Inst_Rep) then
6089 Ensure_Prior_Elaboration
6092 Prag_Nam => Name_Elaborate,
6093 In_State => New_In_State);
6095 end Process_Conditional_ABE_Instantiation_Ada;
6097 -------------------------------------------------
6098 -- Process_Conditional_ABE_Instantiation_SPARK --
6099 -------------------------------------------------
6101 procedure Process_Conditional_ABE_Instantiation_SPARK
6103 Inst_Rep : Scenario_Rep_Id;
6105 Gen_Rep : Target_Rep_Id;
6106 In_State : Processing_In_State)
6108 pragma Unreferenced (Inst_Rep);
6113 -- Ensure that a suitable elaboration model is in effect for SPARK
6114 -- rule verification.
6116 Check_SPARK_Model_In_Effect;
6118 -- A source instantiation imposes an Elaborate[_All] requirement
6119 -- on the context of the main unit. Determine whether the context
6120 -- has a pragma strong enough to meet the requirement. The check
6121 -- is orthogonal to the ABE ramifications of the instantiation.
6123 -- IMPORTANT: This check must be performed only when switch -gnatd.v
6124 -- (enforce SPARK elaboration rules in SPARK code) is active because
6125 -- the static model can ensure the prior elaboration of the unit
6126 -- which contains a body by installing an implicit Elaborate[_All]
6129 if Debug_Flag_Dot_V then
6130 if Nkind (Inst) = N_Package_Instantiation then
6131 Req_Nam := Name_Elaborate_All;
6133 Req_Nam := Name_Elaborate;
6136 Meet_Elaboration_Requirement
6140 In_State => In_State);
6142 -- Otherwise ensure that the unit with the target body is elaborated
6143 -- prior to the main unit.
6146 Ensure_Prior_Elaboration
6148 Unit_Id => Unit (Gen_Rep),
6149 Prag_Nam => Name_Elaborate,
6150 In_State => In_State);
6152 end Process_Conditional_ABE_Instantiation_SPARK;
6154 -------------------------------------------------
6155 -- Process_Conditional_ABE_Variable_Assignment --
6156 -------------------------------------------------
6158 procedure Process_Conditional_ABE_Variable_Assignment
6160 Asmt_Rep : Scenario_Rep_Id;
6161 In_State : Processing_In_State)
6164 Var_Id : constant Entity_Id := Target (Asmt_Rep);
6165 Var_Rep : constant Target_Rep_Id :=
6166 Target_Representation_Of (Var_Id, In_State);
6168 SPARK_Rules_On : constant Boolean :=
6169 SPARK_Mode_Of (Asmt_Rep) = Is_On
6170 and then SPARK_Mode_Of (Var_Rep) = Is_On;
6173 -- Output relevant information when switch -gnatel (info messages on
6174 -- implicit Elaborate[_All] pragmas) is in effect.
6176 if Elab_Info_Messages
6177 and then not In_State.Suppress_Info_Messages
6180 (Msg => "assignment to & during elaboration",
6184 In_SPARK => SPARK_Rules_On);
6187 -- The SPARK rules are in effect. These rules are applied regardless
6188 -- of whether switch -gnatd.v (enforce SPARK elaboration rules in
6189 -- SPARK code) is in effect because the static model cannot ensure
6190 -- safe assignment of variables.
6192 if SPARK_Rules_On then
6193 Process_Conditional_ABE_Variable_Assignment_SPARK
6195 Asmt_Rep => Asmt_Rep,
6198 In_State => In_State);
6200 -- Otherwise the Ada rules are in effect
6203 Process_Conditional_ABE_Variable_Assignment_Ada
6205 Asmt_Rep => Asmt_Rep,
6208 In_State => In_State);
6210 end Process_Conditional_ABE_Variable_Assignment;
6212 -----------------------------------------------------
6213 -- Process_Conditional_ABE_Variable_Assignment_Ada --
6214 -----------------------------------------------------
6216 procedure Process_Conditional_ABE_Variable_Assignment_Ada
6218 Asmt_Rep : Scenario_Rep_Id;
6220 Var_Rep : Target_Rep_Id;
6221 In_State : Processing_In_State)
6223 pragma Unreferenced (Asmt_Rep);
6225 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep);
6226 Unit_Id : constant Entity_Id := Unit (Var_Rep);
6229 -- Emit a warning when an uninitialized variable declared in a
6230 -- package spec without a pragma Elaborate_Body is initialized
6231 -- by elaboration code within the corresponding body.
6233 if Is_Elaboration_Warnings_OK_Id (Var_Id)
6234 and then not Is_Initialized (Var_Decl)
6235 and then not Has_Pragma_Elaborate_Body (Unit_Id)
6237 -- Do not emit any ABE diagnostics when a previous scenario in
6238 -- this traversal has suppressed elaboration warnings.
6240 if not In_State.Suppress_Warnings then
6242 ("??variable & can be accessed by clients before this "
6243 & "initialization", Asmt, Var_Id);
6246 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
6247 & "initialization", Asmt, Unit_Id);
6249 Output_Active_Scenarios (Asmt, In_State);
6252 -- Generate an implicit Elaborate_Body in the spec
6254 Set_Elaborate_Body_Desirable (Unit_Id);
6256 end Process_Conditional_ABE_Variable_Assignment_Ada;
6258 -------------------------------------------------------
6259 -- Process_Conditional_ABE_Variable_Assignment_SPARK --
6260 -------------------------------------------------------
6262 procedure Process_Conditional_ABE_Variable_Assignment_SPARK
6264 Asmt_Rep : Scenario_Rep_Id;
6266 Var_Rep : Target_Rep_Id;
6267 In_State : Processing_In_State)
6269 pragma Unreferenced (Asmt_Rep);
6271 Var_Decl : constant Node_Id := Variable_Declaration (Var_Rep);
6272 Unit_Id : constant Entity_Id := Unit (Var_Rep);
6275 -- Ensure that a suitable elaboration model is in effect for SPARK
6276 -- rule verification.
6278 Check_SPARK_Model_In_Effect;
6280 -- Do not emit any ABE diagnostics when a previous scenario in this
6281 -- traversal has suppressed elaboration warnings.
6283 if In_State.Suppress_Warnings then
6286 -- Emit an error when an initialized variable declared in a package
6287 -- spec that is missing pragma Elaborate_Body is further modified by
6288 -- elaboration code within the corresponding body.
6290 elsif Is_Elaboration_Warnings_OK_Id (Var_Id)
6291 and then Is_Initialized (Var_Decl)
6292 and then not Has_Pragma_Elaborate_Body (Unit_Id)
6295 ("variable & modified by elaboration code in package body",
6299 ("\add pragma ""Elaborate_Body"" to spec & to ensure full "
6300 & "initialization", Asmt, Unit_Id);
6302 Output_Active_Scenarios (Asmt, In_State);
6304 end Process_Conditional_ABE_Variable_Assignment_SPARK;
6306 ------------------------------------------------
6307 -- Process_Conditional_ABE_Variable_Reference --
6308 ------------------------------------------------
6310 procedure Process_Conditional_ABE_Variable_Reference
6312 Ref_Rep : Scenario_Rep_Id;
6313 In_State : Processing_In_State)
6315 Var_Id : constant Entity_Id := Target (Ref);
6316 Var_Rep : Target_Rep_Id;
6317 Unit_Id : Entity_Id;
6320 -- Nothing to do when the variable reference is not a read
6322 if not Is_Read_Reference (Ref_Rep) then
6326 Var_Rep := Target_Representation_Of (Var_Id, In_State);
6327 Unit_Id := Unit (Var_Rep);
6329 -- Output relevant information when switch -gnatel (info messages on
6330 -- implicit Elaborate[_All] pragmas) is in effect.
6332 if Elab_Info_Messages
6333 and then not In_State.Suppress_Info_Messages
6336 (Msg => "read of variable & during elaboration",
6343 -- Nothing to do when the variable appears within the main unit
6344 -- because diagnostics on reads are relevant only for external
6347 if Is_Same_Unit (Unit_Id, Cunit_Entity (Main_Unit)) then
6350 -- Nothing to do when the variable is already initialized. Note that
6351 -- the variable may be further modified by the external unit.
6353 elsif Is_Initialized (Variable_Declaration (Var_Rep)) then
6356 -- Nothing to do when the external unit guarantees the initialization
6357 -- of the variable by means of pragma Elaborate_Body.
6359 elsif Has_Pragma_Elaborate_Body (Unit_Id) then
6362 -- A variable read imposes an Elaborate requirement on the context of
6363 -- the main unit. Determine whether the context has a pragma strong
6364 -- enough to meet the requirement.
6367 Meet_Elaboration_Requirement
6370 Req_Nam => Name_Elaborate,
6371 In_State => In_State);
6373 end Process_Conditional_ABE_Variable_Reference;
6375 -----------------------------------
6376 -- Traverse_Conditional_ABE_Body --
6377 -----------------------------------
6379 procedure Traverse_Conditional_ABE_Body
6381 In_State : Processing_In_State)
6386 Requires_Processing => Is_Conditional_ABE_Scenario'Access,
6387 Processor => Process_Conditional_ABE'Access,
6388 In_State => In_State);
6389 end Traverse_Conditional_ABE_Body;
6390 end Conditional_ABE_Processor;
6396 procedure Destroy (NE : in out Node_Or_Entity_Id) is
6397 pragma Unreferenced (NE);
6406 package body Diagnostics is
6412 procedure Elab_Msg_NE
6419 function Prefix return String;
6420 pragma Inline (Prefix);
6421 -- Obtain the prefix of the message
6423 function Suffix return String;
6424 pragma Inline (Suffix);
6425 -- Obtain the suffix of the message
6431 function Prefix return String is
6444 function Suffix return String is
6453 -- Start of processing for Elab_Msg_NE
6456 Error_Msg_NE (Prefix & Msg & Suffix, N, Id);
6465 Subp_Id : Entity_Id;
6469 procedure Info_Accept_Alternative;
6470 pragma Inline (Info_Accept_Alternative);
6471 -- Output information concerning an accept alternative
6473 procedure Info_Simple_Call;
6474 pragma Inline (Info_Simple_Call);
6475 -- Output information concerning the call
6477 procedure Info_Type_Actions (Action : String);
6478 pragma Inline (Info_Type_Actions);
6479 -- Output information concerning action Action of a type
6481 procedure Info_Verification_Call
6485 pragma Inline (Info_Verification_Call);
6486 -- Output information concerning the verification of predicate Pred
6487 -- applied to related entity Id with kind Id_Kind.
6489 -----------------------------
6490 -- Info_Accept_Alternative --
6491 -----------------------------
6493 procedure Info_Accept_Alternative is
6494 Entry_Id : constant Entity_Id := Receiving_Entry (Subp_Id);
6495 pragma Assert (Present (Entry_Id));
6499 (Msg => "accept for entry & during elaboration",
6502 Info_Msg => Info_Msg,
6503 In_SPARK => In_SPARK);
6504 end Info_Accept_Alternative;
6506 ----------------------
6507 -- Info_Simple_Call --
6508 ----------------------
6510 procedure Info_Simple_Call is
6513 (Msg => "call to & during elaboration",
6516 Info_Msg => Info_Msg,
6517 In_SPARK => In_SPARK);
6518 end Info_Simple_Call;
6520 -----------------------
6521 -- Info_Type_Actions --
6522 -----------------------
6524 procedure Info_Type_Actions (Action : String) is
6525 Typ : constant Entity_Id := First_Formal_Type (Subp_Id);
6526 pragma Assert (Present (Typ));
6530 (Msg => Action & " actions for type & during elaboration",
6533 Info_Msg => Info_Msg,
6534 In_SPARK => In_SPARK);
6535 end Info_Type_Actions;
6537 ----------------------------
6538 -- Info_Verification_Call --
6539 ----------------------------
6541 procedure Info_Verification_Call
6546 pragma Assert (Present (Id));
6551 "verification of " & Pred & " of " & Id_Kind & " & during "
6555 Info_Msg => Info_Msg,
6556 In_SPARK => In_SPARK);
6557 end Info_Verification_Call;
6559 -- Start of processing for Info_Call
6562 -- Do not output anything for targets defined in internal units
6563 -- because this creates noise.
6565 if not In_Internal_Unit (Subp_Id) then
6567 -- Accept alternative
6569 if Is_Accept_Alternative_Proc (Subp_Id) then
6570 Info_Accept_Alternative;
6574 elsif Is_TSS (Subp_Id, TSS_Deep_Adjust) then
6575 Info_Type_Actions ("adjustment");
6577 -- Default_Initial_Condition
6579 elsif Is_Default_Initial_Condition_Proc (Subp_Id) then
6580 Info_Verification_Call
6581 (Pred => "Default_Initial_Condition",
6582 Id => First_Formal_Type (Subp_Id),
6587 elsif Is_Protected_Entry (Subp_Id) then
6590 -- Task entry calls are never processed because the entry being
6591 -- invoked does not have a corresponding "body", it has a select.
6593 elsif Is_Task_Entry (Subp_Id) then
6598 elsif Is_TSS (Subp_Id, TSS_Deep_Finalize) then
6599 Info_Type_Actions ("finalization");
6601 -- Calls to _Finalizer procedures must not appear in the output
6602 -- because this creates confusing noise.
6604 elsif Is_Finalizer_Proc (Subp_Id) then
6607 -- Initial_Condition
6609 elsif Is_Initial_Condition_Proc (Subp_Id) then
6610 Info_Verification_Call
6611 (Pred => "Initial_Condition",
6612 Id => Find_Enclosing_Scope (Call),
6613 Id_Kind => "package");
6617 elsif Is_Init_Proc (Subp_Id)
6618 or else Is_TSS (Subp_Id, TSS_Deep_Initialize)
6620 Info_Type_Actions ("initialization");
6624 elsif Is_Invariant_Proc (Subp_Id) then
6625 Info_Verification_Call
6626 (Pred => "invariants",
6627 Id => First_Formal_Type (Subp_Id),
6630 -- Partial invariant calls must not appear in the output because
6631 -- this creates confusing noise.
6633 elsif Is_Partial_Invariant_Proc (Subp_Id) then
6638 elsif Is_Postconditions_Proc (Subp_Id) then
6639 Info_Verification_Call
6640 (Pred => "postconditions",
6641 Id => Find_Enclosing_Scope (Call),
6642 Id_Kind => "subprogram");
6644 -- Subprograms must come last because some of the previous cases
6645 -- fall under this category.
6647 elsif Ekind (Subp_Id) = E_Function then
6650 elsif Ekind (Subp_Id) = E_Procedure then
6654 pragma Assert (False);
6660 ------------------------
6661 -- Info_Instantiation --
6662 ------------------------
6664 procedure Info_Instantiation
6672 (Msg => "instantiation of & during elaboration",
6675 Info_Msg => Info_Msg,
6676 In_SPARK => In_SPARK);
6677 end Info_Instantiation;
6679 -----------------------------
6680 -- Info_Variable_Reference --
6681 -----------------------------
6683 procedure Info_Variable_Reference
6690 if Is_Read (Ref) then
6692 (Msg => "read of variable & during elaboration",
6695 Info_Msg => Info_Msg,
6696 In_SPARK => In_SPARK);
6698 end Info_Variable_Reference;
6701 ---------------------------------
6702 -- Early_Call_Region_Processor --
6703 ---------------------------------
6705 package body Early_Call_Region_Processor is
6707 ---------------------
6708 -- Data structures --
6709 ---------------------
6711 -- The following map relates early call regions to subprogram bodies
6713 procedure Destroy (N : in out Node_Id);
6716 package ECR_Map is new Dynamic_Hash_Tables
6717 (Key_Type => Entity_Id,
6718 Value_Type => Node_Id,
6720 Expansion_Threshold => 1.5,
6721 Expansion_Factor => 2,
6722 Compression_Threshold => 0.3,
6723 Compression_Factor => 2,
6725 Destroy_Value => Destroy,
6728 Early_Call_Regions_Map : ECR_Map.Dynamic_Hash_Table := ECR_Map.Nil;
6730 -----------------------
6731 -- Local subprograms --
6732 -----------------------
6734 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id;
6735 pragma Inline (Early_Call_Region);
6736 -- Obtain the early call region associated with entry or subprogram body
6739 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id);
6740 pragma Inline (Set_Early_Call_Region);
6741 -- Associate an early call region with begins at construct Start with
6742 -- entry or subprogram body Body_Id.
6748 procedure Destroy (N : in out Node_Id) is
6749 pragma Unreferenced (N);
6754 -----------------------
6755 -- Early_Call_Region --
6756 -----------------------
6758 function Early_Call_Region (Body_Id : Entity_Id) return Node_Id is
6759 pragma Assert (Present (Body_Id));
6761 return ECR_Map.Get (Early_Call_Regions_Map, Body_Id);
6762 end Early_Call_Region;
6764 ------------------------------------------
6765 -- Finalize_Early_Call_Region_Processor --
6766 ------------------------------------------
6768 procedure Finalize_Early_Call_Region_Processor is
6770 ECR_Map.Destroy (Early_Call_Regions_Map);
6771 end Finalize_Early_Call_Region_Processor;
6773 ----------------------------
6774 -- Find_Early_Call_Region --
6775 ----------------------------
6777 function Find_Early_Call_Region
6778 (Body_Decl : Node_Id;
6779 Assume_Elab_Body : Boolean := False;
6780 Skip_Memoization : Boolean := False) return Node_Id
6782 -- NOTE: The routines within Find_Early_Call_Region are intentionally
6783 -- unnested to avoid deep indentation of code.
6785 ECR_Found : exception;
6786 -- This exception is raised when the early call region has been found
6788 Start : Node_Id := Empty;
6789 -- The start of the early call region. This variable is updated by
6790 -- the various nested routines. Due to the use of exceptions, the
6791 -- variable must be global to the nested routines.
6793 -- The algorithm implemented in this routine attempts to find the
6794 -- early call region of a subprogram body by inspecting constructs
6795 -- in reverse declarative order, while navigating the tree. The
6796 -- algorithm consists of an Inspection phase and Advancement phase.
6797 -- The pseudocode is as follows:
6801 -- advancement phase
6804 -- The infinite loop is terminated by raising exception ECR_Found.
6805 -- The algorithm utilizes two pointers, Curr and Start, to represent
6806 -- the current construct to inspect and the start of the early call
6809 -- IMPORTANT: The algorithm must maintain the following invariant at
6810 -- all time for it to function properly:
6812 -- A nested construct is entered only when it contains suitable
6815 -- This guarantees that leaving a nested or encapsulating construct
6816 -- functions properly.
6818 -- The Inspection phase determines whether the current construct is
6819 -- non-preelaborable, and if it is, the algorithm terminates.
6821 -- The Advancement phase walks the tree in reverse declarative order,
6822 -- while entering and leaving nested and encapsulating constructs. It
6823 -- may also terminate the elaborithm. There are several special cases
6830 -- <construct N-1> <- Curr
6831 -- <construct N> <- Start
6832 -- <subprogram body>
6834 -- In the general case, a declarative or statement list is traversed
6835 -- in reverse order where Curr is the lead pointer, and Start is the
6836 -- last preelaborable construct.
6838 -- 2) Entering handled bodies
6840 -- package body Nested is <- Curr (2.3)
6841 -- <declarations> <- Curr (2.2)
6843 -- <statements> <- Curr (2.1)
6845 -- <construct> <- Start
6847 -- In this case, the algorithm enters a handled body by starting from
6848 -- the last statement (2.1), or the last declaration (2.2), or the
6849 -- body is consumed (2.3) because it is empty and thus preelaborable.
6851 -- 3) Entering package declarations
6853 -- package Nested is <- Curr (2.3)
6854 -- <visible declarations> <- Curr (2.2)
6856 -- <private declarations> <- Curr (2.1)
6858 -- <construct> <- Start
6860 -- In this case, the algorithm enters a package declaration by
6861 -- starting from the last private declaration (2.1), the last visible
6862 -- declaration (2.2), or the package is consumed (2.3) because it is
6863 -- empty and thus preelaborable.
6865 -- 4) Transitioning from list to list of the same construct
6867 -- Certain constructs have two eligible lists. The algorithm must
6868 -- thus transition from the second to the first list when the second
6869 -- list is exhausted.
6871 -- declare <- Curr (4.2)
6872 -- <declarations> <- Curr (4.1)
6874 -- <statements> <- Start
6877 -- In this case, the algorithm has exhausted the second list (the
6878 -- statements in the example above), and continues with the last
6879 -- declaration (4.1) or the construct is consumed (4.2) because it
6880 -- contains only preelaborable code.
6882 -- 5) Transitioning from list to construct
6884 -- tack body Task is <- Curr (5.1)
6886 -- <construct 1> <- Start
6888 -- In this case, the algorithm has exhausted a list, Curr is Empty,
6889 -- and the owner of the list is consumed (5.1).
6891 -- 6) Transitioning from unit to unit
6893 -- A package body with a spec subject to pragma Elaborate_Body
6894 -- extends the possible range of the early call region to the package
6897 -- package Pack is <- Curr (6.3)
6898 -- pragma Elaborate_Body; <- Curr (6.2)
6899 -- <visible declarations> <- Curr (6.2)
6901 -- <private declarations> <- Curr (6.1)
6904 -- package body Pack is <- Curr, Start
6906 -- In this case, the algorithm has reached a package body compilation
6907 -- unit whose spec is subject to pragma Elaborate_Body, or the caller
6908 -- of the algorithm has specified this behavior. This transition is
6909 -- equivalent to 3).
6911 -- 7) Transitioning from unit to termination
6913 -- Reaching a compilation unit always terminates the algorithm as
6914 -- there are no more lists to examine. This must take case 6) into
6917 -- 8) Transitioning from subunit to stub
6919 -- package body Pack is separate; <- Curr (8.1)
6922 -- package body Pack is <- Curr, Start
6924 -- Reaching a subunit continues the search from the corresponding
6927 procedure Advance (Curr : in out Node_Id);
6928 pragma Inline (Advance);
6929 -- Update the Curr and Start pointers depending on their location
6930 -- in the tree to the next eligible construct. This routine raises
6933 procedure Enter_Handled_Body (Curr : in out Node_Id);
6934 pragma Inline (Enter_Handled_Body);
6935 -- Update the Curr and Start pointers to enter a nested handled body
6936 -- if applicable. This routine raises ECR_Found.
6938 procedure Enter_Package_Declaration (Curr : in out Node_Id);
6939 pragma Inline (Enter_Package_Declaration);
6940 -- Update the Curr and Start pointers to enter a nested package spec
6941 -- if applicable. This routine raises ECR_Found.
6943 function Find_ECR (N : Node_Id) return Node_Id;
6944 pragma Inline (Find_ECR);
6945 -- Find an early call region starting from arbitrary node N
6947 function Has_Suitable_Construct (List : List_Id) return Boolean;
6948 pragma Inline (Has_Suitable_Construct);
6949 -- Determine whether list List contains a suitable construct for
6950 -- inclusion into an early call region.
6952 procedure Include (N : Node_Id; Curr : out Node_Id);
6953 pragma Inline (Include);
6954 -- Update the Curr and Start pointers to include arbitrary construct
6955 -- N in the early call region. This routine raises ECR_Found.
6957 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean;
6958 pragma Inline (Is_OK_Preelaborable_Construct);
6959 -- Determine whether arbitrary node N denotes a preelaboration-safe
6962 function Is_Suitable_Construct (N : Node_Id) return Boolean;
6963 pragma Inline (Is_Suitable_Construct);
6964 -- Determine whether arbitrary node N denotes a suitable construct
6965 -- for inclusion into the early call region.
6967 procedure Transition_Body_Declarations
6969 Curr : out Node_Id);
6970 pragma Inline (Transition_Body_Declarations);
6971 -- Update the Curr and Start pointers when construct Bod denotes a
6972 -- block statement or a suitable body. This routine raises ECR_Found.
6974 procedure Transition_Handled_Statements
6976 Curr : out Node_Id);
6977 pragma Inline (Transition_Handled_Statements);
6978 -- Update the Curr and Start pointers when node HSS denotes a handled
6979 -- sequence of statements. This routine raises ECR_Found.
6981 procedure Transition_Spec_Declarations
6983 Curr : out Node_Id);
6984 pragma Inline (Transition_Spec_Declarations);
6985 -- Update the Curr and Start pointers when construct Spec denotes
6986 -- a concurrent definition or a package spec. This routine raises
6989 procedure Transition_Unit (Unit : Node_Id; Curr : out Node_Id);
6990 pragma Inline (Transition_Unit);
6991 -- Update the Curr and Start pointers when node Unit denotes a
6992 -- potential compilation unit. This routine raises ECR_Found.
6998 procedure Advance (Curr : in out Node_Id) is
7002 -- Curr denotes one of the following cases upon entry into this
7005 -- * Empty - There is no current construct when a declarative or
7006 -- a statement list has been exhausted. This does not indicate
7007 -- that the early call region has been computed as it is still
7008 -- possible to transition to another list.
7010 -- * Encapsulator - The current construct wraps declarations
7011 -- and/or statements. This indicates that the early call
7012 -- region may extend within the nested construct.
7014 -- * Preelaborable - The current construct is preelaborable
7015 -- because Find_ECR would not invoke Advance if this was not
7018 -- The current construct is an encapsulator or is preelaborable
7020 if Present (Curr) then
7022 -- Enter encapsulators by inspecting their declarations and/or
7025 if Nkind_In (Curr, N_Block_Statement, N_Package_Body) then
7026 Enter_Handled_Body (Curr);
7028 elsif Nkind (Curr) = N_Package_Declaration then
7029 Enter_Package_Declaration (Curr);
7031 -- Early call regions have a property which can be exploited to
7032 -- optimize the algorithm.
7034 -- <preceding subprogram body>
7035 -- <preelaborable construct 1>
7037 -- <preelaborable construct N>
7038 -- <initiating subprogram body>
7040 -- If a traversal initiated from a subprogram body reaches a
7041 -- preceding subprogram body, then both bodies share the same
7042 -- early call region.
7044 -- The property results in the following desirable effects:
7046 -- * If the preceding body already has an early call region,
7047 -- then the initiating body can reuse it. This minimizes the
7048 -- amount of processing performed by the algorithm.
7050 -- * If the preceding body lack an early call region, then the
7051 -- algorithm can compute the early call region, and reuse it
7052 -- for the initiating body. This processing performs the same
7053 -- amount of work, but has the beneficial effect of computing
7054 -- the early call regions of all preceding bodies.
7056 elsif Nkind_In (Curr, N_Entry_Body, N_Subprogram_Body) then
7058 Find_Early_Call_Region
7060 Assume_Elab_Body => Assume_Elab_Body,
7061 Skip_Memoization => Skip_Memoization);
7065 -- Otherwise current construct is preelaborable. Unpdate the
7066 -- early call region to include it.
7069 Include (Curr, Curr);
7072 -- Otherwise the current construct is missing, indicating that the
7073 -- current list has been exhausted. Depending on the context of
7074 -- the list, several transitions are possible.
7077 -- The invariant of the algorithm ensures that Curr and Start
7078 -- are at the same level of nesting at the point of transition.
7079 -- The algorithm can determine which list the traversal came
7080 -- from by examining Start.
7082 Context := Parent (Start);
7084 -- Attempt the following transitions:
7086 -- private declarations -> visible declarations
7087 -- private declarations -> upper level
7088 -- private declarations -> terminate
7089 -- visible declarations -> upper level
7090 -- visible declarations -> terminate
7092 if Nkind_In (Context, N_Package_Specification,
7093 N_Protected_Definition,
7096 Transition_Spec_Declarations (Context, Curr);
7098 -- Attempt the following transitions:
7100 -- statements -> declarations
7101 -- statements -> upper level
7102 -- statements -> corresponding package spec (Elab_Body)
7103 -- statements -> terminate
7105 elsif Nkind (Context) = N_Handled_Sequence_Of_Statements then
7106 Transition_Handled_Statements (Context, Curr);
7108 -- Attempt the following transitions:
7110 -- declarations -> upper level
7111 -- declarations -> corresponding package spec (Elab_Body)
7112 -- declarations -> terminate
7114 elsif Nkind_In (Context, N_Block_Statement,
7121 Transition_Body_Declarations (Context, Curr);
7123 -- Otherwise it is not possible to transition. Stop the search
7124 -- because there are no more declarations or statements to
7133 --------------------------
7134 -- Enter_Handled_Body --
7135 --------------------------
7137 procedure Enter_Handled_Body (Curr : in out Node_Id) is
7138 Decls : constant List_Id := Declarations (Curr);
7139 HSS : constant Node_Id := Handled_Statement_Sequence (Curr);
7140 Stmts : List_Id := No_List;
7143 if Present (HSS) then
7144 Stmts := Statements (HSS);
7147 -- The handled body has a non-empty statement sequence. The
7148 -- construct to inspect is the last statement.
7150 if Has_Suitable_Construct (Stmts) then
7151 Curr := Last (Stmts);
7153 -- The handled body lacks statements, but has non-empty
7154 -- declarations. The construct to inspect is the last declaration.
7156 elsif Has_Suitable_Construct (Decls) then
7157 Curr := Last (Decls);
7159 -- Otherwise the handled body lacks both declarations and
7160 -- statements. The construct to inspect is the node which precedes
7161 -- the handled body. Update the early call region to include the
7165 Include (Curr, Curr);
7167 end Enter_Handled_Body;
7169 -------------------------------
7170 -- Enter_Package_Declaration --
7171 -------------------------------
7173 procedure Enter_Package_Declaration (Curr : in out Node_Id) is
7174 Pack_Spec : constant Node_Id := Specification (Curr);
7175 Prv_Decls : constant List_Id := Private_Declarations (Pack_Spec);
7176 Vis_Decls : constant List_Id := Visible_Declarations (Pack_Spec);
7179 -- The package has a non-empty private declarations. The construct
7180 -- to inspect is the last private declaration.
7182 if Has_Suitable_Construct (Prv_Decls) then
7183 Curr := Last (Prv_Decls);
7185 -- The package lacks private declarations, but has non-empty
7186 -- visible declarations. In this case the construct to inspect
7187 -- is the last visible declaration.
7189 elsif Has_Suitable_Construct (Vis_Decls) then
7190 Curr := Last (Vis_Decls);
7192 -- Otherwise the package lacks any declarations. The construct
7193 -- to inspect is the node which precedes the package. Update the
7194 -- early call region to include the package declaration.
7197 Include (Curr, Curr);
7199 end Enter_Package_Declaration;
7205 function Find_ECR (N : Node_Id) return Node_Id is
7209 -- The early call region starts at N
7214 -- Inspect each node in reverse declarative order while going in
7215 -- and out of nested and enclosing constructs. Note that the only
7216 -- way to terminate this infinite loop is to raise ECR_Found.
7219 -- The current construct is not preelaboration-safe. Terminate
7223 and then not Is_OK_Preelaborable_Construct (Curr)
7228 -- Advance to the next suitable construct. This may terminate
7229 -- the traversal by raising ECR_Found.
7239 ----------------------------
7240 -- Has_Suitable_Construct --
7241 ----------------------------
7243 function Has_Suitable_Construct (List : List_Id) return Boolean is
7247 -- Examine the list in reverse declarative order, looking for a
7248 -- suitable construct.
7250 if Present (List) then
7251 Item := Last (List);
7252 while Present (Item) loop
7253 if Is_Suitable_Construct (Item) then
7262 end Has_Suitable_Construct;
7268 procedure Include (N : Node_Id; Curr : out Node_Id) is
7272 -- The input node is a compilation unit. This terminates the
7273 -- search because there are no more lists to inspect and there are
7274 -- no more enclosing constructs to climb up to. The transitions
7277 -- private declarations -> terminate
7278 -- visible declarations -> terminate
7279 -- statements -> terminate
7280 -- declarations -> terminate
7282 if Nkind (Parent (Start)) = N_Compilation_Unit then
7285 -- Otherwise the input node is still within some list
7288 Curr := Prev (Start);
7292 -----------------------------------
7293 -- Is_OK_Preelaborable_Construct --
7294 -----------------------------------
7296 function Is_OK_Preelaborable_Construct (N : Node_Id) return Boolean is
7298 -- Assignment statements are acceptable as long as they were
7299 -- produced by the ABE mechanism to update elaboration flags.
7301 if Nkind (N) = N_Assignment_Statement then
7302 return Is_Elaboration_Code (N);
7304 -- Block statements are acceptable even though they directly
7305 -- violate preelaborability. The intention is not to penalize
7306 -- the early call region when a block contains only preelaborable
7310 -- Val : constant Integer := 1;
7312 -- pragma Assert (Val = 1);
7316 -- Note that the Advancement phase does enter blocks, and will
7317 -- detect any non-preelaborable declarations or statements within.
7319 elsif Nkind (N) = N_Block_Statement then
7323 -- Otherwise the construct must be preelaborable. The check must
7324 -- take the syntactic and semantic structure of the construct. DO
7325 -- NOT use Is_Preelaborable_Construct here.
7327 return not Is_Non_Preelaborable_Construct (N);
7328 end Is_OK_Preelaborable_Construct;
7330 ---------------------------
7331 -- Is_Suitable_Construct --
7332 ---------------------------
7334 function Is_Suitable_Construct (N : Node_Id) return Boolean is
7335 Context : constant Node_Id := Parent (N);
7338 -- An internally-generated statement sequence which contains only
7339 -- a single null statement is not a suitable construct because it
7340 -- is a byproduct of the parser. Such a null statement should be
7341 -- excluded from the early call region because it carries the
7342 -- source location of the "end" keyword, and may lead to confusing
7345 if Nkind (N) = N_Null_Statement
7346 and then not Comes_From_Source (N)
7347 and then Present (Context)
7348 and then Nkind (Context) = N_Handled_Sequence_Of_Statements
7353 -- Otherwise only constructs which correspond to pure Ada
7354 -- constructs are considered suitable.
7359 | N_Freeze_Generic_Entity
7360 | N_Implicit_Label_Declaration
7362 | N_Pop_Constraint_Error_Label
7363 | N_Pop_Program_Error_Label
7364 | N_Pop_Storage_Error_Label
7365 | N_Push_Constraint_Error_Label
7366 | N_Push_Program_Error_Label
7367 | N_Push_Storage_Error_Label
7368 | N_SCIL_Dispatch_Table_Tag_Init
7369 | N_SCIL_Dispatching_Call
7370 | N_SCIL_Membership_Test
7371 | N_Variable_Reference_Marker
7378 end Is_Suitable_Construct;
7380 ----------------------------------
7381 -- Transition_Body_Declarations --
7382 ----------------------------------
7384 procedure Transition_Body_Declarations
7388 Decls : constant List_Id := Declarations (Bod);
7391 -- The search must come from the declarations of the body
7394 (Is_Non_Empty_List (Decls)
7395 and then List_Containing (Start) = Decls);
7397 -- The search finished inspecting the declarations. The construct
7398 -- to inspect is the node which precedes the handled body, unless
7399 -- the body is a compilation unit. The transitions are:
7401 -- declarations -> upper level
7402 -- declarations -> corresponding package spec (Elab_Body)
7403 -- declarations -> terminate
7405 Transition_Unit (Bod, Curr);
7406 end Transition_Body_Declarations;
7408 -----------------------------------
7409 -- Transition_Handled_Statements --
7410 -----------------------------------
7412 procedure Transition_Handled_Statements
7416 Bod : constant Node_Id := Parent (HSS);
7417 Decls : constant List_Id := Declarations (Bod);
7418 Stmts : constant List_Id := Statements (HSS);
7421 -- The search must come from the statements of certain bodies or
7424 pragma Assert (Nkind_In (Bod, N_Block_Statement,
7431 -- The search must come from the statements of the handled
7435 (Is_Non_Empty_List (Stmts)
7436 and then List_Containing (Start) = Stmts);
7438 -- The search finished inspecting the statements. The handled body
7439 -- has non-empty declarations. The construct to inspect is the
7440 -- last declaration. The transitions are:
7442 -- statements -> declarations
7444 if Has_Suitable_Construct (Decls) then
7445 Curr := Last (Decls);
7447 -- Otherwise the handled body lacks declarations. The construct to
7448 -- inspect is the node which precedes the handled body, unless the
7449 -- body is a compilation unit. The transitions are:
7451 -- statements -> upper level
7452 -- statements -> corresponding package spec (Elab_Body)
7453 -- statements -> terminate
7456 Transition_Unit (Bod, Curr);
7458 end Transition_Handled_Statements;
7460 ----------------------------------
7461 -- Transition_Spec_Declarations --
7462 ----------------------------------
7464 procedure Transition_Spec_Declarations
7468 Prv_Decls : constant List_Id := Private_Declarations (Spec);
7469 Vis_Decls : constant List_Id := Visible_Declarations (Spec);
7472 pragma Assert (Present (Start) and then Is_List_Member (Start));
7474 -- The search came from the private declarations and finished
7475 -- their inspection.
7477 if Has_Suitable_Construct (Prv_Decls)
7478 and then List_Containing (Start) = Prv_Decls
7480 -- The context has non-empty visible declarations. The node to
7481 -- inspect is the last visible declaration. The transitions
7484 -- private declarations -> visible declarations
7486 if Has_Suitable_Construct (Vis_Decls) then
7487 Curr := Last (Vis_Decls);
7489 -- Otherwise the context lacks visible declarations. The
7490 -- construct to inspect is the node which precedes the context
7491 -- unless the context is a compilation unit. The transitions
7494 -- private declarations -> upper level
7495 -- private declarations -> terminate
7498 Transition_Unit (Parent (Spec), Curr);
7501 -- The search came from the visible declarations and finished
7502 -- their inspections. The construct to inspect is the node which
7503 -- precedes the context, unless the context is a compilaton unit.
7504 -- The transitions are:
7506 -- visible declarations -> upper level
7507 -- visible declarations -> terminate
7509 elsif Has_Suitable_Construct (Vis_Decls)
7510 and then List_Containing (Start) = Vis_Decls
7512 Transition_Unit (Parent (Spec), Curr);
7514 -- At this point both declarative lists are empty, but the
7515 -- traversal still came from within the spec. This indicates
7516 -- that the invariant of the algorithm has been violated.
7519 pragma Assert (False);
7522 end Transition_Spec_Declarations;
7524 ---------------------
7525 -- Transition_Unit --
7526 ---------------------
7528 procedure Transition_Unit
7532 Context : constant Node_Id := Parent (Unit);
7535 -- The unit is a compilation unit. This terminates the search
7536 -- because there are no more lists to inspect and there are no
7537 -- more enclosing constructs to climb up to.
7539 if Nkind (Context) = N_Compilation_Unit then
7541 -- A package body with a corresponding spec subject to pragma
7542 -- Elaborate_Body is an exception to the above. The annotation
7543 -- allows the search to continue into the package declaration.
7544 -- The transitions are:
7546 -- statements -> corresponding package spec (Elab_Body)
7547 -- declarations -> corresponding package spec (Elab_Body)
7549 if Nkind (Unit) = N_Package_Body
7550 and then (Assume_Elab_Body
7551 or else Has_Pragma_Elaborate_Body
7552 (Corresponding_Spec (Unit)))
7554 Curr := Unit_Declaration_Node (Corresponding_Spec (Unit));
7555 Enter_Package_Declaration (Curr);
7557 -- Otherwise terminate the search. The transitions are:
7559 -- private declarations -> terminate
7560 -- visible declarations -> terminate
7561 -- statements -> terminate
7562 -- declarations -> terminate
7568 -- The unit is a subunit. The construct to inspect is the node
7569 -- which precedes the corresponding stub. Update the early call
7570 -- region to include the unit.
7572 elsif Nkind (Context) = N_Subunit then
7574 Curr := Corresponding_Stub (Context);
7576 -- Otherwise the unit is nested. The construct to inspect is the
7577 -- node which precedes the unit. Update the early call region to
7578 -- include the unit.
7581 Include (Unit, Curr);
7583 end Transition_Unit;
7587 Body_Id : constant Entity_Id := Unique_Defining_Entity (Body_Decl);
7590 -- Start of processing for Find_Early_Call_Region
7593 -- The caller demands the start of the early call region without
7594 -- saving or retrieving it to/from internal data structures.
7596 if Skip_Memoization then
7597 Region := Find_ECR (Body_Decl);
7602 -- Check whether the early call region of the subprogram body is
7605 Region := Early_Call_Region (Body_Id);
7608 Region := Find_ECR (Body_Decl);
7610 -- Associate the early call region with the subprogram body in
7611 -- case other scenarios need it.
7613 Set_Early_Call_Region (Body_Id, Region);
7617 -- A subprogram body must always have an early call region
7619 pragma Assert (Present (Region));
7622 end Find_Early_Call_Region;
7624 --------------------------------------------
7625 -- Initialize_Early_Call_Region_Processor --
7626 --------------------------------------------
7628 procedure Initialize_Early_Call_Region_Processor is
7630 Early_Call_Regions_Map := ECR_Map.Create (100);
7631 end Initialize_Early_Call_Region_Processor;
7633 ---------------------------
7634 -- Set_Early_Call_Region --
7635 ---------------------------
7637 procedure Set_Early_Call_Region (Body_Id : Entity_Id; Start : Node_Id) is
7638 pragma Assert (Present (Body_Id));
7639 pragma Assert (Present (Start));
7642 ECR_Map.Put (Early_Call_Regions_Map, Body_Id, Start);
7643 end Set_Early_Call_Region;
7644 end Early_Call_Region_Processor;
7646 ----------------------
7647 -- Elaborated_Units --
7648 ----------------------
7650 package body Elaborated_Units is
7656 -- The following type idenfities the elaboration attributes of a unit
7658 type Elaboration_Attributes_Id is new Natural;
7660 No_Elaboration_Attributes : constant Elaboration_Attributes_Id :=
7661 Elaboration_Attributes_Id'First;
7662 First_Elaboration_Attributes : constant Elaboration_Attributes_Id :=
7663 No_Elaboration_Attributes + 1;
7665 -- The following type represents the elaboration attributes of a unit
7667 type Elaboration_Attributes_Record is record
7668 Elab_Pragma : Node_Id := Empty;
7669 -- This attribute denotes a source Elaborate or Elaborate_All pragma
7670 -- which guarantees the prior elaboration of some unit with respect
7671 -- to the main unit. The pragma may come from the following contexts:
7674 -- * The spec of the main unit (if applicable)
7675 -- * Any parent spec of the main unit (if applicable)
7676 -- * Any parent subunit of the main unit (if applicable)
7678 -- The attribute remains Empty if no such pragma is available. Source
7679 -- pragmas play a role in satisfying SPARK elaboration requirements.
7681 With_Clause : Node_Id := Empty;
7682 -- This attribute denotes an internally-generated or a source with
7683 -- clause for some unit withed by the main unit. With clauses carry
7684 -- flags which represent implicit Elaborate or Elaborate_All pragmas.
7685 -- These clauses play a role in supplying elaboration dependencies to
7689 ---------------------
7690 -- Data structures --
7691 ---------------------
7693 -- The following table stores all elaboration attributes
7695 package Elaboration_Attributes is new Table.Table
7696 (Table_Index_Type => Elaboration_Attributes_Id,
7697 Table_Component_Type => Elaboration_Attributes_Record,
7698 Table_Low_Bound => First_Elaboration_Attributes,
7699 Table_Initial => 250,
7700 Table_Increment => 200,
7701 Table_Name => "Elaboration_Attributes");
7703 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id);
7704 -- Destroy elaboration attributes EA_Id
7706 package UA_Map is new Dynamic_Hash_Tables
7707 (Key_Type => Entity_Id,
7708 Value_Type => Elaboration_Attributes_Id,
7709 No_Value => No_Elaboration_Attributes,
7710 Expansion_Threshold => 1.5,
7711 Expansion_Factor => 2,
7712 Compression_Threshold => 0.3,
7713 Compression_Factor => 2,
7715 Destroy_Value => Destroy,
7718 -- The following map relates an elaboration attributes of a unit to the
7721 Unit_To_Attributes_Map : UA_Map.Dynamic_Hash_Table := UA_Map.Nil;
7727 function Elaboration_Attributes_Of
7728 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id;
7729 pragma Inline (Elaboration_Attributes_Of);
7730 -- Obtain the elaboration attributes of unit Unit_Id
7732 -----------------------
7733 -- Local subprograms --
7734 -----------------------
7736 function Elab_Pragma (EA_Id : Elaboration_Attributes_Id) return Node_Id;
7737 pragma Inline (Elab_Pragma);
7738 -- Obtain the Elaborate[_All] pragma of elaboration attributes EA_Id
7740 procedure Ensure_Prior_Elaboration_Dynamic
7742 Unit_Id : Entity_Id;
7744 In_State : Processing_In_State);
7745 pragma Inline (Ensure_Prior_Elaboration_Dynamic);
7746 -- Guarantee the elaboration of unit Unit_Id with respect to the main
7747 -- unit by suggesting the use of Elaborate[_All] with name Prag_Nam. N
7748 -- denotes the related scenario. In_State is the current state of the
7749 -- Processing phase.
7751 procedure Ensure_Prior_Elaboration_Static
7753 Unit_Id : Entity_Id;
7755 In_State : Processing_In_State);
7756 pragma Inline (Ensure_Prior_Elaboration_Static);
7757 -- Guarantee the elaboration of unit Unit_Id with respect to the main
7758 -- unit by installing an implicit Elaborate[_All] pragma with name
7759 -- Prag_Nam. N denotes the related scenario. In_State is the current
7760 -- state of the Processing phase.
7762 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean;
7763 pragma Inline (Present);
7764 -- Determine whether elaboration attributes UA_Id exist
7766 procedure Set_Elab_Pragma
7767 (EA_Id : Elaboration_Attributes_Id;
7769 pragma Inline (Set_Elab_Pragma);
7770 -- Set the Elaborate[_All] pragma of elaboration attributes EA_Id to
7773 procedure Set_With_Clause
7774 (EA_Id : Elaboration_Attributes_Id;
7776 pragma Inline (Set_With_Clause);
7777 -- Set the with clause of elaboration attributes EA_Id to Clause
7779 function With_Clause (EA_Id : Elaboration_Attributes_Id) return Node_Id;
7780 pragma Inline (With_Clause);
7781 -- Obtain the implicit or source with clause of elaboration attributes
7784 ------------------------------
7785 -- Collect_Elaborated_Units --
7786 ------------------------------
7788 procedure Collect_Elaborated_Units is
7789 procedure Add_Pragma (Prag : Node_Id);
7790 pragma Inline (Add_Pragma);
7791 -- Determine whether pragma Prag denotes a legal Elaborate[_All]
7792 -- pragma. If this is the case, add the related unit to the context.
7793 -- For pragma Elaborate_All, include recursively all units withed by
7794 -- the related unit.
7797 (Unit_Id : Entity_Id;
7799 Full_Context : Boolean);
7800 pragma Inline (Add_Unit);
7801 -- Add unit Unit_Id to the elaboration context. Prag denotes the
7802 -- pragma which prompted the inclusion of the unit to the context.
7803 -- If flag Full_Context is set, examine the nonlimited clauses of
7804 -- unit Unit_Id and add each withed unit to the context.
7806 procedure Find_Elaboration_Context (Comp_Unit : Node_Id);
7807 pragma Inline (Find_Elaboration_Context);
7808 -- Examine the context items of compilation unit Comp_Unit for
7809 -- suitable elaboration-related pragmas and add all related units
7816 procedure Add_Pragma (Prag : Node_Id) is
7817 Prag_Args : constant List_Id :=
7818 Pragma_Argument_Associations (Prag);
7819 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
7823 -- Nothing to do if the pragma is not related to elaboration
7825 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then
7828 -- Nothing to do when the pragma is illegal
7830 elsif Error_Posted (Prag) then
7834 Unit_Arg := Get_Pragma_Arg (First (Prag_Args));
7836 -- The argument of the pragma may appear in package.package form
7838 if Nkind (Unit_Arg) = N_Selected_Component then
7839 Unit_Arg := Selector_Name (Unit_Arg);
7843 (Unit_Id => Entity (Unit_Arg),
7845 Full_Context => Prag_Nam = Name_Elaborate_All);
7853 (Unit_Id : Entity_Id;
7855 Full_Context : Boolean)
7858 EA_Id : Elaboration_Attributes_Id;
7859 Unit_Prag : Node_Id;
7862 -- Nothing to do when some previous error left a with clause or a
7863 -- pragma in a bad state.
7865 if No (Unit_Id) then
7869 EA_Id := Elaboration_Attributes_Of (Unit_Id);
7870 Unit_Prag := Elab_Pragma (EA_Id);
7872 -- The unit is already included in the context by means of pragma
7875 if Present (Unit_Prag) then
7877 -- Upgrade an existing pragma Elaborate when the unit is
7878 -- subject to Elaborate_All because the new pragma covers a
7879 -- larger set of units.
7881 if Pragma_Name (Unit_Prag) = Name_Elaborate
7882 and then Pragma_Name (Prag) = Name_Elaborate_All
7884 Set_Elab_Pragma (EA_Id, Prag);
7886 -- Otherwise the unit retains its existing pragma and does not
7887 -- need to be included in the context again.
7893 -- Otherwise the current unit is not included in the context
7896 Set_Elab_Pragma (EA_Id, Prag);
7899 -- Includes all units withed by the current one when computing the
7902 if Full_Context then
7904 -- Process all nonlimited with clauses found in the context of
7905 -- the current unit. Note that limited clauses do not impose an
7906 -- elaboration order.
7908 Clause := First (Context_Items (Compilation_Unit (Unit_Id)));
7909 while Present (Clause) loop
7910 if Nkind (Clause) = N_With_Clause
7911 and then not Error_Posted (Clause)
7912 and then not Limited_Present (Clause)
7915 (Unit_Id => Entity (Name (Clause)),
7917 Full_Context => Full_Context);
7925 ------------------------------
7926 -- Find_Elaboration_Context --
7927 ------------------------------
7929 procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is
7930 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
7935 -- Process all elaboration-related pragmas found in the context of
7936 -- the compilation unit.
7938 Prag := First (Context_Items (Comp_Unit));
7939 while Present (Prag) loop
7940 if Nkind (Prag) = N_Pragma then
7946 end Find_Elaboration_Context;
7953 -- Start of processing for Collect_Elaborated_Units
7956 -- Perform a traversal to examines the context of the main unit. The
7957 -- traversal performs the following jumps:
7959 -- subunit -> parent subunit
7960 -- parent subunit -> body
7962 -- spec -> parent spec
7963 -- parent spec -> grandparent spec and so on
7965 -- The traversal relies on units rather than scopes because the scope
7966 -- of a subunit is some spec, while this traversal must process the
7967 -- body as well. Given that protected and task bodies can also be
7968 -- subunits, this complicates the scope approach even further.
7970 Unit_Id := Unit (Cunit (Main_Unit));
7972 -- Perform the following traversals when the main unit is a subunit
7974 -- subunit -> parent subunit
7975 -- parent subunit -> body
7977 while Present (Unit_Id) and then Nkind (Unit_Id) = N_Subunit loop
7978 Find_Elaboration_Context (Parent (Unit_Id));
7980 -- Continue the traversal by going to the unit which contains the
7981 -- corresponding stub.
7983 if Present (Corresponding_Stub (Unit_Id)) then
7985 Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unit_Id))));
7987 -- Otherwise the subunit may be erroneous or left in a bad state
7994 -- Perform the following traversal now that subunits have been taken
7995 -- care of, or the main unit is a body.
7999 if Present (Unit_Id)
8000 and then Nkind_In (Unit_Id, N_Package_Body, N_Subprogram_Body)
8002 Find_Elaboration_Context (Parent (Unit_Id));
8004 -- Continue the traversal by going to the unit which contains the
8005 -- corresponding spec.
8007 if Present (Corresponding_Spec (Unit_Id)) then
8009 Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unit_Id))));
8013 -- Perform the following traversals now that the body has been taken
8014 -- care of, or the main unit is a spec.
8016 -- spec -> parent spec
8017 -- parent spec -> grandparent spec and so on
8019 if Present (Unit_Id)
8020 and then Nkind_In (Unit_Id, N_Generic_Package_Declaration,
8021 N_Generic_Subprogram_Declaration,
8022 N_Package_Declaration,
8023 N_Subprogram_Declaration)
8025 Find_Elaboration_Context (Parent (Unit_Id));
8027 -- Process a potential chain of parent units which ends with the
8028 -- main unit spec. The traversal can now safely rely on the scope
8031 Par_Id := Scope (Defining_Entity (Unit_Id));
8032 while Present (Par_Id) and then Par_Id /= Standard_Standard loop
8033 Find_Elaboration_Context (Compilation_Unit (Par_Id));
8035 Par_Id := Scope (Par_Id);
8038 end Collect_Elaborated_Units;
8044 procedure Destroy (EA_Id : in out Elaboration_Attributes_Id) is
8045 pragma Unreferenced (EA_Id);
8054 function Elab_Pragma
8055 (EA_Id : Elaboration_Attributes_Id) return Node_Id
8057 pragma Assert (Present (EA_Id));
8059 return Elaboration_Attributes.Table (EA_Id).Elab_Pragma;
8062 -------------------------------
8063 -- Elaboration_Attributes_Of --
8064 -------------------------------
8066 function Elaboration_Attributes_Of
8067 (Unit_Id : Entity_Id) return Elaboration_Attributes_Id
8069 EA_Id : Elaboration_Attributes_Id;
8072 EA_Id := UA_Map.Get (Unit_To_Attributes_Map, Unit_Id);
8074 -- The unit lacks elaboration attributes. This indicates that the
8075 -- unit is encountered for the first time. Create the elaboration
8076 -- attributes for it.
8078 if not Present (EA_Id) then
8079 Elaboration_Attributes.Append
8080 ((Elab_Pragma => Empty,
8081 With_Clause => Empty));
8082 EA_Id := Elaboration_Attributes.Last;
8084 -- Associate the elaboration attributes with the unit
8086 UA_Map.Put (Unit_To_Attributes_Map, Unit_Id, EA_Id);
8089 pragma Assert (Present (EA_Id));
8092 end Elaboration_Attributes_Of;
8094 ------------------------------
8095 -- Ensure_Prior_Elaboration --
8096 ------------------------------
8098 procedure Ensure_Prior_Elaboration
8100 Unit_Id : Entity_Id;
8102 In_State : Processing_In_State)
8104 pragma Assert (Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All));
8107 -- Nothing to do when the need for prior elaboration came from a
8108 -- partial finalization routine which occurs in an initialization
8109 -- context. This behaviour parallels that of the old ABE mechanism.
8111 if In_State.Within_Partial_Finalization then
8114 -- Nothing to do when the need for prior elaboration came from a task
8115 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on
8116 -- task bodies) is in effect.
8118 elsif Debug_Flag_Dot_Y and then In_State.Within_Task_Body then
8121 -- Nothing to do when the unit is elaborated prior to the main unit.
8122 -- This check must also consider the following cases:
8124 -- * No check is made against the context of the main unit because
8125 -- this is specific to the elaboration model in effect and requires
8126 -- custom handling (see Ensure_xxx_Prior_Elaboration).
8128 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
8129 -- Elaborate[_All] MUST be generated even though Unit_Id is always
8130 -- elaborated prior to the main unit. This conservative strategy
8131 -- ensures that other units withed by Unit_Id will not lead to an
8134 -- package A is package body A is
8135 -- procedure ABE; procedure ABE is ... end ABE;
8139 -- package B is package body B is
8140 -- pragma Elaborate_Body; procedure Proc is
8142 -- procedure Proc; A.ABE;
8143 -- package B; end Proc;
8147 -- package C is package body C is
8153 -- In the example above, the elaboration of C invokes B.Proc. B is
8154 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All]
8155 -- is gnerated for B in C, then the following elaboratio order will
8158 -- spec of A elaborated
8159 -- spec of B elaborated
8160 -- body of B elaborated
8161 -- spec of C elaborated
8162 -- body of C elaborated <-- calls B.Proc which calls A.ABE
8163 -- body of A elaborated <-- problem
8165 -- The generation of an implicit pragma Elaborate_All (B) ensures
8166 -- that the elaboration order mechanism will not pick the above
8169 -- An implicit Elaborate is NOT generated when the unit is subject
8170 -- to Elaborate_Body because both pragmas have the same effect.
8172 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All]
8173 -- MUST NOT be generated in this case because a unit cannot depend
8174 -- on its own elaboration. This case is therefore treated as valid
8175 -- prior elaboration.
8177 elsif Has_Prior_Elaboration
8178 (Unit_Id => Unit_Id,
8179 Same_Unit_OK => True,
8180 Elab_Body_OK => Prag_Nam = Name_Elaborate)
8185 -- Suggest the use of pragma Prag_Nam when the dynamic model is in
8188 if Dynamic_Elaboration_Checks then
8189 Ensure_Prior_Elaboration_Dynamic
8192 Prag_Nam => Prag_Nam,
8193 In_State => In_State);
8195 -- Install an implicit pragma Prag_Nam when the static model is in
8199 pragma Assert (Static_Elaboration_Checks);
8201 Ensure_Prior_Elaboration_Static
8204 Prag_Nam => Prag_Nam,
8205 In_State => In_State);
8207 end Ensure_Prior_Elaboration;
8209 --------------------------------------
8210 -- Ensure_Prior_Elaboration_Dynamic --
8211 --------------------------------------
8213 procedure Ensure_Prior_Elaboration_Dynamic
8215 Unit_Id : Entity_Id;
8217 In_State : Processing_In_State)
8219 procedure Info_Missing_Pragma;
8220 pragma Inline (Info_Missing_Pragma);
8221 -- Output information concerning missing Elaborate or Elaborate_All
8222 -- pragma with name Prag_Nam for scenario N, which would ensure the
8223 -- prior elaboration of Unit_Id.
8225 -------------------------
8226 -- Info_Missing_Pragma --
8227 -------------------------
8229 procedure Info_Missing_Pragma is
8231 -- Internal units are ignored as they cause unnecessary noise
8233 if not In_Internal_Unit (Unit_Id) then
8235 -- The name of the unit subjected to the elaboration pragma is
8236 -- fully qualified to improve the clarity of the info message.
8238 Error_Msg_Name_1 := Prag_Nam;
8239 Error_Msg_Qual_Level := Nat'Last;
8241 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id);
8242 Error_Msg_Qual_Level := 0;
8244 end Info_Missing_Pragma;
8248 EA_Id : constant Elaboration_Attributes_Id :=
8249 Elaboration_Attributes_Of (Unit_Id);
8250 N_Lvl : Enclosing_Level_Kind;
8251 N_Rep : Scenario_Rep_Id;
8253 -- Start of processing for Ensure_Prior_Elaboration_Dynamic
8256 -- Nothing to do when the unit is guaranteed prior elaboration by
8257 -- means of a source Elaborate[_All] pragma.
8259 if Present (Elab_Pragma (EA_Id)) then
8263 -- Output extra information on a missing Elaborate[_All] pragma when
8264 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
8267 if Elab_Info_Messages
8268 and then not In_State.Suppress_Info_Messages
8270 N_Rep := Scenario_Representation_Of (N, In_State);
8271 N_Lvl := Level (N_Rep);
8273 -- Declaration-level scenario
8275 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N))
8276 and then N_Lvl = Declaration_Level
8280 -- Library-level scenario
8282 elsif N_Lvl in Library_Level then
8285 -- Instantiation library-level scenario
8287 elsif N_Lvl = Instantiation_Level then
8290 -- Otherwise the scenario does not appear at the proper level
8296 Info_Missing_Pragma;
8298 end Ensure_Prior_Elaboration_Dynamic;
8300 -------------------------------------
8301 -- Ensure_Prior_Elaboration_Static --
8302 -------------------------------------
8304 procedure Ensure_Prior_Elaboration_Static
8306 Unit_Id : Entity_Id;
8308 In_State : Processing_In_State)
8310 function Find_With_Clause
8312 Withed_Id : Entity_Id) return Node_Id;
8313 pragma Inline (Find_With_Clause);
8314 -- Find a nonlimited with clause in the list of context items Items
8315 -- that withs unit Withed_Id. Return Empty if no such clause exists.
8317 procedure Info_Implicit_Pragma;
8318 pragma Inline (Info_Implicit_Pragma);
8319 -- Output information concerning an implicitly generated Elaborate
8320 -- or Elaborate_All pragma with name Prag_Nam for scenario N which
8321 -- ensures the prior elaboration of unit Unit_Id.
8323 ----------------------
8324 -- Find_With_Clause --
8325 ----------------------
8327 function Find_With_Clause
8329 Withed_Id : Entity_Id) return Node_Id
8334 -- Examine the context clauses looking for a suitable with. Note
8335 -- that limited clauses do not affect the elaboration order.
8337 Item := First (Items);
8338 while Present (Item) loop
8339 if Nkind (Item) = N_With_Clause
8340 and then not Error_Posted (Item)
8341 and then not Limited_Present (Item)
8342 and then Entity (Name (Item)) = Withed_Id
8351 end Find_With_Clause;
8353 --------------------------
8354 -- Info_Implicit_Pragma --
8355 --------------------------
8357 procedure Info_Implicit_Pragma is
8359 -- Internal units are ignored as they cause unnecessary noise
8361 if not In_Internal_Unit (Unit_Id) then
8363 -- The name of the unit subjected to the elaboration pragma is
8364 -- fully qualified to improve the clarity of the info message.
8366 Error_Msg_Name_1 := Prag_Nam;
8367 Error_Msg_Qual_Level := Nat'Last;
8370 ("info: implicit pragma % generated for unit &", N, Unit_Id);
8372 Error_Msg_Qual_Level := 0;
8373 Output_Active_Scenarios (N, In_State);
8375 end Info_Implicit_Pragma;
8379 EA_Id : constant Elaboration_Attributes_Id :=
8380 Elaboration_Attributes_Of (Unit_Id);
8382 Main_Cunit : constant Node_Id := Cunit (Main_Unit);
8383 Loc : constant Source_Ptr := Sloc (Main_Cunit);
8384 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id);
8385 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id);
8386 Unit_With : constant Node_Id := With_Clause (EA_Id);
8391 -- Start of processing for Ensure_Prior_Elaboration_Static
8394 -- Nothing to do when the caller has suppressed the generation of
8395 -- implicit Elaborate[_All] pragmas.
8397 if In_State.Suppress_Implicit_Pragmas then
8400 -- Nothing to do when the unit is guaranteed prior elaboration by
8401 -- means of a source Elaborate[_All] pragma.
8403 elsif Present (Unit_Prag) then
8406 -- Nothing to do when the unit has an existing implicit Elaborate or
8407 -- Elaborate_All pragma installed by a previous scenario.
8409 elsif Present (Unit_With) then
8411 -- The unit is already guaranteed prior elaboration by means of an
8412 -- implicit Elaborate pragma, however the current scenario imposes
8413 -- a stronger requirement of Elaborate_All. "Upgrade" the existing
8414 -- pragma to match this new requirement.
8416 if Elaborate_Desirable (Unit_With)
8417 and then Prag_Nam = Name_Elaborate_All
8419 Set_Elaborate_All_Desirable (Unit_With);
8420 Set_Elaborate_Desirable (Unit_With, False);
8426 -- At this point it is known that the unit has no prior elaboration
8427 -- according to pragmas and hierarchical relationships.
8429 Items := Context_Items (Main_Cunit);
8433 Set_Context_Items (Main_Cunit, Items);
8436 -- Locate the with clause for the unit. Note that there may not be a
8437 -- clause if the unit is visible through a subunit-body, body-spec,
8438 -- or spec-parent relationship.
8443 Withed_Id => Unit_Id);
8448 -- Note that adding implicit with clauses is safe because analysis,
8449 -- resolution, and expansion have already taken place and it is not
8450 -- possible to interfere with visibility.
8454 Make_With_Clause (Loc,
8455 Name => New_Occurrence_Of (Unit_Id, Loc));
8457 Set_Implicit_With (Clause);
8458 Set_Library_Unit (Clause, Unit_Cunit);
8460 Append_To (Items, Clause);
8463 -- Mark the with clause depending on the pragma required
8465 if Prag_Nam = Name_Elaborate then
8466 Set_Elaborate_Desirable (Clause);
8468 Set_Elaborate_All_Desirable (Clause);
8471 -- The implicit Elaborate[_All] ensures the prior elaboration of
8472 -- the unit. Include the unit in the elaboration context of the
8475 Set_With_Clause (EA_Id, Clause);
8477 -- Output extra information on an implicit Elaborate[_All] pragma
8478 -- when switch -gnatel (info messages on implicit Elaborate[_All]
8479 -- pragmas is in effect.
8481 if Elab_Info_Messages then
8482 Info_Implicit_Pragma;
8484 end Ensure_Prior_Elaboration_Static;
8486 -------------------------------
8487 -- Finalize_Elaborated_Units --
8488 -------------------------------
8490 procedure Finalize_Elaborated_Units is
8492 UA_Map.Destroy (Unit_To_Attributes_Map);
8493 end Finalize_Elaborated_Units;
8495 ---------------------------
8496 -- Has_Prior_Elaboration --
8497 ---------------------------
8499 function Has_Prior_Elaboration
8500 (Unit_Id : Entity_Id;
8501 Context_OK : Boolean := False;
8502 Elab_Body_OK : Boolean := False;
8503 Same_Unit_OK : Boolean := False) return Boolean
8505 EA_Id : constant Elaboration_Attributes_Id :=
8506 Elaboration_Attributes_Of (Unit_Id);
8508 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit);
8509 Unit_Prag : constant Node_Id := Elab_Pragma (EA_Id);
8510 Unit_With : constant Node_Id := With_Clause (EA_Id);
8513 -- A preelaborated unit is always elaborated prior to the main unit
8515 if Is_Preelaborated_Unit (Unit_Id) then
8518 -- An internal unit is always elaborated prior to a non-internal main
8521 elsif In_Internal_Unit (Unit_Id)
8522 and then not In_Internal_Unit (Main_Id)
8526 -- A unit has prior elaboration if it appears within the context
8527 -- of the main unit. Consider this case only when requested by the
8531 and then (Present (Unit_Prag) or else Present (Unit_With))
8535 -- A unit whose body is elaborated together with its spec has prior
8536 -- elaboration except with respect to itself. Consider this case only
8537 -- when requested by the caller.
8540 and then Has_Pragma_Elaborate_Body (Unit_Id)
8541 and then not Is_Same_Unit (Unit_Id, Main_Id)
8545 -- A unit has no prior elaboration with respect to itself, but does
8546 -- not require any means of ensuring its own elaboration either.
8547 -- Treat this case as valid prior elaboration only when requested by
8550 elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then
8555 end Has_Prior_Elaboration;
8557 ---------------------------------
8558 -- Initialize_Elaborated_Units --
8559 ---------------------------------
8561 procedure Initialize_Elaborated_Units is
8563 Unit_To_Attributes_Map := UA_Map.Create (250);
8564 end Initialize_Elaborated_Units;
8566 ----------------------------------
8567 -- Meet_Elaboration_Requirement --
8568 ----------------------------------
8570 procedure Meet_Elaboration_Requirement
8572 Targ_Id : Entity_Id;
8574 In_State : Processing_In_State)
8576 pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All));
8578 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit);
8579 Unit_Id : constant Entity_Id := Find_Top_Unit (Targ_Id);
8581 procedure Elaboration_Requirement_Error;
8582 pragma Inline (Elaboration_Requirement_Error);
8583 -- Emit an error concerning scenario N which has failed to meet the
8584 -- elaboration requirement.
8586 function Find_Preelaboration_Pragma
8587 (Prag_Nam : Name_Id) return Node_Id;
8588 pragma Inline (Find_Preelaboration_Pragma);
8589 -- Traverse the visible declarations of unit Unit_Id and locate a
8590 -- source preelaboration-related pragma with name Prag_Nam.
8592 procedure Info_Requirement_Met (Prag : Node_Id);
8593 pragma Inline (Info_Requirement_Met);
8594 -- Output information concerning pragma Prag which meets requirement
8597 -----------------------------------
8598 -- Elaboration_Requirement_Error --
8599 -----------------------------------
8601 procedure Elaboration_Requirement_Error is
8603 if Is_Suitable_Call (N) then
8610 elsif Is_Suitable_Instantiation (N) then
8617 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then
8619 ("read of refinement constituents during elaboration in "
8622 elsif Is_Suitable_Variable_Reference (N) then
8623 Info_Variable_Reference
8629 -- No other scenario may impose a requirement on the context of
8633 pragma Assert (False);
8637 Error_Msg_Name_1 := Req_Nam;
8638 Error_Msg_Node_2 := Unit_Id;
8639 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id);
8641 Output_Active_Scenarios (N, In_State);
8642 end Elaboration_Requirement_Error;
8644 --------------------------------
8645 -- Find_Preelaboration_Pragma --
8646 --------------------------------
8648 function Find_Preelaboration_Pragma
8649 (Prag_Nam : Name_Id) return Node_Id
8651 Spec : constant Node_Id := Parent (Unit_Id);
8655 -- A preelaboration-related pragma comes from source and appears
8656 -- at the top of the visible declarations of a package.
8658 if Nkind (Spec) = N_Package_Specification then
8659 Decl := First (Visible_Declarations (Spec));
8660 while Present (Decl) loop
8661 if Comes_From_Source (Decl) then
8662 if Nkind (Decl) = N_Pragma
8663 and then Pragma_Name (Decl) = Prag_Nam
8667 -- Otherwise the construct terminates the region where
8668 -- the preelaboration-related pragma may appear.
8680 end Find_Preelaboration_Pragma;
8682 --------------------------
8683 -- Info_Requirement_Met --
8684 --------------------------
8686 procedure Info_Requirement_Met (Prag : Node_Id) is
8687 pragma Assert (Present (Prag));
8690 Error_Msg_Name_1 := Req_Nam;
8691 Error_Msg_Sloc := Sloc (Prag);
8693 ("\\% requirement for unit & met by pragma #", N, Unit_Id);
8694 end Info_Requirement_Met;
8698 EA_Id : Elaboration_Attributes_Id;
8701 Unit_Prag : Node_Id;
8703 -- Start of processing for Meet_Elaboration_Requirement
8706 -- Assume that the requirement has not been met
8710 -- If the target is within the main unit, either at the source level
8711 -- or through an instantiation, then there is no real requirement to
8712 -- meet because the main unit cannot force its own elaboration by
8713 -- means of an Elaborate[_All] pragma. Treat this case as valid
8716 if In_Extended_Main_Code_Unit (Targ_Id) then
8719 -- Otherwise the target resides in an external unit
8721 -- The requirement is met when the target comes from an internal unit
8722 -- because such a unit is elaborated prior to a non-internal unit.
8724 elsif In_Internal_Unit (Unit_Id)
8725 and then not In_Internal_Unit (Main_Id)
8729 -- The requirement is met when the target comes from a preelaborated
8730 -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
8732 elsif Is_Preelaborated_Unit (Unit_Id) then
8735 -- Output extra information when switch -gnatel (info messages on
8736 -- implicit Elaborate[_All] pragmas.
8738 if Elab_Info_Messages
8739 and then not In_State.Suppress_Info_Messages
8741 if Is_Preelaborated (Unit_Id) then
8742 Elab_Nam := Name_Preelaborate;
8744 elsif Is_Pure (Unit_Id) then
8745 Elab_Nam := Name_Pure;
8747 elsif Is_Remote_Call_Interface (Unit_Id) then
8748 Elab_Nam := Name_Remote_Call_Interface;
8750 elsif Is_Remote_Types (Unit_Id) then
8751 Elab_Nam := Name_Remote_Types;
8754 pragma Assert (Is_Shared_Passive (Unit_Id));
8755 Elab_Nam := Name_Shared_Passive;
8758 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam));
8761 -- Determine whether the context of the main unit has a pragma strong
8762 -- enough to meet the requirement.
8765 EA_Id := Elaboration_Attributes_Of (Unit_Id);
8766 Unit_Prag := Elab_Pragma (EA_Id);
8768 -- The pragma must be either Elaborate_All or be as strong as the
8771 if Present (Unit_Prag)
8772 and then Nam_In (Pragma_Name (Unit_Prag), Name_Elaborate_All,
8777 -- Output extra information when switch -gnatel (info messages
8778 -- on implicit Elaborate[_All] pragmas.
8780 if Elab_Info_Messages
8781 and then not In_State.Suppress_Info_Messages
8783 Info_Requirement_Met (Unit_Prag);
8788 -- The requirement was not met by the context of the main unit, issue
8792 Elaboration_Requirement_Error;
8794 end Meet_Elaboration_Requirement;
8800 function Present (EA_Id : Elaboration_Attributes_Id) return Boolean is
8802 return EA_Id /= No_Elaboration_Attributes;
8805 ---------------------
8806 -- Set_Elab_Pragma --
8807 ---------------------
8809 procedure Set_Elab_Pragma
8810 (EA_Id : Elaboration_Attributes_Id;
8813 pragma Assert (Present (EA_Id));
8815 Elaboration_Attributes.Table (EA_Id).Elab_Pragma := Prag;
8816 end Set_Elab_Pragma;
8818 ---------------------
8819 -- Set_With_Clause --
8820 ---------------------
8822 procedure Set_With_Clause
8823 (EA_Id : Elaboration_Attributes_Id;
8826 pragma Assert (Present (EA_Id));
8828 Elaboration_Attributes.Table (EA_Id).With_Clause := Clause;
8829 end Set_With_Clause;
8835 function With_Clause
8836 (EA_Id : Elaboration_Attributes_Id) return Node_Id
8838 pragma Assert (Present (EA_Id));
8840 return Elaboration_Attributes.Table (EA_Id).With_Clause;
8842 end Elaborated_Units;
8844 ------------------------------
8845 -- Elaboration_Phase_Active --
8846 ------------------------------
8848 function Elaboration_Phase_Active return Boolean is
8850 return Elaboration_Phase = Active;
8851 end Elaboration_Phase_Active;
8853 ----------------------------------
8854 -- Finalize_All_Data_Structures --
8855 ----------------------------------
8857 procedure Finalize_All_Data_Structures is
8859 Finalize_Body_Processor;
8860 Finalize_Early_Call_Region_Processor;
8861 Finalize_Elaborated_Units;
8862 Finalize_Internal_Representation;
8863 Finalize_Invocation_Graph;
8864 Finalize_Scenario_Storage;
8865 end Finalize_All_Data_Structures;
8867 -----------------------------
8868 -- Find_Enclosing_Instance --
8869 -----------------------------
8871 function Find_Enclosing_Instance (N : Node_Id) return Node_Id is
8875 -- Climb the parent chain looking for an enclosing instance spec or body
8878 while Present (Par) loop
8879 if Nkind_In (Par, N_Package_Body,
8880 N_Package_Declaration,
8882 N_Subprogram_Declaration)
8883 and then Is_Generic_Instance (Unique_Defining_Entity (Par))
8888 Par := Parent (Par);
8892 end Find_Enclosing_Instance;
8894 --------------------------
8895 -- Find_Enclosing_Level --
8896 --------------------------
8898 function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is
8899 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind;
8900 pragma Inline (Level_Of);
8901 -- Obtain the corresponding level of unit Unit
8907 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is
8908 Spec_Id : Entity_Id;
8911 if Nkind (Unit) in N_Generic_Instantiation then
8912 return Instantiation_Level;
8914 elsif Nkind (Unit) = N_Generic_Package_Declaration then
8915 return Generic_Spec_Level;
8917 elsif Nkind (Unit) = N_Package_Declaration then
8918 return Library_Spec_Level;
8920 elsif Nkind (Unit) = N_Package_Body then
8921 Spec_Id := Corresponding_Spec (Unit);
8923 -- The body belongs to a generic package
8925 if Present (Spec_Id)
8926 and then Ekind (Spec_Id) = E_Generic_Package
8928 return Generic_Body_Level;
8930 -- Otherwise the body belongs to a non-generic package. This also
8931 -- treats an illegal package body without a corresponding spec as
8932 -- a non-generic package body.
8935 return Library_Body_Level;
8948 -- Start of processing for Find_Enclosing_Level
8951 -- Call markers and instantiations which appear at the declaration level
8952 -- but are later relocated in a different context retain their original
8953 -- declaration level.
8955 if Nkind_In (N, N_Call_Marker,
8956 N_Function_Instantiation,
8957 N_Package_Instantiation,
8958 N_Procedure_Instantiation)
8959 and then Is_Declaration_Level_Node (N)
8961 return Declaration_Level;
8964 -- Climb the parent chain looking at the enclosing levels
8967 Curr := Parent (Prev);
8968 while Present (Curr) loop
8970 -- A traversal from a subunit continues via the corresponding stub
8972 if Nkind (Curr) = N_Subunit then
8973 Curr := Corresponding_Stub (Curr);
8975 -- The current construct is a package. Packages are ignored because
8976 -- they are always elaborated when the enclosing context is invoked
8979 elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then
8982 -- The current construct is a block statement
8984 elsif Nkind (Curr) = N_Block_Statement then
8986 -- Ignore internally generated blocks created by the expander for
8987 -- various purposes such as abort defer/undefer.
8989 if not Comes_From_Source (Curr) then
8992 -- If the traversal came from the handled sequence of statments,
8993 -- then the node appears at the level of the enclosing construct.
8994 -- This is a more reliable test because transients scopes within
8995 -- the declarative region of the encapsulator are hard to detect.
8997 elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements
8998 and then Handled_Statement_Sequence (Curr) = Prev
9000 return Find_Enclosing_Level (Parent (Curr));
9002 -- Otherwise the traversal came from the declarations, the node is
9003 -- at the declaration level.
9006 return Declaration_Level;
9009 -- The current construct is a declaration-level encapsulator
9011 elsif Nkind_In (Curr, N_Entry_Body,
9015 -- If the traversal came from the handled sequence of statments,
9016 -- then the node cannot possibly appear at any level. This is
9017 -- a more reliable test because transients scopes within the
9018 -- declarative region of the encapsulator are hard to detect.
9020 if Nkind (Prev) = N_Handled_Sequence_Of_Statements
9021 and then Handled_Statement_Sequence (Curr) = Prev
9025 -- Otherwise the traversal came from the declarations, the node is
9026 -- at the declaration level.
9029 return Declaration_Level;
9032 -- The current construct is a non-library-level encapsulator which
9033 -- indicates that the node cannot possibly appear at any level. Note
9034 -- that the check must come after the declaration-level check because
9035 -- both predicates share certain nodes.
9037 elsif Is_Non_Library_Level_Encapsulator (Curr) then
9038 Context := Parent (Curr);
9040 -- The sole exception is when the encapsulator is the compilation
9041 -- utit itself because the compilation unit node requires special
9042 -- processing (see below).
9044 if Present (Context)
9045 and then Nkind (Context) = N_Compilation_Unit
9049 -- Otherwise the node is not at any level
9055 -- The current construct is a compilation unit. The node appears at
9056 -- the [generic] library level when the unit is a [generic] package.
9058 elsif Nkind (Curr) = N_Compilation_Unit then
9059 return Level_Of (Unit (Curr));
9063 Curr := Parent (Prev);
9067 end Find_Enclosing_Level;
9073 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is
9075 return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N))));
9078 ----------------------
9079 -- Find_Unit_Entity --
9080 ----------------------
9082 function Find_Unit_Entity (N : Node_Id) return Entity_Id is
9083 Context : constant Node_Id := Parent (N);
9084 Orig_N : constant Node_Id := Original_Node (N);
9087 -- The unit denotes a package body of an instantiation which acts as
9088 -- a compilation unit. The proper entity is that of the package spec.
9090 if Nkind (N) = N_Package_Body
9091 and then Nkind (Orig_N) = N_Package_Instantiation
9092 and then Nkind (Context) = N_Compilation_Unit
9094 return Corresponding_Spec (N);
9096 -- The unit denotes an anonymous package created to wrap a subprogram
9097 -- instantiation which acts as a compilation unit. The proper entity is
9098 -- that of the "related instance".
9100 elsif Nkind (N) = N_Package_Declaration
9101 and then Nkind_In (Orig_N, N_Function_Instantiation,
9102 N_Procedure_Instantiation)
9103 and then Nkind (Context) = N_Compilation_Unit
9106 Related_Instance (Defining_Entity (N, Concurrent_Subunit => True));
9108 -- Otherwise the proper entity is the defining entity
9111 return Defining_Entity (N, Concurrent_Subunit => True);
9113 end Find_Unit_Entity;
9115 -----------------------
9116 -- First_Formal_Type --
9117 -----------------------
9119 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is
9120 Formal_Id : constant Entity_Id := First_Formal (Subp_Id);
9124 if Present (Formal_Id) then
9125 Typ := Etype (Formal_Id);
9127 -- Handle various combinations of concurrent and private types
9130 if Ekind_In (Typ, E_Protected_Type, E_Task_Type)
9131 and then Present (Anonymous_Object (Typ))
9133 Typ := Anonymous_Object (Typ);
9135 elsif Is_Concurrent_Record_Type (Typ) then
9136 Typ := Corresponding_Concurrent_Type (Typ);
9138 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
9139 Typ := Full_View (Typ);
9150 end First_Formal_Type;
9152 ------------------------------
9153 -- Guaranteed_ABE_Processor --
9154 ------------------------------
9156 package body Guaranteed_ABE_Processor is
9157 function Is_Guaranteed_ABE
9159 Target_Decl : Node_Id;
9160 Target_Body : Node_Id) return Boolean;
9161 pragma Inline (Is_Guaranteed_ABE);
9162 -- Determine whether scenario N with a target described by its initial
9163 -- declaration Target_Decl and body Target_Decl results in a guaranteed
9166 procedure Process_Guaranteed_ABE_Activation
9168 Call_Rep : Scenario_Rep_Id;
9170 Obj_Rep : Target_Rep_Id;
9171 Task_Typ : Entity_Id;
9172 Task_Rep : Target_Rep_Id;
9173 In_State : Processing_In_State);
9174 pragma Inline (Process_Guaranteed_ABE_Activation);
9175 -- Perform common guaranteed ABE checks and diagnostics for activation
9176 -- call Call which activates object Obj_Id of task type Task_Typ. Formal
9177 -- Call_Rep denotes the representation of the call. Obj_Rep denotes the
9178 -- representation of the object. Task_Rep denotes the representation of
9179 -- the task type. In_State is the current state of the Processing phase.
9181 procedure Process_Guaranteed_ABE_Call
9183 Call_Rep : Scenario_Rep_Id;
9184 In_State : Processing_In_State);
9185 pragma Inline (Process_Guaranteed_ABE_Call);
9186 -- Perform common guaranteed ABE checks and diagnostics for call Call
9187 -- with representation Call_Rep. In_State denotes the current state of
9188 -- the Processing phase.
9190 procedure Process_Guaranteed_ABE_Instantiation
9192 Inst_Rep : Scenario_Rep_Id;
9193 In_State : Processing_In_State);
9194 pragma Inline (Process_Guaranteed_ABE_Instantiation);
9195 -- Perform common guaranteed ABE checks and diagnostics for instance
9196 -- Inst with representation Inst_Rep. In_State is the current state of
9197 -- the Processing phase.
9199 -----------------------
9200 -- Is_Guaranteed_ABE --
9201 -----------------------
9203 function Is_Guaranteed_ABE
9205 Target_Decl : Node_Id;
9206 Target_Body : Node_Id) return Boolean
9209 -- Avoid cascaded errors if there were previous serious infractions.
9210 -- As a result the scenario will not be treated as a guaranteed ABE.
9211 -- This behaviour parallels that of the old ABE mechanism.
9213 if Serious_Errors_Detected > 0 then
9216 -- The scenario and the target appear in the same context ignoring
9217 -- enclosing library levels.
9219 elsif In_Same_Context (N, Target_Decl) then
9221 -- The target body has already been encountered. The scenario
9222 -- results in a guaranteed ABE if it appears prior to the body.
9224 if Present (Target_Body) then
9225 return Earlier_In_Extended_Unit (N, Target_Body);
9227 -- Otherwise the body has not been encountered yet. The scenario
9228 -- is a guaranteed ABE since the body will appear later. It is
9229 -- assumed that the caller has already ensured that the scenario
9230 -- is ABE-safe because optional bodies are not considered here.
9238 end Is_Guaranteed_ABE;
9240 ----------------------------
9241 -- Process_Guaranteed_ABE --
9242 ----------------------------
9244 procedure Process_Guaranteed_ABE
9246 In_State : Processing_In_State)
9248 Scen : constant Node_Id := Scenario (N);
9249 Scen_Rep : Scenario_Rep_Id;
9252 -- Add the current scenario to the stack of active scenarios
9254 Push_Active_Scenario (Scen);
9256 -- Only calls, instantiations, and task activations may result in a
9259 -- Call or task activation
9261 if Is_Suitable_Call (Scen) then
9262 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
9264 if Kind (Scen_Rep) = Call_Scenario then
9265 Process_Guaranteed_ABE_Call
9267 Call_Rep => Scen_Rep,
9268 In_State => In_State);
9271 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario);
9275 Call_Rep => Scenario_Representation_Of (Scen, In_State),
9276 Processor => Process_Guaranteed_ABE_Activation'Access,
9277 In_State => In_State);
9282 elsif Is_Suitable_Instantiation (Scen) then
9283 Process_Guaranteed_ABE_Instantiation
9285 Inst_Rep => Scenario_Representation_Of (Scen, In_State),
9286 In_State => In_State);
9289 -- Remove the current scenario from the stack of active scenarios
9290 -- once all ABE diagnostics and checks have been performed.
9292 Pop_Active_Scenario (Scen);
9293 end Process_Guaranteed_ABE;
9295 ---------------------------------------
9296 -- Process_Guaranteed_ABE_Activation --
9297 ---------------------------------------
9299 procedure Process_Guaranteed_ABE_Activation
9301 Call_Rep : Scenario_Rep_Id;
9303 Obj_Rep : Target_Rep_Id;
9304 Task_Typ : Entity_Id;
9305 Task_Rep : Target_Rep_Id;
9306 In_State : Processing_In_State)
9308 Spec_Decl : constant Node_Id := Spec_Declaration (Task_Rep);
9310 Check_OK : constant Boolean :=
9311 not In_State.Suppress_Checks
9312 and then Ghost_Mode_Of (Obj_Rep) /= Is_Ignored
9313 and then Ghost_Mode_Of (Task_Rep) /= Is_Ignored
9314 and then Elaboration_Checks_OK (Obj_Rep)
9315 and then Elaboration_Checks_OK (Task_Rep);
9316 -- A run-time ABE check may be installed only when the object and the
9317 -- task type have active elaboration checks, and both are not ignored
9318 -- Ghost constructs.
9321 -- Nothing to do when the root scenario appears at the declaration
9322 -- level and the task is in the same unit, but outside this context.
9324 -- task type Task_Typ; -- task declaration
9326 -- procedure Proc is
9327 -- function A ... is
9329 -- if Some_Condition then
9333 -- <activation call> -- activation site
9338 -- X : ... := A; -- root scenario
9341 -- task body Task_Typ is
9345 -- In the example above, the context of X is the declarative list
9346 -- of Proc. The "elaboration" of X may reach the activation of T
9347 -- whose body is defined outside of X's context. The task body is
9348 -- relevant only when Proc is invoked, but this happens only in
9349 -- "normal" elaboration, therefore the task body must not be
9350 -- considered if this is not the case.
9352 if Is_Up_Level_Target
9353 (Targ_Decl => Spec_Decl,
9354 In_State => In_State)
9358 -- Nothing to do when the activation is ABE-safe
9362 -- task type Task_Typ;
9365 -- package body Gen is
9366 -- task body Task_Typ is
9373 -- procedure Main is
9374 -- package Nested is
9375 -- package Inst is new Gen;
9376 -- T : Inst.Task_Typ;
9377 -- end Nested; -- safe activation
9380 elsif Is_Safe_Activation (Call, Task_Rep) then
9383 -- An activation call leads to a guaranteed ABE when the activation
9384 -- call and the task appear within the same context ignoring library
9385 -- levels, and the body of the task has not been seen yet or appears
9386 -- after the activation call.
9388 -- procedure Guaranteed_ABE is
9389 -- task type Task_Typ;
9391 -- package Nested is
9393 -- <activation call> -- guaranteed ABE
9396 -- task body Task_Typ is
9401 elsif Is_Guaranteed_ABE
9403 Target_Decl => Spec_Decl,
9404 Target_Body => Body_Declaration (Task_Rep))
9406 if Elaboration_Warnings_OK (Call_Rep) then
9407 Error_Msg_Sloc := Sloc (Call);
9409 ("??task & will be activated # before elaboration of its "
9412 ("\Program_Error will be raised at run time", Obj_Id);
9415 -- Mark the activation call as a guaranteed ABE
9417 Set_Is_Known_Guaranteed_ABE (Call);
9419 -- Install a run-time ABE failue because this activation call will
9420 -- always result in an ABE.
9423 Install_Scenario_ABE_Failure
9425 Targ_Id => Task_Typ,
9426 Targ_Rep => Task_Rep,
9427 Disable => Obj_Rep);
9430 end Process_Guaranteed_ABE_Activation;
9432 ---------------------------------
9433 -- Process_Guaranteed_ABE_Call --
9434 ---------------------------------
9436 procedure Process_Guaranteed_ABE_Call
9438 Call_Rep : Scenario_Rep_Id;
9439 In_State : Processing_In_State)
9441 Subp_Id : constant Entity_Id := Target (Call_Rep);
9442 Subp_Rep : constant Target_Rep_Id :=
9443 Target_Representation_Of (Subp_Id, In_State);
9444 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep);
9446 Check_OK : constant Boolean :=
9447 not In_State.Suppress_Checks
9448 and then Ghost_Mode_Of (Call_Rep) /= Is_Ignored
9449 and then Ghost_Mode_Of (Subp_Rep) /= Is_Ignored
9450 and then Elaboration_Checks_OK (Call_Rep)
9451 and then Elaboration_Checks_OK (Subp_Rep);
9452 -- A run-time ABE check may be installed only when both the call
9453 -- and the target have active elaboration checks, and both are not
9454 -- ignored Ghost constructs.
9457 -- Nothing to do when the root scenario appears at the declaration
9458 -- level and the target is in the same unit but outside this context.
9460 -- function B ...; -- target declaration
9462 -- procedure Proc is
9463 -- function A ... is
9465 -- if Some_Condition then
9466 -- return B; -- call site
9470 -- X : ... := A; -- root scenario
9473 -- function B ... is
9477 -- In the example above, the context of X is the declarative region
9478 -- of Proc. The "elaboration" of X may eventually reach B which is
9479 -- defined outside of X's context. B is relevant only when Proc is
9480 -- invoked, but this happens only by means of "normal" elaboration,
9481 -- therefore B must not be considered if this is not the case.
9483 if Is_Up_Level_Target
9484 (Targ_Decl => Spec_Decl,
9485 In_State => In_State)
9489 -- Nothing to do when the call is ABE-safe
9492 -- function Gen ...;
9494 -- function Gen ... is
9500 -- procedure Main is
9501 -- function Inst is new Gen;
9502 -- X : ... := Inst; -- safe call
9505 elsif Is_Safe_Call (Call, Subp_Id, Subp_Rep) then
9508 -- A call leads to a guaranteed ABE when the call and the target
9509 -- appear within the same context ignoring library levels, and the
9510 -- body of the target has not been seen yet or appears after the
9513 -- procedure Guaranteed_ABE is
9514 -- function Func ...;
9516 -- package Nested is
9517 -- Obj : ... := Func; -- guaranteed ABE
9520 -- function Func ... is
9525 elsif Is_Guaranteed_ABE
9527 Target_Decl => Spec_Decl,
9528 Target_Body => Body_Declaration (Subp_Rep))
9530 if Elaboration_Warnings_OK (Call_Rep) then
9532 ("??cannot call & before body seen", Call, Subp_Id);
9533 Error_Msg_N ("\Program_Error will be raised at run time", Call);
9536 -- Mark the call as a guarnateed ABE
9538 Set_Is_Known_Guaranteed_ABE (Call);
9540 -- Install a run-time ABE failure because the call will always
9541 -- result in an ABE.
9544 Install_Scenario_ABE_Failure
9547 Targ_Rep => Subp_Rep,
9548 Disable => Call_Rep);
9551 end Process_Guaranteed_ABE_Call;
9553 ------------------------------------------
9554 -- Process_Guaranteed_ABE_Instantiation --
9555 ------------------------------------------
9557 procedure Process_Guaranteed_ABE_Instantiation
9559 Inst_Rep : Scenario_Rep_Id;
9560 In_State : Processing_In_State)
9562 Gen_Id : constant Entity_Id := Target (Inst_Rep);
9563 Gen_Rep : constant Target_Rep_Id :=
9564 Target_Representation_Of (Gen_Id, In_State);
9565 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep);
9567 Check_OK : constant Boolean :=
9568 not In_State.Suppress_Checks
9569 and then Ghost_Mode_Of (Inst_Rep) /= Is_Ignored
9570 and then Ghost_Mode_Of (Gen_Rep) /= Is_Ignored
9571 and then Elaboration_Checks_OK (Inst_Rep)
9572 and then Elaboration_Checks_OK (Gen_Rep);
9573 -- A run-time ABE check may be installed only when both the instance
9574 -- and the generic have active elaboration checks and both are not
9575 -- ignored Ghost constructs.
9578 -- Nothing to do when the root scenario appears at the declaration
9579 -- level and the generic is in the same unit, but outside this
9583 -- procedure Gen is ...; -- generic declaration
9585 -- procedure Proc is
9586 -- function A ... is
9588 -- if Some_Condition then
9590 -- procedure I is new Gen; -- instantiation site
9595 -- X : ... := A; -- root scenario
9602 -- In the example above, the context of X is the declarative region
9603 -- of Proc. The "elaboration" of X may eventually reach Gen which
9604 -- appears outside of X's context. Gen is relevant only when Proc is
9605 -- invoked, but this happens only by means of "normal" elaboration,
9606 -- therefore Gen must not be considered if this is not the case.
9608 if Is_Up_Level_Target
9609 (Targ_Decl => Spec_Decl,
9610 In_State => In_State)
9614 -- Nothing to do when the instantiation is ABE-safe
9621 -- package body Gen is
9626 -- procedure Main is
9627 -- package Inst is new Gen (ABE); -- safe instantiation
9630 elsif Is_Safe_Instantiation (Inst, Gen_Id, Gen_Rep) then
9633 -- An instantiation leads to a guaranteed ABE when the instantiation
9634 -- and the generic appear within the same context ignoring library
9635 -- levels, and the body of the generic has not been seen yet or
9636 -- appears after the instantiation.
9638 -- procedure Guaranteed_ABE is
9642 -- package Nested is
9643 -- procedure Inst is new Gen; -- guaranteed ABE
9651 elsif Is_Guaranteed_ABE
9653 Target_Decl => Spec_Decl,
9654 Target_Body => Body_Declaration (Gen_Rep))
9656 if Elaboration_Warnings_OK (Inst_Rep) then
9658 ("??cannot instantiate & before body seen", Inst, Gen_Id);
9659 Error_Msg_N ("\Program_Error will be raised at run time", Inst);
9662 -- Mark the instantiation as a guarantee ABE. This automatically
9663 -- suppresses the instantiation of the generic body.
9665 Set_Is_Known_Guaranteed_ABE (Inst);
9667 -- Install a run-time ABE failure because the instantiation will
9668 -- always result in an ABE.
9671 Install_Scenario_ABE_Failure
9674 Targ_Rep => Gen_Rep,
9675 Disable => Inst_Rep);
9678 end Process_Guaranteed_ABE_Instantiation;
9679 end Guaranteed_ABE_Processor;
9685 function Has_Body (Pack_Decl : Node_Id) return Boolean is
9686 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id;
9687 pragma Inline (Find_Corresponding_Body);
9688 -- Try to locate the corresponding body of spec Spec_Id. If no body is
9689 -- found, return Empty.
9692 (Spec_Id : Entity_Id;
9693 From : Node_Id) return Node_Id;
9694 pragma Inline (Find_Body);
9695 -- Try to locate the corresponding body of spec Spec_Id in the node list
9696 -- which follows arbitrary node From. If no body is found, return Empty.
9698 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id;
9699 pragma Inline (Load_Package_Body);
9700 -- Attempt to load the body of unit Unit_Nam. If the load failed, return
9701 -- Empty. If the compilation will not generate code, return Empty.
9703 -----------------------------
9704 -- Find_Corresponding_Body --
9705 -----------------------------
9707 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is
9708 Context : constant Entity_Id := Scope (Spec_Id);
9709 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
9710 Body_Decl : Node_Id;
9711 Body_Id : Entity_Id;
9714 if Is_Compilation_Unit (Spec_Id) then
9715 Body_Id := Corresponding_Body (Spec_Decl);
9717 if Present (Body_Id) then
9718 return Unit_Declaration_Node (Body_Id);
9720 -- The package is at the library and requires a body. Load the
9721 -- corresponding body because the optional body may be declared
9724 elsif Unit_Requires_Body (Spec_Id) then
9727 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl))));
9729 -- Otherwise there is no optional body
9735 -- The immediate context is a package. The optional body may be
9736 -- within the body of that package.
9738 -- procedure Proc is
9739 -- package Nested_1 is
9740 -- package Nested_2 is
9747 -- package body Nested_1 is
9748 -- package body Nested_2 is separate;
9751 -- separate (Proc.Nested_1.Nested_2)
9752 -- package body Nested_2 is
9753 -- package body Pack is -- optional body
9758 elsif Is_Package_Or_Generic_Package (Context) then
9759 Body_Decl := Find_Corresponding_Body (Context);
9761 -- The optional body is within the body of the enclosing package
9763 if Present (Body_Decl) then
9766 (Spec_Id => Spec_Id,
9767 From => First (Declarations (Body_Decl)));
9769 -- Otherwise the enclosing package does not have a body. This may
9770 -- be the result of an error or a genuine lack of a body.
9776 -- Otherwise the immediate context is a body. The optional body may
9777 -- be within the same list as the spec.
9779 -- procedure Proc is
9784 -- package body Pack is -- optional body
9791 (Spec_Id => Spec_Id,
9792 From => Next (Spec_Decl));
9794 end Find_Corresponding_Body;
9801 (Spec_Id : Entity_Id;
9802 From : Node_Id) return Node_Id
9804 Spec_Nam : constant Name_Id := Chars (Spec_Id);
9810 while Present (Item) loop
9812 -- The current item denotes the optional body
9814 if Nkind (Item) = N_Package_Body
9815 and then Chars (Defining_Entity (Item)) = Spec_Nam
9819 -- The current item denotes a stub, the optional body may be in
9822 elsif Nkind (Item) = N_Package_Body_Stub
9823 and then Chars (Defining_Entity (Item)) = Spec_Nam
9825 Lib_Unit := Library_Unit (Item);
9827 -- The corresponding subunit was previously loaded
9829 if Present (Lib_Unit) then
9832 -- Otherwise attempt to load the corresponding subunit
9835 return Load_Package_Body (Get_Unit_Name (Item));
9845 -----------------------
9846 -- Load_Package_Body --
9847 -----------------------
9849 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is
9850 Body_Decl : Node_Id;
9851 Unit_Num : Unit_Number_Type;
9854 -- The load is performed only when the compilation will generate code
9856 if Operating_Mode = Generate_Code then
9859 (Load_Name => Unit_Nam,
9862 Error_Node => Pack_Decl);
9864 -- The load failed most likely because the physical file is
9867 if Unit_Num = No_Unit then
9870 -- Otherwise the load was successful, return the body of the unit
9873 Body_Decl := Unit (Cunit (Unit_Num));
9875 -- If the unit is a subunit with an available proper body,
9876 -- return the proper body.
9878 if Nkind (Body_Decl) = N_Subunit
9879 and then Present (Proper_Body (Body_Decl))
9881 Body_Decl := Proper_Body (Body_Decl);
9889 end Load_Package_Body;
9893 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
9895 -- Start of processing for Has_Body
9898 -- The body is available
9900 if Present (Corresponding_Body (Pack_Decl)) then
9903 -- The body is required if the package spec contains a construct which
9904 -- requires a completion in a body.
9906 elsif Unit_Requires_Body (Pack_Id) then
9909 -- The body may be optional
9912 return Present (Find_Corresponding_Body (Pack_Id));
9920 function Hash (NE : Node_Or_Entity_Id) return Bucket_Range_Type is
9921 pragma Assert (Present (NE));
9923 return Bucket_Range_Type (NE);
9926 --------------------------
9927 -- In_External_Instance --
9928 --------------------------
9930 function In_External_Instance
9932 Target_Decl : Node_Id) return Boolean
9935 Inst_Body : Node_Id;
9936 Inst_Spec : Node_Id;
9939 Inst := Find_Enclosing_Instance (Target_Decl);
9941 -- The target declaration appears within an instance spec. Visibility is
9942 -- ignored because internally generated primitives for private types may
9943 -- reside in the private declarations and still be invoked from outside.
9945 if Present (Inst) and then Nkind (Inst) = N_Package_Declaration then
9947 -- The scenario comes from the main unit and the instance does not
9949 if In_Extended_Main_Code_Unit (N)
9950 and then not In_Extended_Main_Code_Unit (Inst)
9954 -- Otherwise the scenario must not appear within the instance spec or
9958 Spec_And_Body_From_Node
9960 Spec_Decl => Inst_Spec,
9961 Body_Decl => Inst_Body);
9963 return not In_Subtree
9966 Root2 => Inst_Body);
9971 end In_External_Instance;
9973 ---------------------
9974 -- In_Main_Context --
9975 ---------------------
9977 function In_Main_Context (N : Node_Id) return Boolean is
9979 -- Scenarios outside the main unit are not considered because the ALI
9980 -- information supplied to binde is for the main unit only.
9982 if not In_Extended_Main_Code_Unit (N) then
9985 -- Scenarios within internal units are not considered unless switch
9986 -- -gnatdE (elaboration checks on predefined units) is in effect.
9988 elsif not Debug_Flag_EE and then In_Internal_Unit (N) then
9993 end In_Main_Context;
9995 ---------------------
9996 -- In_Same_Context --
9997 ---------------------
9999 function In_Same_Context
10002 Nested_OK : Boolean := False) return Boolean
10004 function Find_Enclosing_Context (N : Node_Id) return Node_Id;
10005 pragma Inline (Find_Enclosing_Context);
10006 -- Return the nearest enclosing non-library-level or compilation unit
10007 -- node which which encapsulates arbitrary node N. Return Empty is no
10008 -- such context is available.
10010 function In_Nested_Context
10012 Inner : Node_Id) return Boolean;
10013 pragma Inline (In_Nested_Context);
10014 -- Determine whether arbitrary node Outer encapsulates arbitrary node
10017 ----------------------------
10018 -- Find_Enclosing_Context --
10019 ----------------------------
10021 function Find_Enclosing_Context (N : Node_Id) return Node_Id is
10027 while Present (Par) loop
10029 -- A traversal from a subunit continues via the corresponding stub
10031 if Nkind (Par) = N_Subunit then
10032 Par := Corresponding_Stub (Par);
10034 -- Stop the traversal when the nearest enclosing non-library-level
10035 -- encapsulator has been reached.
10037 elsif Is_Non_Library_Level_Encapsulator (Par) then
10038 Context := Parent (Par);
10040 -- The sole exception is when the encapsulator is the unit of
10041 -- compilation because this case requires special processing
10044 if Present (Context)
10045 and then Nkind (Context) = N_Compilation_Unit
10053 -- Reaching a compilation unit node without hitting a non-library-
10054 -- level encapsulator indicates that N is at the library level in
10055 -- which case the compilation unit is the context.
10057 elsif Nkind (Par) = N_Compilation_Unit then
10061 Par := Parent (Par);
10065 end Find_Enclosing_Context;
10067 -----------------------
10068 -- In_Nested_Context --
10069 -----------------------
10071 function In_Nested_Context
10073 Inner : Node_Id) return Boolean
10079 while Present (Par) loop
10081 -- A traversal from a subunit continues via the corresponding stub
10083 if Nkind (Par) = N_Subunit then
10084 Par := Corresponding_Stub (Par);
10086 elsif Par = Outer then
10090 Par := Parent (Par);
10094 end In_Nested_Context;
10098 Context_1 : constant Node_Id := Find_Enclosing_Context (N1);
10099 Context_2 : constant Node_Id := Find_Enclosing_Context (N2);
10101 -- Start of processing for In_Same_Context
10104 -- Both nodes appear within the same context
10106 if Context_1 = Context_2 then
10109 -- Both nodes appear in compilation units. Determine whether one unit
10110 -- is the body of the other.
10112 elsif Nkind (Context_1) = N_Compilation_Unit
10113 and then Nkind (Context_2) = N_Compilation_Unit
10117 (Unit_1 => Defining_Entity (Unit (Context_1)),
10118 Unit_2 => Defining_Entity (Unit (Context_2)));
10120 -- The context of N1 encloses the context of N2
10122 elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then
10127 end In_Same_Context;
10133 procedure Initialize is
10135 -- Set the soft link which enables Atree.Rewrite to update a scenario
10136 -- each time it is transformed into another node.
10138 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access);
10140 -- Create all internal data structures and activate the elaboration
10141 -- phase of the compiler.
10143 Initialize_All_Data_Structures;
10144 Set_Elaboration_Phase (Active);
10147 ------------------------------------
10148 -- Initialize_All_Data_Structures --
10149 ------------------------------------
10151 procedure Initialize_All_Data_Structures is
10153 Initialize_Body_Processor;
10154 Initialize_Early_Call_Region_Processor;
10155 Initialize_Elaborated_Units;
10156 Initialize_Internal_Representation;
10157 Initialize_Invocation_Graph;
10158 Initialize_Scenario_Storage;
10159 end Initialize_All_Data_Structures;
10161 --------------------------
10162 -- Instantiated_Generic --
10163 --------------------------
10165 function Instantiated_Generic (Inst : Node_Id) return Entity_Id is
10167 -- Traverse a possible chain of renamings to obtain the original generic
10168 -- being instantiatied.
10170 return Get_Renamed_Entity (Entity (Name (Inst)));
10171 end Instantiated_Generic;
10173 -----------------------------
10174 -- Internal_Representation --
10175 -----------------------------
10177 package body Internal_Representation is
10183 -- The following type represents the contents of a scenario
10185 type Scenario_Rep_Record is record
10186 Elab_Checks_OK : Boolean := False;
10187 -- The status of elaboration checks for the scenario
10189 Elab_Warnings_OK : Boolean := False;
10190 -- The status of elaboration warnings for the scenario
10192 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified;
10193 -- The Ghost mode of the scenario
10195 Kind : Scenario_Kind := No_Scenario;
10196 -- The nature of the scenario
10198 Level : Enclosing_Level_Kind := No_Level;
10199 -- The enclosing level where the scenario resides
10201 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified;
10202 -- The SPARK mode of the scenario
10204 Target : Entity_Id := Empty;
10205 -- The target of the scenario
10207 -- The following attributes are multiplexed and depend on the Kind of
10208 -- the scenario. They are mapped as follows:
10211 -- Is_Dispatching_Call (Flag_1)
10213 -- Task_Activation_Scenario
10214 -- Activated_Task_Objects (List_1)
10215 -- Activated_Task_Type (Field_1)
10217 -- Variable_Reference
10218 -- Is_Read_Reference (Flag_1)
10220 Flag_1 : Boolean := False;
10221 Field_1 : Node_Or_Entity_Id := Empty;
10222 List_1 : NE_List.Doubly_Linked_List := NE_List.Nil;
10225 -- The following type represents the contents of a target
10227 type Target_Rep_Record is record
10228 Body_Decl : Node_Id := Empty;
10229 -- The declaration of the target body
10231 Elab_Checks_OK : Boolean := False;
10232 -- The status of elaboration checks for the target
10234 Elab_Warnings_OK : Boolean := False;
10235 -- The status of elaboration warnings for the target
10237 GM : Extended_Ghost_Mode := Is_Checked_Or_Not_Specified;
10238 -- The Ghost mode of the target
10240 Kind : Target_Kind := No_Target;
10241 -- The nature of the target
10243 SM : Extended_SPARK_Mode := Is_Off_Or_Not_Specified;
10244 -- The SPARK mode of the target
10246 Spec_Decl : Node_Id := Empty;
10247 -- The declaration of the target spec
10249 Unit : Entity_Id := Empty;
10250 -- The top unit where the target is declared
10252 Version : Representation_Kind := No_Representation;
10253 -- The version of the target representation
10255 -- The following attributes are multiplexed and depend on the Kind of
10256 -- the target. They are mapped as follows:
10258 -- Subprogram_Target
10259 -- Barrier_Body_Declaration (Field_1)
10262 -- Variable_Declaration (Field_1)
10264 Field_1 : Node_Or_Entity_Id := Empty;
10267 ---------------------
10268 -- Data structures --
10269 ---------------------
10271 procedure Destroy (T_Id : in out Target_Rep_Id);
10272 -- Destroy a target representation T_Id
10274 package ETT_Map is new Dynamic_Hash_Tables
10275 (Key_Type => Entity_Id,
10276 Value_Type => Target_Rep_Id,
10277 No_Value => No_Target_Rep,
10278 Expansion_Threshold => 1.5,
10279 Expansion_Factor => 2,
10280 Compression_Threshold => 0.3,
10281 Compression_Factor => 2,
10283 Destroy_Value => Destroy,
10286 -- The following map relates target representations to entities
10288 Entity_To_Target_Map : ETT_Map.Dynamic_Hash_Table := ETT_Map.Nil;
10290 procedure Destroy (S_Id : in out Scenario_Rep_Id);
10291 -- Destroy a scenario representation S_Id
10293 package NTS_Map is new Dynamic_Hash_Tables
10294 (Key_Type => Node_Id,
10295 Value_Type => Scenario_Rep_Id,
10296 No_Value => No_Scenario_Rep,
10297 Expansion_Threshold => 1.5,
10298 Expansion_Factor => 2,
10299 Compression_Threshold => 0.3,
10300 Compression_Factor => 2,
10302 Destroy_Value => Destroy,
10305 -- The following map relates scenario representations to nodes
10307 Node_To_Scenario_Map : NTS_Map.Dynamic_Hash_Table := NTS_Map.Nil;
10309 -- The following table stores all scenario representations
10311 package Scenario_Reps is new Table.Table
10312 (Table_Index_Type => Scenario_Rep_Id,
10313 Table_Component_Type => Scenario_Rep_Record,
10314 Table_Low_Bound => First_Scenario_Rep,
10315 Table_Initial => 1000,
10316 Table_Increment => 200,
10317 Table_Name => "Scenario_Reps");
10319 -- The following table stores all target representations
10321 package Target_Reps is new Table.Table
10322 (Table_Index_Type => Target_Rep_Id,
10323 Table_Component_Type => Target_Rep_Record,
10324 Table_Low_Bound => First_Target_Rep,
10325 Table_Initial => 1000,
10326 Table_Increment => 200,
10327 Table_Name => "Target_Reps");
10333 function Create_Access_Taken_Rep
10334 (Attr : Node_Id) return Scenario_Rep_Record;
10335 pragma Inline (Create_Access_Taken_Rep);
10336 -- Create the representation of 'Access attribute Attr
10338 function Create_Call_Or_Task_Activation_Rep
10339 (Call : Node_Id) return Scenario_Rep_Record;
10340 pragma Inline (Create_Call_Or_Task_Activation_Rep);
10341 -- Create the representation of call or task activation Call
10343 function Create_Derived_Type_Rep
10344 (Typ_Decl : Node_Id) return Scenario_Rep_Record;
10345 pragma Inline (Create_Derived_Type_Rep);
10346 -- Create the representation of a derived type described by declaration
10349 function Create_Generic_Rep
10350 (Gen_Id : Entity_Id) return Target_Rep_Record;
10351 pragma Inline (Create_Generic_Rep);
10352 -- Create the representation of generic Gen_Id
10354 function Create_Instantiation_Rep
10355 (Inst : Node_Id) return Scenario_Rep_Record;
10356 pragma Inline (Create_Instantiation_Rep);
10357 -- Create the representation of instantiation Inst
10359 function Create_Protected_Entry_Rep
10360 (PE_Id : Entity_Id) return Target_Rep_Record;
10361 pragma Inline (Create_Protected_Entry_Rep);
10362 -- Create the representation of protected entry PE_Id
10364 function Create_Protected_Subprogram_Rep
10365 (PS_Id : Entity_Id) return Target_Rep_Record;
10366 pragma Inline (Create_Protected_Subprogram_Rep);
10367 -- Create the representation of protected subprogram PS_Id
10369 function Create_Refined_State_Pragma_Rep
10370 (Prag : Node_Id) return Scenario_Rep_Record;
10371 pragma Inline (Create_Refined_State_Pragma_Rep);
10372 -- Create the representation of Refined_State pragma Prag
10374 function Create_Scenario_Rep
10376 In_State : Processing_In_State) return Scenario_Rep_Record;
10377 pragma Inline (Create_Scenario_Rep);
10378 -- Top level dispatcher. Create the representation of elaboration
10379 -- scenario N. In_State is the current state of the Processing phase.
10381 function Create_Subprogram_Rep
10382 (Subp_Id : Entity_Id) return Target_Rep_Record;
10383 pragma Inline (Create_Subprogram_Rep);
10384 -- Create the representation of entry, operator, or subprogram Subp_Id
10386 function Create_Target_Rep
10388 In_State : Processing_In_State) return Target_Rep_Record;
10389 pragma Inline (Create_Target_Rep);
10390 -- Top level dispatcher. Create the representation of elaboration target
10391 -- Id. In_State is the current state of the Processing phase.
10393 function Create_Task_Entry_Rep
10394 (TE_Id : Entity_Id) return Target_Rep_Record;
10395 pragma Inline (Create_Task_Entry_Rep);
10396 -- Create the representation of task entry TE_Id
10398 function Create_Task_Rep (Task_Typ : Entity_Id) return Target_Rep_Record;
10399 pragma Inline (Create_Task_Rep);
10400 -- Create the representation of task type Typ
10402 function Create_Variable_Assignment_Rep
10403 (Asmt : Node_Id) return Scenario_Rep_Record;
10404 pragma Inline (Create_Variable_Assignment_Rep);
10405 -- Create the representation of variable assignment Asmt
10407 function Create_Variable_Reference_Rep
10408 (Ref : Node_Id) return Scenario_Rep_Record;
10409 pragma Inline (Create_Variable_Reference_Rep);
10410 -- Create the representation of variable reference Ref
10412 function Create_Variable_Rep
10413 (Var_Id : Entity_Id) return Target_Rep_Record;
10414 pragma Inline (Create_Variable_Rep);
10415 -- Create the representation of variable Var_Id
10417 -----------------------
10418 -- Local subprograms --
10419 -----------------------
10421 function Ghost_Mode_Of_Entity
10422 (Id : Entity_Id) return Extended_Ghost_Mode;
10423 pragma Inline (Ghost_Mode_Of_Entity);
10424 -- Obtain the extended Ghost mode of arbitrary entity Id
10426 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode;
10427 pragma Inline (Ghost_Mode_Of_Node);
10428 -- Obtain the extended Ghost mode of arbitrary node N
10430 function Present (S_Id : Scenario_Rep_Id) return Boolean;
10431 pragma Inline (Present);
10432 -- Determine whether scenario representation S_Id exists
10434 function Present (T_Id : Target_Rep_Id) return Boolean;
10435 pragma Inline (Present);
10436 -- Determine whether target representation T_Id exists
10438 function SPARK_Mode_Of_Entity
10439 (Id : Entity_Id) return Extended_SPARK_Mode;
10440 pragma Inline (SPARK_Mode_Of_Entity);
10441 -- Obtain the extended SPARK mode of arbitrary entity Id
10443 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode;
10444 pragma Inline (SPARK_Mode_Of_Node);
10445 -- Obtain the extended SPARK mode of arbitrary node N
10447 function To_Ghost_Mode
10448 (Ignored_Status : Boolean) return Extended_Ghost_Mode;
10449 pragma Inline (To_Ghost_Mode);
10450 -- Convert a Ghost mode indicated by Ignored_Status into its extended
10453 function To_SPARK_Mode (On_Status : Boolean) return Extended_SPARK_Mode;
10454 pragma Inline (To_SPARK_Mode);
10455 -- Convert a SPARK mode indicated by On_Status into its extended
10458 function Version (T_Id : Target_Rep_Id) return Representation_Kind;
10459 pragma Inline (Version);
10460 -- Obtain the version of target representation T_Id
10462 ----------------------------
10463 -- Activated_Task_Objects --
10464 ----------------------------
10466 function Activated_Task_Objects
10467 (S_Id : Scenario_Rep_Id) return NE_List.Doubly_Linked_List
10469 pragma Assert (Present (S_Id));
10470 pragma Assert (Kind (S_Id) = Task_Activation_Scenario);
10473 return Scenario_Reps.Table (S_Id).List_1;
10474 end Activated_Task_Objects;
10476 -------------------------
10477 -- Activated_Task_Type --
10478 -------------------------
10480 function Activated_Task_Type
10481 (S_Id : Scenario_Rep_Id) return Entity_Id
10483 pragma Assert (Present (S_Id));
10484 pragma Assert (Kind (S_Id) = Task_Activation_Scenario);
10487 return Scenario_Reps.Table (S_Id).Field_1;
10488 end Activated_Task_Type;
10490 ------------------------------
10491 -- Barrier_Body_Declaration --
10492 ------------------------------
10494 function Barrier_Body_Declaration
10495 (T_Id : Target_Rep_Id) return Node_Id
10497 pragma Assert (Present (T_Id));
10498 pragma Assert (Kind (T_Id) = Subprogram_Target);
10501 return Target_Reps.Table (T_Id).Field_1;
10502 end Barrier_Body_Declaration;
10504 ----------------------
10505 -- Body_Declaration --
10506 ----------------------
10508 function Body_Declaration (T_Id : Target_Rep_Id) return Node_Id is
10509 pragma Assert (Present (T_Id));
10511 return Target_Reps.Table (T_Id).Body_Decl;
10512 end Body_Declaration;
10514 -----------------------------
10515 -- Create_Access_Taken_Rep --
10516 -----------------------------
10518 function Create_Access_Taken_Rep
10519 (Attr : Node_Id) return Scenario_Rep_Record
10521 Rec : Scenario_Rep_Record;
10524 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Attr);
10525 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Attr);
10526 Rec.GM := Is_Checked_Or_Not_Specified;
10527 Rec.SM := SPARK_Mode_Of_Node (Attr);
10528 Rec.Kind := Access_Taken_Scenario;
10529 Rec.Target := Canonical_Subprogram (Entity (Prefix (Attr)));
10532 end Create_Access_Taken_Rep;
10534 ----------------------------------------
10535 -- Create_Call_Or_Task_Activation_Rep --
10536 ----------------------------------------
10538 function Create_Call_Or_Task_Activation_Rep
10539 (Call : Node_Id) return Scenario_Rep_Record
10541 Subp_Id : constant Entity_Id := Canonical_Subprogram (Target (Call));
10542 Kind : Scenario_Kind;
10543 Rec : Scenario_Rep_Record;
10546 if Is_Activation_Proc (Subp_Id) then
10547 Kind := Task_Activation_Scenario;
10549 Kind := Call_Scenario;
10552 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call);
10553 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Call);
10554 Rec.GM := Ghost_Mode_Of_Node (Call);
10555 Rec.SM := SPARK_Mode_Of_Node (Call);
10557 Rec.Target := Subp_Id;
10559 -- Scenario-specific attributes
10561 Rec.Flag_1 := Is_Dispatching_Call (Call); -- Dispatching_Call
10564 end Create_Call_Or_Task_Activation_Rep;
10566 -----------------------------
10567 -- Create_Derived_Type_Rep --
10568 -----------------------------
10570 function Create_Derived_Type_Rep
10571 (Typ_Decl : Node_Id) return Scenario_Rep_Record
10573 Typ : constant Entity_Id := Defining_Entity (Typ_Decl);
10574 Rec : Scenario_Rep_Record;
10577 Rec.Elab_Checks_OK := False; -- not relevant
10578 Rec.Elab_Warnings_OK := False; -- not relevant
10579 Rec.GM := Ghost_Mode_Of_Entity (Typ);
10580 Rec.SM := SPARK_Mode_Of_Entity (Typ);
10581 Rec.Kind := Derived_Type_Scenario;
10585 end Create_Derived_Type_Rep;
10587 ------------------------
10588 -- Create_Generic_Rep --
10589 ------------------------
10591 function Create_Generic_Rep
10592 (Gen_Id : Entity_Id) return Target_Rep_Record
10594 Rec : Target_Rep_Record;
10597 Rec.Kind := Generic_Target;
10599 Spec_And_Body_From_Entity
10601 Body_Decl => Rec.Body_Decl,
10602 Spec_Decl => Rec.Spec_Decl);
10605 end Create_Generic_Rep;
10607 ------------------------------
10608 -- Create_Instantiation_Rep --
10609 ------------------------------
10611 function Create_Instantiation_Rep
10612 (Inst : Node_Id) return Scenario_Rep_Record
10614 Rec : Scenario_Rep_Record;
10617 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst);
10618 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Inst);
10619 Rec.GM := Ghost_Mode_Of_Node (Inst);
10620 Rec.SM := SPARK_Mode_Of_Node (Inst);
10621 Rec.Kind := Instantiation_Scenario;
10622 Rec.Target := Instantiated_Generic (Inst);
10625 end Create_Instantiation_Rep;
10627 --------------------------------
10628 -- Create_Protected_Entry_Rep --
10629 --------------------------------
10631 function Create_Protected_Entry_Rep
10632 (PE_Id : Entity_Id) return Target_Rep_Record
10634 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PE_Id);
10636 Barf_Id : Entity_Id;
10638 Rec : Target_Rep_Record;
10639 Spec_Id : Entity_Id;
10642 -- When the entry [family] has already been expanded, it carries both
10643 -- the procedure which emulates the behavior of the entry [family] as
10644 -- well as the barrier function.
10646 if Present (Prot_Id) then
10647 Barf_Id := Barrier_Function (PE_Id);
10648 Spec_Id := Prot_Id;
10650 -- Otherwise no expansion took place
10657 Rec.Kind := Subprogram_Target;
10659 Spec_And_Body_From_Entity
10661 Body_Decl => Rec.Body_Decl,
10662 Spec_Decl => Rec.Spec_Decl);
10664 -- Target-specific attributes
10666 if Present (Barf_Id) then
10667 Spec_And_Body_From_Entity
10669 Body_Decl => Rec.Field_1, -- Barrier_Body_Declaration
10670 Spec_Decl => Dummy);
10674 end Create_Protected_Entry_Rep;
10676 -------------------------------------
10677 -- Create_Protected_Subprogram_Rep --
10678 -------------------------------------
10680 function Create_Protected_Subprogram_Rep
10681 (PS_Id : Entity_Id) return Target_Rep_Record
10683 Prot_Id : constant Entity_Id := Protected_Body_Subprogram (PS_Id);
10684 Rec : Target_Rep_Record;
10685 Spec_Id : Entity_Id;
10688 -- When the protected subprogram has already been expanded, it
10689 -- carries the subprogram which seizes the lock and invokes the
10690 -- original statements.
10692 if Present (Prot_Id) then
10693 Spec_Id := Prot_Id;
10695 -- Otherwise no expansion took place
10701 Rec.Kind := Subprogram_Target;
10703 Spec_And_Body_From_Entity
10705 Body_Decl => Rec.Body_Decl,
10706 Spec_Decl => Rec.Spec_Decl);
10709 end Create_Protected_Subprogram_Rep;
10711 -------------------------------------
10712 -- Create_Refined_State_Pragma_Rep --
10713 -------------------------------------
10715 function Create_Refined_State_Pragma_Rep
10716 (Prag : Node_Id) return Scenario_Rep_Record
10718 Rec : Scenario_Rep_Record;
10721 Rec.Elab_Checks_OK := False; -- not relevant
10722 Rec.Elab_Warnings_OK := False; -- not relevant
10724 To_Ghost_Mode (Is_Ignored_Ghost_Pragma (Prag));
10725 Rec.SM := Is_Off_Or_Not_Specified;
10726 Rec.Kind := Refined_State_Pragma_Scenario;
10727 Rec.Target := Empty;
10730 end Create_Refined_State_Pragma_Rep;
10732 -------------------------
10733 -- Create_Scenario_Rep --
10734 -------------------------
10736 function Create_Scenario_Rep
10738 In_State : Processing_In_State) return Scenario_Rep_Record
10740 pragma Unreferenced (In_State);
10742 Rec : Scenario_Rep_Record;
10745 if Is_Suitable_Access_Taken (N) then
10746 Rec := Create_Access_Taken_Rep (N);
10748 elsif Is_Suitable_Call (N) then
10749 Rec := Create_Call_Or_Task_Activation_Rep (N);
10751 elsif Is_Suitable_Instantiation (N) then
10752 Rec := Create_Instantiation_Rep (N);
10754 elsif Is_Suitable_SPARK_Derived_Type (N) then
10755 Rec := Create_Derived_Type_Rep (N);
10757 elsif Is_Suitable_SPARK_Refined_State_Pragma (N) then
10758 Rec := Create_Refined_State_Pragma_Rep (N);
10760 elsif Is_Suitable_Variable_Assignment (N) then
10761 Rec := Create_Variable_Assignment_Rep (N);
10763 elsif Is_Suitable_Variable_Reference (N) then
10764 Rec := Create_Variable_Reference_Rep (N);
10767 pragma Assert (False);
10771 -- Common scenario attributes
10773 Rec.Level := Find_Enclosing_Level (N);
10776 end Create_Scenario_Rep;
10778 ---------------------------
10779 -- Create_Subprogram_Rep --
10780 ---------------------------
10782 function Create_Subprogram_Rep
10783 (Subp_Id : Entity_Id) return Target_Rep_Record
10785 Rec : Target_Rep_Record;
10786 Spec_Id : Entity_Id;
10789 Spec_Id := Subp_Id;
10791 -- The elaboration target denotes an internal function that returns a
10792 -- constrained array type in a SPARK-to-C compilation. In this case
10793 -- the function receives a corresponding procedure which has an out
10794 -- parameter. The proper body for ABE checks and diagnostics is that
10795 -- of the procedure.
10797 if Ekind (Spec_Id) = E_Function
10798 and then Rewritten_For_C (Spec_Id)
10800 Spec_Id := Corresponding_Procedure (Spec_Id);
10803 Rec.Kind := Subprogram_Target;
10805 Spec_And_Body_From_Entity
10807 Body_Decl => Rec.Body_Decl,
10808 Spec_Decl => Rec.Spec_Decl);
10811 end Create_Subprogram_Rep;
10813 -----------------------
10814 -- Create_Target_Rep --
10815 -----------------------
10817 function Create_Target_Rep
10819 In_State : Processing_In_State) return Target_Rep_Record
10821 Rec : Target_Rep_Record;
10824 if Is_Generic_Unit (Id) then
10825 Rec := Create_Generic_Rep (Id);
10827 elsif Is_Protected_Entry (Id) then
10828 Rec := Create_Protected_Entry_Rep (Id);
10830 elsif Is_Protected_Subp (Id) then
10831 Rec := Create_Protected_Subprogram_Rep (Id);
10833 elsif Is_Task_Entry (Id) then
10834 Rec := Create_Task_Entry_Rep (Id);
10836 elsif Is_Task_Type (Id) then
10837 Rec := Create_Task_Rep (Id);
10839 elsif Ekind_In (Id, E_Constant, E_Variable) then
10840 Rec := Create_Variable_Rep (Id);
10842 elsif Ekind_In (Id, E_Entry,
10847 Rec := Create_Subprogram_Rep (Id);
10850 pragma Assert (False);
10854 -- Common target attributes
10856 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Id);
10857 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Id);
10858 Rec.GM := Ghost_Mode_Of_Entity (Id);
10859 Rec.SM := SPARK_Mode_Of_Entity (Id);
10860 Rec.Unit := Find_Top_Unit (Id);
10861 Rec.Version := In_State.Representation;
10864 end Create_Target_Rep;
10866 ---------------------------
10867 -- Create_Task_Entry_Rep --
10868 ---------------------------
10870 function Create_Task_Entry_Rep
10871 (TE_Id : Entity_Id) return Target_Rep_Record
10873 Task_Typ : constant Entity_Id := Non_Private_View (Scope (TE_Id));
10874 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ);
10876 Rec : Target_Rep_Record;
10877 Spec_Id : Entity_Id;
10880 -- The the task type has already been expanded, it carries the
10881 -- procedure which emulates the behavior of the task body.
10883 if Present (Task_Body_Id) then
10884 Spec_Id := Task_Body_Id;
10886 -- Otherwise no expansion took place
10892 Rec.Kind := Subprogram_Target;
10894 Spec_And_Body_From_Entity
10896 Body_Decl => Rec.Body_Decl,
10897 Spec_Decl => Rec.Spec_Decl);
10900 end Create_Task_Entry_Rep;
10902 ---------------------
10903 -- Create_Task_Rep --
10904 ---------------------
10906 function Create_Task_Rep
10907 (Task_Typ : Entity_Id) return Target_Rep_Record
10909 Task_Body_Id : constant Entity_Id := Task_Body_Procedure (Task_Typ);
10911 Rec : Target_Rep_Record;
10912 Spec_Id : Entity_Id;
10915 -- The the task type has already been expanded, it carries the
10916 -- procedure which emulates the behavior of the task body.
10918 if Present (Task_Body_Id) then
10919 Spec_Id := Task_Body_Id;
10921 -- Otherwise no expansion took place
10924 Spec_Id := Task_Typ;
10927 Rec.Kind := Task_Target;
10929 Spec_And_Body_From_Entity
10931 Body_Decl => Rec.Body_Decl,
10932 Spec_Decl => Rec.Spec_Decl);
10935 end Create_Task_Rep;
10937 ------------------------------------
10938 -- Create_Variable_Assignment_Rep --
10939 ------------------------------------
10941 function Create_Variable_Assignment_Rep
10942 (Asmt : Node_Id) return Scenario_Rep_Record
10944 Var_Id : constant Entity_Id := Entity (Assignment_Target (Asmt));
10945 Rec : Scenario_Rep_Record;
10948 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Asmt);
10949 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Id (Var_Id);
10950 Rec.GM := Ghost_Mode_Of_Node (Asmt);
10951 Rec.SM := SPARK_Mode_Of_Node (Asmt);
10952 Rec.Kind := Variable_Assignment_Scenario;
10953 Rec.Target := Var_Id;
10956 end Create_Variable_Assignment_Rep;
10958 -----------------------------------
10959 -- Create_Variable_Reference_Rep --
10960 -----------------------------------
10962 function Create_Variable_Reference_Rep
10963 (Ref : Node_Id) return Scenario_Rep_Record
10965 Rec : Scenario_Rep_Record;
10968 Rec.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Ref);
10969 Rec.Elab_Warnings_OK := Is_Elaboration_Warnings_OK_Node (Ref);
10970 Rec.GM := Ghost_Mode_Of_Node (Ref);
10971 Rec.SM := SPARK_Mode_Of_Node (Ref);
10972 Rec.Kind := Variable_Reference_Scenario;
10973 Rec.Target := Target (Ref);
10975 -- Scenario-specific attributes
10977 Rec.Flag_1 := Is_Read (Ref); -- Is_Read_Reference
10980 end Create_Variable_Reference_Rep;
10982 -------------------------
10983 -- Create_Variable_Rep --
10984 -------------------------
10986 function Create_Variable_Rep
10987 (Var_Id : Entity_Id) return Target_Rep_Record
10989 Rec : Target_Rep_Record;
10992 Rec.Kind := Variable_Target;
10994 -- Target-specific attributes
10996 Rec.Field_1 := Declaration_Node (Var_Id); -- Variable_Declaration
10999 end Create_Variable_Rep;
11005 procedure Destroy (S_Id : in out Scenario_Rep_Id) is
11006 pragma Unreferenced (S_Id);
11015 procedure Destroy (T_Id : in out Target_Rep_Id) is
11016 pragma Unreferenced (T_Id);
11021 --------------------------------
11022 -- Disable_Elaboration_Checks --
11023 --------------------------------
11025 procedure Disable_Elaboration_Checks (S_Id : Scenario_Rep_Id) is
11026 pragma Assert (Present (S_Id));
11028 Scenario_Reps.Table (S_Id).Elab_Checks_OK := False;
11029 end Disable_Elaboration_Checks;
11031 --------------------------------
11032 -- Disable_Elaboration_Checks --
11033 --------------------------------
11035 procedure Disable_Elaboration_Checks (T_Id : Target_Rep_Id) is
11036 pragma Assert (Present (T_Id));
11038 Target_Reps.Table (T_Id).Elab_Checks_OK := False;
11039 end Disable_Elaboration_Checks;
11041 ---------------------------
11042 -- Elaboration_Checks_OK --
11043 ---------------------------
11045 function Elaboration_Checks_OK (S_Id : Scenario_Rep_Id) return Boolean is
11046 pragma Assert (Present (S_Id));
11048 return Scenario_Reps.Table (S_Id).Elab_Checks_OK;
11049 end Elaboration_Checks_OK;
11051 ---------------------------
11052 -- Elaboration_Checks_OK --
11053 ---------------------------
11055 function Elaboration_Checks_OK (T_Id : Target_Rep_Id) return Boolean is
11056 pragma Assert (Present (T_Id));
11058 return Target_Reps.Table (T_Id).Elab_Checks_OK;
11059 end Elaboration_Checks_OK;
11061 -----------------------------
11062 -- Elaboration_Warnings_OK --
11063 -----------------------------
11065 function Elaboration_Warnings_OK
11066 (S_Id : Scenario_Rep_Id) return Boolean
11068 pragma Assert (Present (S_Id));
11070 return Scenario_Reps.Table (S_Id).Elab_Warnings_OK;
11071 end Elaboration_Warnings_OK;
11073 -----------------------------
11074 -- Elaboration_Warnings_OK --
11075 -----------------------------
11077 function Elaboration_Warnings_OK (T_Id : Target_Rep_Id) return Boolean is
11078 pragma Assert (Present (T_Id));
11080 return Target_Reps.Table (T_Id).Elab_Warnings_OK;
11081 end Elaboration_Warnings_OK;
11083 --------------------------------------
11084 -- Finalize_Internal_Representation --
11085 --------------------------------------
11087 procedure Finalize_Internal_Representation is
11089 ETT_Map.Destroy (Entity_To_Target_Map);
11090 NTS_Map.Destroy (Node_To_Scenario_Map);
11091 end Finalize_Internal_Representation;
11093 -------------------
11094 -- Ghost_Mode_Of --
11095 -------------------
11097 function Ghost_Mode_Of
11098 (S_Id : Scenario_Rep_Id) return Extended_Ghost_Mode
11100 pragma Assert (Present (S_Id));
11102 return Scenario_Reps.Table (S_Id).GM;
11105 -------------------
11106 -- Ghost_Mode_Of --
11107 -------------------
11109 function Ghost_Mode_Of
11110 (T_Id : Target_Rep_Id) return Extended_Ghost_Mode
11112 pragma Assert (Present (T_Id));
11114 return Target_Reps.Table (T_Id).GM;
11117 --------------------------
11118 -- Ghost_Mode_Of_Entity --
11119 --------------------------
11121 function Ghost_Mode_Of_Entity
11122 (Id : Entity_Id) return Extended_Ghost_Mode
11125 return To_Ghost_Mode (Is_Ignored_Ghost_Entity (Id));
11126 end Ghost_Mode_Of_Entity;
11128 ------------------------
11129 -- Ghost_Mode_Of_Node --
11130 ------------------------
11132 function Ghost_Mode_Of_Node (N : Node_Id) return Extended_Ghost_Mode is
11134 return To_Ghost_Mode (Is_Ignored_Ghost_Node (N));
11135 end Ghost_Mode_Of_Node;
11137 ----------------------------------------
11138 -- Initialize_Internal_Representation --
11139 ----------------------------------------
11141 procedure Initialize_Internal_Representation is
11143 Entity_To_Target_Map := ETT_Map.Create (500);
11144 Node_To_Scenario_Map := NTS_Map.Create (500);
11145 end Initialize_Internal_Representation;
11147 -------------------------
11148 -- Is_Dispatching_Call --
11149 -------------------------
11151 function Is_Dispatching_Call (S_Id : Scenario_Rep_Id) return Boolean is
11152 pragma Assert (Present (S_Id));
11153 pragma Assert (Kind (S_Id) = Call_Scenario);
11156 return Scenario_Reps.Table (S_Id).Flag_1;
11157 end Is_Dispatching_Call;
11159 -----------------------
11160 -- Is_Read_Reference --
11161 -----------------------
11163 function Is_Read_Reference (S_Id : Scenario_Rep_Id) return Boolean is
11164 pragma Assert (Present (S_Id));
11165 pragma Assert (Kind (S_Id) = Variable_Reference_Scenario);
11168 return Scenario_Reps.Table (S_Id).Flag_1;
11169 end Is_Read_Reference;
11175 function Kind (S_Id : Scenario_Rep_Id) return Scenario_Kind is
11176 pragma Assert (Present (S_Id));
11178 return Scenario_Reps.Table (S_Id).Kind;
11185 function Kind (T_Id : Target_Rep_Id) return Target_Kind is
11186 pragma Assert (Present (T_Id));
11188 return Target_Reps.Table (T_Id).Kind;
11195 function Level (S_Id : Scenario_Rep_Id) return Enclosing_Level_Kind is
11196 pragma Assert (Present (S_Id));
11198 return Scenario_Reps.Table (S_Id).Level;
11205 function Present (S_Id : Scenario_Rep_Id) return Boolean is
11207 return S_Id /= No_Scenario_Rep;
11214 function Present (T_Id : Target_Rep_Id) return Boolean is
11216 return T_Id /= No_Target_Rep;
11219 --------------------------------
11220 -- Scenario_Representation_Of --
11221 --------------------------------
11223 function Scenario_Representation_Of
11225 In_State : Processing_In_State) return Scenario_Rep_Id
11227 S_Id : Scenario_Rep_Id;
11230 S_Id := NTS_Map.Get (Node_To_Scenario_Map, N);
11232 -- The elaboration scenario lacks a representation. This indicates
11233 -- that the scenario is encountered for the first time. Create the
11234 -- representation of it.
11236 if not Present (S_Id) then
11237 Scenario_Reps.Append (Create_Scenario_Rep (N, In_State));
11238 S_Id := Scenario_Reps.Last;
11240 -- Associate the internal representation with the elaboration
11243 NTS_Map.Put (Node_To_Scenario_Map, N, S_Id);
11246 pragma Assert (Present (S_Id));
11249 end Scenario_Representation_Of;
11251 --------------------------------
11252 -- Set_Activated_Task_Objects --
11253 --------------------------------
11255 procedure Set_Activated_Task_Objects
11256 (S_Id : Scenario_Rep_Id;
11257 Task_Objs : NE_List.Doubly_Linked_List)
11259 pragma Assert (Present (S_Id));
11260 pragma Assert (Kind (S_Id) = Task_Activation_Scenario);
11263 Scenario_Reps.Table (S_Id).List_1 := Task_Objs;
11264 end Set_Activated_Task_Objects;
11266 -----------------------------
11267 -- Set_Activated_Task_Type --
11268 -----------------------------
11270 procedure Set_Activated_Task_Type
11271 (S_Id : Scenario_Rep_Id;
11272 Task_Typ : Entity_Id)
11274 pragma Assert (Present (S_Id));
11275 pragma Assert (Kind (S_Id) = Task_Activation_Scenario);
11278 Scenario_Reps.Table (S_Id).Field_1 := Task_Typ;
11279 end Set_Activated_Task_Type;
11281 -------------------
11282 -- SPARK_Mode_Of --
11283 -------------------
11285 function SPARK_Mode_Of
11286 (S_Id : Scenario_Rep_Id) return Extended_SPARK_Mode
11288 pragma Assert (Present (S_Id));
11290 return Scenario_Reps.Table (S_Id).SM;
11293 -------------------
11294 -- SPARK_Mode_Of --
11295 -------------------
11297 function SPARK_Mode_Of
11298 (T_Id : Target_Rep_Id) return Extended_SPARK_Mode
11300 pragma Assert (Present (T_Id));
11302 return Target_Reps.Table (T_Id).SM;
11305 --------------------------
11306 -- SPARK_Mode_Of_Entity --
11307 --------------------------
11309 function SPARK_Mode_Of_Entity
11310 (Id : Entity_Id) return Extended_SPARK_Mode
11312 Prag : constant Node_Id := SPARK_Pragma (Id);
11318 and then Get_SPARK_Mode_From_Annotation (Prag) = On);
11319 end SPARK_Mode_Of_Entity;
11321 ------------------------
11322 -- SPARK_Mode_Of_Node --
11323 ------------------------
11325 function SPARK_Mode_Of_Node (N : Node_Id) return Extended_SPARK_Mode is
11327 return To_SPARK_Mode (Is_SPARK_Mode_On_Node (N));
11328 end SPARK_Mode_Of_Node;
11330 ----------------------
11331 -- Spec_Declaration --
11332 ----------------------
11334 function Spec_Declaration (T_Id : Target_Rep_Id) return Node_Id is
11335 pragma Assert (Present (T_Id));
11337 return Target_Reps.Table (T_Id).Spec_Decl;
11338 end Spec_Declaration;
11344 function Target (S_Id : Scenario_Rep_Id) return Entity_Id is
11345 pragma Assert (Present (S_Id));
11347 return Scenario_Reps.Table (S_Id).Target;
11350 ------------------------------
11351 -- Target_Representation_Of --
11352 ------------------------------
11354 function Target_Representation_Of
11356 In_State : Processing_In_State) return Target_Rep_Id
11358 T_Id : Target_Rep_Id;
11361 T_Id := ETT_Map.Get (Entity_To_Target_Map, Id);
11363 -- The elaboration target lacks an internal representation. This
11364 -- indicates that the target is encountered for the first time.
11365 -- Create the internal representation of it.
11367 if not Present (T_Id) then
11368 Target_Reps.Append (Create_Target_Rep (Id, In_State));
11369 T_Id := Target_Reps.Last;
11371 -- Associate the internal representation with the elaboration
11374 ETT_Map.Put (Entity_To_Target_Map, Id, T_Id);
11376 -- The Processing phase is working with a partially analyzed tree,
11377 -- where various attributes become available as analysis continues.
11378 -- This case arrises in the context of guaranteed ABE processing.
11379 -- Update the existing representation by including new attributes.
11381 elsif In_State.Representation = Inconsistent_Representation then
11382 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State);
11384 -- Otherwise the Processing phase imposes a particular representation
11385 -- version which is not satisfied by the target. This case arrises
11386 -- when the Processing phase switches from guaranteed ABE checks and
11387 -- diagnostics to some other mode of operation. Update the existing
11388 -- representation to include all attributes.
11390 elsif In_State.Representation /= Version (T_Id) then
11391 Target_Reps.Table (T_Id) := Create_Target_Rep (Id, In_State);
11394 pragma Assert (Present (T_Id));
11397 end Target_Representation_Of;
11399 -------------------
11400 -- To_Ghost_Mode --
11401 -------------------
11403 function To_Ghost_Mode
11404 (Ignored_Status : Boolean) return Extended_Ghost_Mode
11407 if Ignored_Status then
11410 return Is_Checked_Or_Not_Specified;
11414 -------------------
11415 -- To_SPARK_Mode --
11416 -------------------
11418 function To_SPARK_Mode
11419 (On_Status : Boolean) return Extended_SPARK_Mode
11425 return Is_Off_Or_Not_Specified;
11433 function Unit (T_Id : Target_Rep_Id) return Entity_Id is
11434 pragma Assert (Present (T_Id));
11436 return Target_Reps.Table (T_Id).Unit;
11439 --------------------------
11440 -- Variable_Declaration --
11441 --------------------------
11443 function Variable_Declaration (T_Id : Target_Rep_Id) return Node_Id is
11444 pragma Assert (Present (T_Id));
11445 pragma Assert (Kind (T_Id) = Variable_Target);
11448 return Target_Reps.Table (T_Id).Field_1;
11449 end Variable_Declaration;
11455 function Version (T_Id : Target_Rep_Id) return Representation_Kind is
11456 pragma Assert (Present (T_Id));
11458 return Target_Reps.Table (T_Id).Version;
11460 end Internal_Representation;
11462 ----------------------
11463 -- Invocation_Graph --
11464 ----------------------
11466 package body Invocation_Graph is
11472 -- The following type represents simplified version of an invocation
11475 type Invoker_Target_Relation is record
11476 Invoker : Entity_Id := Empty;
11477 Target : Entity_Id := Empty;
11480 -- The following variables define the entities of the dummy elaboration
11481 -- procedures used as origins of library level paths.
11483 Elab_Body_Id : Entity_Id := Empty;
11484 Elab_Spec_Id : Entity_Id := Empty;
11486 ---------------------
11487 -- Data structures --
11488 ---------------------
11490 -- The following set contains all declared invocation constructs. It
11491 -- ensures that the same construct is not declared multiple times in
11492 -- the ALI file of the main unit.
11494 Saved_Constructs_Set : NE_Set.Membership_Set := NE_Set.Nil;
11496 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type;
11497 -- Obtain the hash value of pair Key
11499 package IR_Set is new Membership_Sets
11500 (Element_Type => Invoker_Target_Relation,
11504 -- The following set contains all recorded simple invocation relations.
11505 -- It ensures that multiple relations involving the same invoker and
11506 -- target do not appear in the ALI file of the main unit.
11508 Saved_Relations_Set : IR_Set.Membership_Set := IR_Set.Nil;
11514 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id;
11515 pragma Inline (Signature_Of);
11516 -- Obtain the invication signature id of arbitrary entity Id
11518 -----------------------
11519 -- Local subprograms --
11520 -----------------------
11522 procedure Build_Elaborate_Body_Procedure;
11523 pragma Inline (Build_Elaborate_Body_Procedure);
11524 -- Create a dummy elaborate body procedure and store its entity in
11527 procedure Build_Elaborate_Procedure
11528 (Proc_Id : out Entity_Id;
11529 Proc_Nam : Name_Id;
11531 pragma Inline (Build_Elaborate_Procedure);
11532 -- Create a dummy elaborate procedure with name Proc_Nam and source
11533 -- location Loc. The entity is returned in Proc_Id.
11535 procedure Build_Elaborate_Spec_Procedure;
11536 pragma Inline (Build_Elaborate_Spec_Procedure);
11537 -- Create a dummy elaborate spec procedure and store its entity in
11540 function Build_Subprogram_Invocation
11541 (Subp_Id : Entity_Id) return Node_Id;
11542 pragma Inline (Build_Subprogram_Invocation);
11543 -- Create a dummy call marker that invokes subprogram Subp_Id
11545 function Build_Task_Activation
11546 (Task_Typ : Entity_Id;
11547 In_State : Processing_In_State) return Node_Id;
11548 pragma Inline (Build_Task_Activation);
11549 -- Create a dummy call marker that activates an anonymous task object of
11552 procedure Declare_Invocation_Construct
11553 (Constr_Id : Entity_Id;
11554 In_State : Processing_In_State);
11555 pragma Inline (Declare_Invocation_Construct);
11556 -- Declare invocation construct Constr_Id by creating a declaration for
11557 -- it in the ALI file of the main unit. In_State is the current state of
11558 -- the Processing phase.
11560 function Invocation_Graph_Recording_OK return Boolean;
11561 pragma Inline (Invocation_Graph_Recording_OK);
11562 -- Determine whether the invocation graph can be recorded
11564 function Is_Invocation_Scenario (N : Node_Id) return Boolean;
11565 pragma Inline (Is_Invocation_Scenario);
11566 -- Determine whether node N is a suitable scenario for invocation graph
11567 -- recording purposes.
11569 function Is_Invocation_Target (Id : Entity_Id) return Boolean;
11570 pragma Inline (Is_Invocation_Target);
11571 -- Determine whether arbitrary entity Id denotes an invocation target
11573 function Is_Saved_Construct (Constr : Entity_Id) return Boolean;
11574 pragma Inline (Is_Saved_Construct);
11575 -- Determine whether invocation construct Constr has already been
11576 -- declared in the ALI file of the main unit.
11578 function Is_Saved_Relation
11579 (Rel : Invoker_Target_Relation) return Boolean;
11580 pragma Inline (Is_Saved_Relation);
11581 -- Determine whether simple invocation relation Rel has already been
11582 -- recorded in the ALI file of the main unit.
11584 procedure Process_Declarations
11586 In_State : Processing_In_State);
11587 pragma Inline (Process_Declarations);
11588 -- Process declaration list Decls by processing all invocation scenarios
11591 procedure Process_Freeze_Node
11593 In_State : Processing_In_State);
11594 pragma Inline (Process_Freeze_Node);
11595 -- Process freeze node Fnode by processing all invocation scenarios in
11596 -- its Actions list.
11598 procedure Process_Invocation_Activation
11600 Call_Rep : Scenario_Rep_Id;
11601 Obj_Id : Entity_Id;
11602 Obj_Rep : Target_Rep_Id;
11603 Task_Typ : Entity_Id;
11604 Task_Rep : Target_Rep_Id;
11605 In_State : Processing_In_State);
11606 pragma Inline (Process_Invocation_Activation);
11607 -- Process activation call Call which activates object Obj_Id of task
11608 -- type Task_Typ by processing all invocation scenarios within the task
11609 -- body. Call_Rep is the representation of the call. Obj_Rep denotes the
11610 -- representation of the object. Task_Rep is the representation of the
11611 -- task type. In_State is the current state of the Processing phase.
11613 procedure Process_Invocation_Body_Scenarios;
11614 pragma Inline (Process_Invocation_Body_Scenarios);
11615 -- Process all library level body scenarios
11617 procedure Process_Invocation_Call
11619 Call_Rep : Scenario_Rep_Id;
11620 In_State : Processing_In_State);
11621 pragma Inline (Process_Invocation_Call);
11622 -- Process invocation call scenario Call with representation Call_Rep.
11623 -- In_State is the current state of the Processing phase.
11625 procedure Process_Invocation_Scenario
11627 In_State : Processing_In_State);
11628 pragma Inline (Process_Invocation_Scenario);
11629 -- Process single invocation scenario N. In_State is the current state
11630 -- of the Processing phase.
11632 procedure Process_Invocation_Scenarios
11633 (Iter : in out NE_Set.Iterator;
11634 In_State : Processing_In_State);
11635 pragma Inline (Process_Invocation_Scenarios);
11636 -- Process all invocation scenarios obtained via iterator Iter. In_State
11637 -- is the current state of the Processing phase.
11639 procedure Process_Invocation_Spec_Scenarios;
11640 pragma Inline (Process_Invocation_Spec_Scenarios);
11641 -- Process all library level spec scenarios
11643 procedure Process_Main_Unit;
11644 pragma Inline (Process_Main_Unit);
11645 -- Process all invocation scenarios within the main unit
11647 procedure Process_Package_Declaration
11648 (Pack_Decl : Node_Id;
11649 In_State : Processing_In_State);
11650 pragma Inline (Process_Package_Declaration);
11651 -- Process package declaration Pack_Decl by processing all invocation
11652 -- scenarios in its visible and private declarations. If the main unit
11653 -- contains a generic, the declarations of the body are also examined.
11654 -- In_State is the current state of the Processing phase.
11656 procedure Process_Protected_Type_Declaration
11657 (Prot_Decl : Node_Id;
11658 In_State : Processing_In_State);
11659 pragma Inline (Process_Protected_Type_Declaration);
11660 -- Process the declarations of protected type Prot_Decl. In_State is the
11661 -- current state of the Processing phase.
11663 procedure Process_Subprogram_Declaration
11664 (Subp_Decl : Node_Id;
11665 In_State : Processing_In_State);
11666 pragma Inline (Process_Subprogram_Declaration);
11667 -- Process subprogram declaration Subp_Decl by processing all invocation
11668 -- scenarios within its body. In_State denotes the current state of the
11669 -- Processing phase.
11671 procedure Process_Subprogram_Instantiation
11673 In_State : Processing_In_State);
11674 pragma Inline (Process_Subprogram_Instantiation);
11675 -- Process subprogram instantiation Inst. In_State is the current state
11676 -- of the Processing phase.
11678 procedure Process_Task_Type_Declaration
11679 (Task_Decl : Node_Id;
11680 In_State : Processing_In_State);
11681 pragma Inline (Process_Task_Type_Declaration);
11682 -- Process task declaration Task_Decl by processing all invocation
11683 -- scenarios within its body. In_State is the current state of the
11684 -- Processing phase.
11686 procedure Record_Full_Invocation_Path (In_State : Processing_In_State);
11687 pragma Inline (Record_Full_Invocation_Path);
11688 -- Record all relations between scenario pairs found in the stack of
11689 -- active scenarios. In_State is the current state of the Processing
11692 procedure Record_Invocation_Graph_Encoding;
11693 pragma Inline (Record_Invocation_Graph_Encoding);
11694 -- Record the encoding format used to capture information related to
11695 -- invocation constructs and relations.
11697 procedure Record_Invocation_Path (In_State : Processing_In_State);
11698 pragma Inline (Record_Invocation_Path);
11699 -- Record the invocation relations found within the path represented in
11700 -- the active scenario stack. In_State denotes the current state of the
11701 -- Processing phase.
11703 procedure Record_Simple_Invocation_Path (In_State : Processing_In_State);
11704 pragma Inline (Record_Simple_Invocation_Path);
11705 -- Record a single relation from the start to the end of the stack of
11706 -- active scenarios. In_State is the current state of the Processing
11709 procedure Record_Invocation_Relation
11710 (Invk_Id : Entity_Id;
11711 Targ_Id : Entity_Id;
11712 In_State : Processing_In_State);
11713 pragma Inline (Record_Invocation_Relation);
11714 -- Record an invocation relation with invoker Invk_Id and target Targ_Id
11715 -- by creating an entry for it in the ALI file of the main unit. Formal
11716 -- In_State denotes the current state of the Processing phase.
11718 procedure Set_Is_Saved_Construct
11719 (Constr : Entity_Id;
11720 Val : Boolean := True);
11721 pragma Inline (Set_Is_Saved_Construct);
11722 -- Mark invocation construct Constr as declared in the ALI file of the
11723 -- main unit depending on value Val.
11725 procedure Set_Is_Saved_Relation
11726 (Rel : Invoker_Target_Relation;
11727 Val : Boolean := True);
11728 pragma Inline (Set_Is_Saved_Relation);
11729 -- Mark simple invocation relation Rel as recorded in the ALI file of
11730 -- the main unit depending on value Val.
11733 (Pos : Active_Scenario_Pos;
11734 In_State : Processing_In_State) return Entity_Id;
11735 pragma Inline (Target_Of);
11736 -- Given position within the active scenario stack Pos, obtain the
11737 -- target of the indicated scenario. In_State is the current state
11738 -- of the Processing phase.
11740 procedure Traverse_Invocation_Body
11742 In_State : Processing_In_State);
11743 pragma Inline (Traverse_Invocation_Body);
11744 -- Traverse subprogram body N looking for suitable invocation scenarios
11745 -- that need to be processed for invocation graph recording purposes.
11746 -- In_State is the current state of the Processing phase.
11748 procedure Write_Invocation_Path (In_State : Processing_In_State);
11749 pragma Inline (Write_Invocation_Path);
11750 -- Write out a path represented by the active scenario on the stack to
11751 -- standard output. In_State denotes the current state of the Processing
11754 ------------------------------------
11755 -- Build_Elaborate_Body_Procedure --
11756 ------------------------------------
11758 procedure Build_Elaborate_Body_Procedure is
11759 Body_Decl : Node_Id;
11760 Spec_Decl : Node_Id;
11763 -- Nothing to do when a previous call already created the procedure
11765 if Present (Elab_Body_Id) then
11769 Spec_And_Body_From_Entity
11770 (Id => Cunit_Entity (Main_Unit),
11771 Body_Decl => Body_Decl,
11772 Spec_Decl => Spec_Decl);
11774 pragma Assert (Present (Body_Decl));
11776 Build_Elaborate_Procedure
11777 (Proc_Id => Elab_Body_Id,
11778 Proc_Nam => Name_B,
11779 Loc => Sloc (Body_Decl));
11780 end Build_Elaborate_Body_Procedure;
11782 -------------------------------
11783 -- Build_Elaborate_Procedure --
11784 -------------------------------
11786 procedure Build_Elaborate_Procedure
11787 (Proc_Id : out Entity_Id;
11788 Proc_Nam : Name_Id;
11791 Proc_Decl : Node_Id;
11792 pragma Unreferenced (Proc_Decl);
11795 Proc_Id := Make_Defining_Identifier (Loc, Proc_Nam);
11797 -- Partially decorate the elaboration procedure because it will not
11798 -- be insertred into the tree and analyzed.
11800 Set_Ekind (Proc_Id, E_Procedure);
11801 Set_Etype (Proc_Id, Standard_Void_Type);
11802 Set_Scope (Proc_Id, Unique_Entity (Cunit_Entity (Main_Unit)));
11804 -- Create a dummy declaration for the elaboration procedure. The
11805 -- declaration does not need to be syntactically legal, but must
11806 -- carry an accurate source location.
11809 Make_Subprogram_Body (Loc,
11811 Make_Procedure_Specification (Loc,
11812 Defining_Unit_Name => Proc_Id),
11813 Declarations => No_List,
11814 Handled_Statement_Sequence => Empty);
11815 end Build_Elaborate_Procedure;
11817 ------------------------------------
11818 -- Build_Elaborate_Spec_Procedure --
11819 ------------------------------------
11821 procedure Build_Elaborate_Spec_Procedure is
11822 Body_Decl : Node_Id;
11823 Spec_Decl : Node_Id;
11826 -- Nothing to do when a previous call already created the procedure
11828 if Present (Elab_Spec_Id) then
11832 Spec_And_Body_From_Entity
11833 (Id => Cunit_Entity (Main_Unit),
11834 Body_Decl => Body_Decl,
11835 Spec_Decl => Spec_Decl);
11837 pragma Assert (Present (Spec_Decl));
11839 Build_Elaborate_Procedure
11840 (Proc_Id => Elab_Spec_Id,
11841 Proc_Nam => Name_S,
11842 Loc => Sloc (Spec_Decl));
11843 end Build_Elaborate_Spec_Procedure;
11845 ---------------------------------
11846 -- Build_Subprogram_Invocation --
11847 ---------------------------------
11849 function Build_Subprogram_Invocation
11850 (Subp_Id : Entity_Id) return Node_Id
11852 Marker : constant Node_Id := Make_Call_Marker (Sloc (Subp_Id));
11853 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
11856 -- Create a dummy call marker which invokes the subprogram
11858 Set_Is_Declaration_Level_Node (Marker, False);
11859 Set_Is_Dispatching_Call (Marker, False);
11860 Set_Is_Elaboration_Checks_OK_Node (Marker, False);
11861 Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
11862 Set_Is_Ignored_Ghost_Node (Marker, False);
11863 Set_Is_Source_Call (Marker, False);
11864 Set_Is_SPARK_Mode_On_Node (Marker, False);
11866 -- Invoke the uniform canonical entity of the subprogram
11868 Set_Target (Marker, Canonical_Subprogram (Subp_Id));
11870 -- Partially insert the marker into the tree
11872 Set_Parent (Marker, Parent (Subp_Decl));
11875 end Build_Subprogram_Invocation;
11877 ---------------------------
11878 -- Build_Task_Activation --
11879 ---------------------------
11881 function Build_Task_Activation
11882 (Task_Typ : Entity_Id;
11883 In_State : Processing_In_State) return Node_Id
11885 Loc : constant Source_Ptr := Sloc (Task_Typ);
11886 Marker : constant Node_Id := Make_Call_Marker (Loc);
11887 Task_Decl : constant Node_Id := Unit_Declaration_Node (Task_Typ);
11889 Activ_Id : Entity_Id;
11890 Marker_Rep_Id : Scenario_Rep_Id;
11891 Task_Obj : Entity_Id;
11892 Task_Objs : NE_List.Doubly_Linked_List;
11895 -- Create a dummy call marker which activates some tasks
11897 Set_Is_Declaration_Level_Node (Marker, False);
11898 Set_Is_Dispatching_Call (Marker, False);
11899 Set_Is_Elaboration_Checks_OK_Node (Marker, False);
11900 Set_Is_Elaboration_Warnings_OK_Node (Marker, False);
11901 Set_Is_Ignored_Ghost_Node (Marker, False);
11902 Set_Is_Source_Call (Marker, False);
11903 Set_Is_SPARK_Mode_On_Node (Marker, False);
11905 -- Invoke the appropriate version of Activate_Tasks
11907 if Restricted_Profile then
11908 Activ_Id := RTE (RE_Activate_Restricted_Tasks);
11910 Activ_Id := RTE (RE_Activate_Tasks);
11913 Set_Target (Marker, Activ_Id);
11915 -- Partially insert the marker into the tree
11917 Set_Parent (Marker, Parent (Task_Decl));
11919 -- Create a dummy task object. Partially decorate the object because
11920 -- it will not be inserted into the tree and analyzed.
11922 Task_Obj := Make_Temporary (Loc, 'T');
11923 Set_Ekind (Task_Obj, E_Variable);
11924 Set_Etype (Task_Obj, Task_Typ);
11926 -- Associate the dummy task object with the activation call
11928 Task_Objs := NE_List.Create;
11929 NE_List.Append (Task_Objs, Task_Obj);
11931 Marker_Rep_Id := Scenario_Representation_Of (Marker, In_State);
11932 Set_Activated_Task_Objects (Marker_Rep_Id, Task_Objs);
11933 Set_Activated_Task_Type (Marker_Rep_Id, Task_Typ);
11936 end Build_Task_Activation;
11938 ----------------------------------
11939 -- Declare_Invocation_Construct --
11940 ----------------------------------
11942 procedure Declare_Invocation_Construct
11943 (Constr_Id : Entity_Id;
11944 In_State : Processing_In_State)
11946 function Body_Placement_Of
11947 (Id : Entity_Id) return Declaration_Placement_Kind;
11948 pragma Inline (Body_Placement_Of);
11949 -- Obtain the placement of arbitrary entity Id's body
11951 function Declaration_Placement_Of_Node
11952 (N : Node_Id) return Declaration_Placement_Kind;
11953 pragma Inline (Declaration_Placement_Of_Node);
11954 -- Obtain the placement of arbitrary node N
11956 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind;
11957 pragma Inline (Kind_Of);
11958 -- Obtain the invocation construct kind of arbitrary entity Id
11960 function Spec_Placement_Of
11961 (Id : Entity_Id) return Declaration_Placement_Kind;
11962 pragma Inline (Spec_Placement_Of);
11963 -- Obtain the placement of arbitrary entity Id's spec
11965 -----------------------
11966 -- Body_Placement_Of --
11967 -----------------------
11969 function Body_Placement_Of
11970 (Id : Entity_Id) return Declaration_Placement_Kind
11972 Id_Rep : constant Target_Rep_Id :=
11973 Target_Representation_Of (Id, In_State);
11974 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep);
11975 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep);
11978 -- The entity has a body
11980 if Present (Body_Decl) then
11981 return Declaration_Placement_Of_Node (Body_Decl);
11983 -- Otherwise the entity must have a spec
11986 pragma Assert (Present (Spec_Decl));
11987 return Declaration_Placement_Of_Node (Spec_Decl);
11989 end Body_Placement_Of;
11991 -----------------------------------
11992 -- Declaration_Placement_Of_Node --
11993 -----------------------------------
11995 function Declaration_Placement_Of_Node
11996 (N : Node_Id) return Declaration_Placement_Kind
11998 Main_Unit_Id : constant Entity_Id := Cunit_Entity (Main_Unit);
11999 N_Unit_Id : constant Entity_Id := Find_Top_Unit (N);
12002 -- The node is in the main unit, its placement depends on the main
12005 if N_Unit_Id = Main_Unit_Id then
12007 -- The main unit is a body
12009 if Ekind_In (Main_Unit_Id, E_Package_Body,
12014 -- The main unit is a stand-alone subprogram body
12016 elsif Ekind_In (Main_Unit_Id, E_Function, E_Procedure)
12017 and then Nkind (Unit_Declaration_Node (Main_Unit_Id)) =
12022 -- Otherwise the main unit is a spec
12028 -- Otherwise the node is in the complementary unit of the main
12029 -- unit. The main unit is a body, the node is in the spec.
12031 elsif Ekind_In (Main_Unit_Id, E_Package_Body,
12036 -- The main unit is a spec, the node is in the body
12041 end Declaration_Placement_Of_Node;
12047 function Kind_Of (Id : Entity_Id) return Invocation_Construct_Kind is
12049 if Id = Elab_Body_Id then
12050 return Elaborate_Body_Procedure;
12052 elsif Id = Elab_Spec_Id then
12053 return Elaborate_Spec_Procedure;
12056 return Regular_Construct;
12060 -----------------------
12061 -- Spec_Placement_Of --
12062 -----------------------
12064 function Spec_Placement_Of
12065 (Id : Entity_Id) return Declaration_Placement_Kind
12067 Id_Rep : constant Target_Rep_Id :=
12068 Target_Representation_Of (Id, In_State);
12069 Body_Decl : constant Node_Id := Body_Declaration (Id_Rep);
12070 Spec_Decl : constant Node_Id := Spec_Declaration (Id_Rep);
12073 -- The entity has a spec
12075 if Present (Spec_Decl) then
12076 return Declaration_Placement_Of_Node (Spec_Decl);
12078 -- Otherwise the entity must have a body
12081 pragma Assert (Present (Body_Decl));
12082 return Declaration_Placement_Of_Node (Body_Decl);
12084 end Spec_Placement_Of;
12086 -- Start of processing for Declare_Invocation_Construct
12089 -- Nothing to do when the construct has already been declared in the
12092 if Is_Saved_Construct (Constr_Id) then
12096 -- Mark the construct as declared in the ALI file
12098 Set_Is_Saved_Construct (Constr_Id);
12100 -- Add the construct in the ALI file
12102 Add_Invocation_Construct
12103 (Body_Placement => Body_Placement_Of (Constr_Id),
12104 Kind => Kind_Of (Constr_Id),
12105 Signature => Signature_Of (Constr_Id),
12106 Spec_Placement => Spec_Placement_Of (Constr_Id),
12107 Update_Units => False);
12108 end Declare_Invocation_Construct;
12110 -------------------------------
12111 -- Finalize_Invocation_Graph --
12112 -------------------------------
12114 procedure Finalize_Invocation_Graph is
12116 NE_Set.Destroy (Saved_Constructs_Set);
12117 IR_Set.Destroy (Saved_Relations_Set);
12118 end Finalize_Invocation_Graph;
12124 function Hash (Key : Invoker_Target_Relation) return Bucket_Range_Type is
12125 pragma Assert (Present (Key.Invoker));
12126 pragma Assert (Present (Key.Target));
12131 (Bucket_Range_Type (Key.Invoker),
12132 Bucket_Range_Type (Key.Target));
12135 ---------------------------------
12136 -- Initialize_Invocation_Graph --
12137 ---------------------------------
12139 procedure Initialize_Invocation_Graph is
12141 Saved_Constructs_Set := NE_Set.Create (100);
12142 Saved_Relations_Set := IR_Set.Create (200);
12143 end Initialize_Invocation_Graph;
12145 -----------------------------------
12146 -- Invocation_Graph_Recording_OK --
12147 -----------------------------------
12149 function Invocation_Graph_Recording_OK return Boolean is
12150 Main_Cunit : constant Node_Id := Cunit (Main_Unit);
12153 -- Nothing to do when switch -gnatd_G (encode invocation graph in ALI
12154 -- files) is not in effect.
12156 if not Debug_Flag_Underscore_GG then
12159 -- Nothing to do when compiling for GNATprove because the invocation
12160 -- graph is not needed.
12162 elsif GNATprove_Mode then
12165 -- Nothing to do when the compilation will not produce an ALI file
12167 elsif Serious_Errors_Detected > 0 then
12170 -- Nothing to do when the main unit requires a body. Processing the
12171 -- completing body will create the ALI file for the unit and record
12172 -- the invocation graph.
12174 elsif Body_Required (Main_Cunit) then
12179 end Invocation_Graph_Recording_OK;
12181 ----------------------------
12182 -- Is_Invocation_Scenario --
12183 ----------------------------
12185 function Is_Invocation_Scenario (N : Node_Id) return Boolean is
12188 Is_Suitable_Access_Taken (N)
12189 or else Is_Suitable_Call (N)
12190 or else Is_Suitable_Instantiation (N);
12191 end Is_Invocation_Scenario;
12193 --------------------------
12194 -- Is_Invocation_Target --
12195 --------------------------
12197 function Is_Invocation_Target (Id : Entity_Id) return Boolean is
12199 -- To qualify, the entity must either come from source, or denote an
12200 -- Ada, bridge, or SPARK target.
12203 Comes_From_Source (Id)
12204 or else Is_Ada_Semantic_Target (Id)
12205 or else Is_Bridge_Target (Id)
12206 or else Is_SPARK_Semantic_Target (Id);
12207 end Is_Invocation_Target;
12209 ------------------------
12210 -- Is_Saved_Construct --
12211 ------------------------
12213 function Is_Saved_Construct (Constr : Entity_Id) return Boolean is
12214 pragma Assert (Present (Constr));
12216 return NE_Set.Contains (Saved_Constructs_Set, Constr);
12217 end Is_Saved_Construct;
12219 -----------------------
12220 -- Is_Saved_Relation --
12221 -----------------------
12223 function Is_Saved_Relation
12224 (Rel : Invoker_Target_Relation) return Boolean
12226 pragma Assert (Present (Rel.Invoker));
12227 pragma Assert (Present (Rel.Target));
12230 return IR_Set.Contains (Saved_Relations_Set, Rel);
12231 end Is_Saved_Relation;
12233 --------------------------
12234 -- Process_Declarations --
12235 --------------------------
12237 procedure Process_Declarations
12239 In_State : Processing_In_State)
12244 Decl := First (Decls);
12245 while Present (Decl) loop
12249 if Nkind (Decl) = N_Freeze_Entity then
12250 Process_Freeze_Node
12252 In_State => In_State);
12254 -- Package (nested)
12256 elsif Nkind (Decl) = N_Package_Declaration then
12257 Process_Package_Declaration
12258 (Pack_Decl => Decl,
12259 In_State => In_State);
12263 elsif Nkind_In (Decl, N_Protected_Type_Declaration,
12264 N_Single_Protected_Declaration)
12266 Process_Protected_Type_Declaration
12267 (Prot_Decl => Decl,
12268 In_State => In_State);
12270 -- Subprogram or entry
12272 elsif Nkind_In (Decl, N_Entry_Declaration,
12273 N_Subprogram_Declaration)
12275 Process_Subprogram_Declaration
12276 (Subp_Decl => Decl,
12277 In_State => In_State);
12279 -- Subprogram body (stand alone)
12281 elsif Nkind (Decl) = N_Subprogram_Body
12282 and then No (Corresponding_Spec (Decl))
12284 Process_Subprogram_Declaration
12285 (Subp_Decl => Decl,
12286 In_State => In_State);
12288 -- Subprogram instantiation
12290 elsif Nkind (Decl) in N_Subprogram_Instantiation then
12291 Process_Subprogram_Instantiation
12293 In_State => In_State);
12297 elsif Nkind_In (Decl, N_Single_Task_Declaration,
12298 N_Task_Type_Declaration)
12300 Process_Task_Type_Declaration
12301 (Task_Decl => Decl,
12302 In_State => In_State);
12304 -- Task type (derived)
12306 elsif Nkind (Decl) = N_Full_Type_Declaration
12307 and then Is_Task_Type (Defining_Entity (Decl))
12309 Process_Task_Type_Declaration
12310 (Task_Decl => Decl,
12311 In_State => In_State);
12316 end Process_Declarations;
12318 -------------------------
12319 -- Process_Freeze_Node --
12320 -------------------------
12322 procedure Process_Freeze_Node
12324 In_State : Processing_In_State)
12327 Process_Declarations
12328 (Decls => Actions (Fnode),
12329 In_State => In_State);
12330 end Process_Freeze_Node;
12332 -----------------------------------
12333 -- Process_Invocation_Activation --
12334 -----------------------------------
12336 procedure Process_Invocation_Activation
12338 Call_Rep : Scenario_Rep_Id;
12339 Obj_Id : Entity_Id;
12340 Obj_Rep : Target_Rep_Id;
12341 Task_Typ : Entity_Id;
12342 Task_Rep : Target_Rep_Id;
12343 In_State : Processing_In_State)
12345 pragma Unreferenced (Call);
12346 pragma Unreferenced (Call_Rep);
12347 pragma Unreferenced (Obj_Id);
12348 pragma Unreferenced (Obj_Rep);
12351 -- Nothing to do when the task type appears within an internal unit
12353 if In_Internal_Unit (Task_Typ) then
12357 -- The task type being activated is within the main unit. Extend the
12358 -- DFS traversal into its body.
12360 if In_Extended_Main_Code_Unit (Task_Typ) then
12361 Traverse_Invocation_Body
12362 (N => Body_Declaration (Task_Rep),
12363 In_State => In_State);
12365 -- The task type being activated resides within an external unit
12367 -- Main unit External unit
12368 -- +-----------+ +-------------+
12370 -- | Start ------------> Task_Typ |
12372 -- +-----------+ +-------------+
12374 -- Record the invocation path which originates from Start and reaches
12378 Record_Invocation_Path (In_State);
12380 end Process_Invocation_Activation;
12382 ---------------------------------------
12383 -- Process_Invocation_Body_Scenarios --
12384 ---------------------------------------
12386 procedure Process_Invocation_Body_Scenarios is
12387 Iter : NE_Set.Iterator := Iterate_Library_Body_Scenarios;
12389 Process_Invocation_Scenarios
12391 In_State => Invocation_Body_State);
12392 end Process_Invocation_Body_Scenarios;
12394 -----------------------------
12395 -- Process_Invocation_Call --
12396 -----------------------------
12398 procedure Process_Invocation_Call
12400 Call_Rep : Scenario_Rep_Id;
12401 In_State : Processing_In_State)
12403 pragma Unreferenced (Call);
12405 Subp_Id : constant Entity_Id := Target (Call_Rep);
12406 Subp_Rep : constant Target_Rep_Id :=
12407 Target_Representation_Of (Subp_Id, In_State);
12410 -- Nothing to do when the subprogram appears within an internal unit
12412 if In_Internal_Unit (Subp_Id) then
12415 -- Nothing to do for an abstract subprogram because it has no body to
12418 elsif Ekind_In (Subp_Id, E_Function, E_Procedure)
12419 and then Is_Abstract_Subprogram (Subp_Id)
12423 -- Nothin to do for a formal subprogram because it has no body to
12426 elsif Is_Formal_Subprogram (Subp_Id) then
12430 -- The subprogram being called is within the main unit. Extend the
12431 -- DFS traversal into its barrier function and body.
12433 if In_Extended_Main_Code_Unit (Subp_Id) then
12434 if Ekind_In (Subp_Id, E_Entry, E_Entry_Family, E_Procedure) then
12435 Traverse_Invocation_Body
12436 (N => Barrier_Body_Declaration (Subp_Rep),
12437 In_State => In_State);
12440 Traverse_Invocation_Body
12441 (N => Body_Declaration (Subp_Rep),
12442 In_State => In_State);
12444 -- The subprogram being called resides within an external unit
12446 -- Main unit External unit
12447 -- +-----------+ +-------------+
12449 -- | Start ------------> Subp_Id |
12451 -- +-----------+ +-------------+
12453 -- Record the invocation path which originates from Start and reaches
12457 Record_Invocation_Path (In_State);
12459 end Process_Invocation_Call;
12461 ---------------------------------
12462 -- Process_Invocation_Scenario --
12463 ---------------------------------
12465 procedure Process_Invocation_Scenario
12467 In_State : Processing_In_State)
12469 Scen : constant Node_Id := Scenario (N);
12470 Scen_Rep : Scenario_Rep_Id;
12473 -- Add the current scenario to the stack of active scenarios
12475 Push_Active_Scenario (Scen);
12477 -- Call or task activation
12479 if Is_Suitable_Call (Scen) then
12480 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
12482 -- Routine Build_Call_Marker creates call markers regardless of
12483 -- whether the call occurs within the main unit or not. This way
12484 -- the serialization of internal names is kept consistent. Only
12485 -- call markers found within the main unit must be processed.
12487 if In_Main_Context (Scen) then
12488 Scen_Rep := Scenario_Representation_Of (Scen, In_State);
12490 if Kind (Scen_Rep) = Call_Scenario then
12491 Process_Invocation_Call
12493 Call_Rep => Scen_Rep,
12494 In_State => In_State);
12497 pragma Assert (Kind (Scen_Rep) = Task_Activation_Scenario);
12501 Call_Rep => Scen_Rep,
12502 Processor => Process_Invocation_Activation'Access,
12503 In_State => In_State);
12508 -- Remove the current scenario from the stack of active scenarios
12509 -- once all invocation constructs and paths have been saved.
12511 Pop_Active_Scenario (Scen);
12512 end Process_Invocation_Scenario;
12514 ----------------------------------
12515 -- Process_Invocation_Scenarios --
12516 ----------------------------------
12518 procedure Process_Invocation_Scenarios
12519 (Iter : in out NE_Set.Iterator;
12520 In_State : Processing_In_State)
12525 while NE_Set.Has_Next (Iter) loop
12526 NE_Set.Next (Iter, N);
12528 -- Reset the traversed status of all subprogram bodies because the
12529 -- current invocation scenario acts as a new DFS traversal root.
12531 Reset_Traversed_Bodies;
12533 Process_Invocation_Scenario (N, In_State);
12535 end Process_Invocation_Scenarios;
12537 ---------------------------------------
12538 -- Process_Invocation_Spec_Scenarios --
12539 ---------------------------------------
12541 procedure Process_Invocation_Spec_Scenarios is
12542 Iter : NE_Set.Iterator := Iterate_Library_Spec_Scenarios;
12544 Process_Invocation_Scenarios
12546 In_State => Invocation_Spec_State);
12547 end Process_Invocation_Spec_Scenarios;
12549 -----------------------
12550 -- Process_Main_Unit --
12551 -----------------------
12553 procedure Process_Main_Unit is
12554 Unit_Decl : constant Node_Id := Unit (Cunit (Main_Unit));
12555 Spec_Id : Entity_Id;
12558 -- The main unit is a [generic] package body
12560 if Nkind (Unit_Decl) = N_Package_Body then
12561 Spec_Id := Corresponding_Spec (Unit_Decl);
12562 pragma Assert (Present (Spec_Id));
12564 Process_Package_Declaration
12565 (Pack_Decl => Unit_Declaration_Node (Spec_Id),
12566 In_State => Invocation_Construct_State);
12568 -- The main unit is a [generic] package declaration
12570 elsif Nkind (Unit_Decl) = N_Package_Declaration then
12571 Process_Package_Declaration
12572 (Pack_Decl => Unit_Decl,
12573 In_State => Invocation_Construct_State);
12575 -- The main unit is a [generic] subprogram body
12577 elsif Nkind (Unit_Decl) = N_Subprogram_Body then
12578 Spec_Id := Corresponding_Spec (Unit_Decl);
12580 -- The body completes a previous declaration
12582 if Present (Spec_Id) then
12583 Process_Subprogram_Declaration
12584 (Subp_Decl => Unit_Declaration_Node (Spec_Id),
12585 In_State => Invocation_Construct_State);
12587 -- Otherwise the body is stand-alone
12590 Process_Subprogram_Declaration
12591 (Subp_Decl => Unit_Decl,
12592 In_State => Invocation_Construct_State);
12595 -- The main unit is a subprogram instantiation
12597 elsif Nkind (Unit_Decl) in N_Subprogram_Instantiation then
12598 Process_Subprogram_Instantiation
12599 (Inst => Unit_Decl,
12600 In_State => Invocation_Construct_State);
12602 -- The main unit is an imported subprogram declaration
12604 elsif Nkind (Unit_Decl) = N_Subprogram_Declaration then
12605 Process_Subprogram_Declaration
12606 (Subp_Decl => Unit_Decl,
12607 In_State => Invocation_Construct_State);
12609 end Process_Main_Unit;
12611 ---------------------------------
12612 -- Process_Package_Declaration --
12613 ---------------------------------
12615 procedure Process_Package_Declaration
12616 (Pack_Decl : Node_Id;
12617 In_State : Processing_In_State)
12619 Body_Id : constant Entity_Id := Corresponding_Body (Pack_Decl);
12620 Spec : constant Node_Id := Specification (Pack_Decl);
12621 Spec_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
12624 -- Add a declaration for the generic package in the ALI of the main
12625 -- unit in case a client unit instantiates it.
12627 if Ekind (Spec_Id) = E_Generic_Package then
12628 Declare_Invocation_Construct
12629 (Constr_Id => Spec_Id,
12630 In_State => In_State);
12632 -- Otherwise inspect the visible and private declarations of the
12633 -- package for invocation constructs.
12636 Process_Declarations
12637 (Decls => Visible_Declarations (Spec),
12638 In_State => In_State);
12640 Process_Declarations
12641 (Decls => Private_Declarations (Spec),
12642 In_State => In_State);
12644 -- The package body containst at least one generic unit or an
12645 -- inlinable subprogram. Such constructs may grant clients of
12646 -- the main unit access to the private enclosing contexts of
12647 -- the constructs. Process the main unit body to discover and
12648 -- encode relevant invocation constructs and relations that
12649 -- may ultimately reach an external unit.
12651 if Present (Body_Id)
12652 and then Save_Invocation_Graph_Of_Body (Cunit (Main_Unit))
12654 Process_Declarations
12655 (Decls => Declarations (Unit_Declaration_Node (Body_Id)),
12656 In_State => In_State);
12659 end Process_Package_Declaration;
12661 ----------------------------------------
12662 -- Process_Protected_Type_Declaration --
12663 ----------------------------------------
12665 procedure Process_Protected_Type_Declaration
12666 (Prot_Decl : Node_Id;
12667 In_State : Processing_In_State)
12669 Prot_Def : constant Node_Id := Protected_Definition (Prot_Decl);
12672 if Present (Prot_Def) then
12673 Process_Declarations
12674 (Decls => Visible_Declarations (Prot_Def),
12675 In_State => In_State);
12677 end Process_Protected_Type_Declaration;
12679 ------------------------------------
12680 -- Process_Subprogram_Declaration --
12681 ------------------------------------
12683 procedure Process_Subprogram_Declaration
12684 (Subp_Decl : Node_Id;
12685 In_State : Processing_In_State)
12687 Subp_Id : constant Entity_Id := Defining_Entity (Subp_Decl);
12690 -- Nothing to do when the subprogram is not an invocation target
12692 if not Is_Invocation_Target (Subp_Id) then
12696 -- Add a declaration for the subprogram in the ALI file of the main
12697 -- unit in case a client unit calls or instantiates it.
12699 Declare_Invocation_Construct
12700 (Constr_Id => Subp_Id,
12701 In_State => In_State);
12703 -- Do not process subprograms without a body because they do not
12704 -- contain any invocation scenarios.
12706 if Is_Bodiless_Subprogram (Subp_Id) then
12709 -- Do not process generic subprograms because generics must not be
12712 elsif Is_Generic_Subprogram (Subp_Id) then
12715 -- Otherwise create a dummy scenario which calls the subprogram to
12716 -- act as a root for a DFS traversal.
12719 -- Reset the traversed status of all subprogram bodies because the
12720 -- subprogram acts as a new DFS traversal root.
12722 Reset_Traversed_Bodies;
12724 Process_Invocation_Scenario
12725 (N => Build_Subprogram_Invocation (Subp_Id),
12726 In_State => In_State);
12728 end Process_Subprogram_Declaration;
12730 --------------------------------------
12731 -- Process_Subprogram_Instantiation --
12732 --------------------------------------
12734 procedure Process_Subprogram_Instantiation
12736 In_State : Processing_In_State)
12739 -- Add a declaration for the instantiation in the ALI file of the
12740 -- main unit in case a client unit calls it.
12742 Declare_Invocation_Construct
12743 (Constr_Id => Defining_Entity (Inst),
12744 In_State => In_State);
12745 end Process_Subprogram_Instantiation;
12747 -----------------------------------
12748 -- Process_Task_Type_Declaration --
12749 -----------------------------------
12751 procedure Process_Task_Type_Declaration
12752 (Task_Decl : Node_Id;
12753 In_State : Processing_In_State)
12755 Task_Typ : constant Entity_Id := Defining_Entity (Task_Decl);
12756 Task_Def : Node_Id;
12759 -- Add a declaration for the task type the ALI file of the main unit
12760 -- in case a client unit creates a task object and activates it.
12762 Declare_Invocation_Construct
12763 (Constr_Id => Task_Typ,
12764 In_State => In_State);
12766 -- Process the entries of the task type because they represent valid
12767 -- entry points into the task body.
12769 if Nkind_In (Task_Decl, N_Single_Task_Declaration,
12770 N_Task_Type_Declaration)
12772 Task_Def := Task_Definition (Task_Decl);
12774 if Present (Task_Def) then
12775 Process_Declarations
12776 (Decls => Visible_Declarations (Task_Def),
12777 In_State => In_State);
12781 -- Reset the traversed status of all subprogram bodies because the
12782 -- task type acts as a new DFS traversal root.
12784 Reset_Traversed_Bodies;
12786 -- Create a dummy scenario which activates an anonymous object of the
12787 -- task type to acts as a root of a DFS traversal.
12789 Process_Invocation_Scenario
12790 (N => Build_Task_Activation (Task_Typ, In_State),
12791 In_State => In_State);
12792 end Process_Task_Type_Declaration;
12794 ---------------------------------
12795 -- Record_Full_Invocation_Path --
12796 ---------------------------------
12798 procedure Record_Full_Invocation_Path (In_State : Processing_In_State) is
12799 package Scenarios renames Active_Scenario_Stack;
12802 -- The path originates from the elaboration of the body. Add an extra
12803 -- relation from the elaboration body procedure to the first active
12806 if In_State.Processing = Invocation_Body_Processing then
12807 Build_Elaborate_Body_Procedure;
12809 Record_Invocation_Relation
12810 (Invk_Id => Elab_Body_Id,
12811 Targ_Id => Target_Of (Scenarios.First, In_State),
12812 In_State => In_State);
12814 -- The path originates from the elaboration of the spec. Add an extra
12815 -- relation from the elaboration spec procedure to the first active
12818 elsif In_State.Processing = Invocation_Spec_Processing then
12819 Build_Elaborate_Spec_Procedure;
12821 Record_Invocation_Relation
12822 (Invk_Id => Elab_Spec_Id,
12823 Targ_Id => Target_Of (Scenarios.First, In_State),
12824 In_State => In_State);
12827 -- Record individual relations formed by pairs of scenarios
12829 for Index in Scenarios.First .. Scenarios.Last - 1 loop
12830 Record_Invocation_Relation
12831 (Invk_Id => Target_Of (Index, In_State),
12832 Targ_Id => Target_Of (Index + 1, In_State),
12833 In_State => In_State);
12835 end Record_Full_Invocation_Path;
12837 -----------------------------
12838 -- Record_Invocation_Graph --
12839 -----------------------------
12841 procedure Record_Invocation_Graph is
12843 -- Nothing to do when the invocation graph is not recorded
12845 if not Invocation_Graph_Recording_OK then
12849 -- Save the encoding format used to capture information about the
12850 -- invocation constructs and relations in the ALI file of the main
12853 Record_Invocation_Graph_Encoding;
12855 -- Examine all library level invocation scenarios and perform DFS
12856 -- traversals from each one. Encode a path in the ALI file of the
12857 -- main unit if it reaches into an external unit.
12859 Process_Invocation_Body_Scenarios;
12860 Process_Invocation_Spec_Scenarios;
12862 -- Examine all invocation constructs within the spec and body of the
12863 -- main unit and perform DFS traversals from each one. Encode a path
12864 -- in the ALI file of the main unit if it reaches into an external
12868 end Record_Invocation_Graph;
12870 --------------------------------------
12871 -- Record_Invocation_Graph_Encoding --
12872 --------------------------------------
12874 procedure Record_Invocation_Graph_Encoding is
12875 Kind : Invocation_Graph_Encoding_Kind := No_Encoding;
12878 -- Switch -gnatd_F (encode full invocation paths in ALI files) is in
12881 if Debug_Flag_Underscore_FF then
12882 Kind := Full_Path_Encoding;
12884 Kind := Endpoints_Encoding;
12887 -- Save the encoding format in the ALI file of the main unit
12889 Set_Invocation_Graph_Encoding
12891 Update_Units => False);
12892 end Record_Invocation_Graph_Encoding;
12894 ----------------------------
12895 -- Record_Invocation_Path --
12896 ----------------------------
12898 procedure Record_Invocation_Path (In_State : Processing_In_State) is
12899 package Scenarios renames Active_Scenario_Stack;
12902 -- Save a path when the active scenario stack contains at least one
12903 -- invocation scenario.
12905 if Scenarios.Last - Scenarios.First < 0 then
12909 -- Register all relations in the path when switch -gnatd_F (encode
12910 -- full invocation paths in ALI files) is in effect.
12912 if Debug_Flag_Underscore_FF then
12913 Record_Full_Invocation_Path (In_State);
12915 -- Otherwise register a single relation
12918 Record_Simple_Invocation_Path (In_State);
12921 Write_Invocation_Path (In_State);
12922 end Record_Invocation_Path;
12924 --------------------------------
12925 -- Record_Invocation_Relation --
12926 --------------------------------
12928 procedure Record_Invocation_Relation
12929 (Invk_Id : Entity_Id;
12930 Targ_Id : Entity_Id;
12931 In_State : Processing_In_State)
12933 pragma Assert (Present (Invk_Id));
12934 pragma Assert (Present (Targ_Id));
12936 procedure Get_Invocation_Attributes
12937 (Extra : out Entity_Id;
12938 Kind : out Invocation_Kind);
12939 pragma Inline (Get_Invocation_Attributes);
12940 -- Return the additional entity used in error diagnostics in Extra
12941 -- and the invocation kind in Kind which pertain to the invocation
12942 -- relation with invoker Invk_Id and target Targ_Id.
12944 -------------------------------
12945 -- Get_Invocation_Attributes --
12946 -------------------------------
12948 procedure Get_Invocation_Attributes
12949 (Extra : out Entity_Id;
12950 Kind : out Invocation_Kind)
12952 Targ_Rep : constant Target_Rep_Id :=
12953 Target_Representation_Of (Targ_Id, In_State);
12954 Spec_Decl : constant Node_Id := Spec_Declaration (Targ_Rep);
12957 -- Accept within a task body
12959 if Is_Accept_Alternative_Proc (Targ_Id) then
12960 Extra := Receiving_Entry (Targ_Id);
12961 Kind := Accept_Alternative;
12963 -- Activation of a task object
12965 elsif Is_Activation_Proc (Targ_Id)
12966 or else Is_Task_Type (Targ_Id)
12969 Kind := Task_Activation;
12971 -- Controlled adjustment actions
12973 elsif Is_Controlled_Proc (Targ_Id, Name_Adjust) then
12974 Extra := First_Formal_Type (Targ_Id);
12975 Kind := Controlled_Adjustment;
12977 -- Controlled finalization actions
12979 elsif Is_Controlled_Proc (Targ_Id, Name_Finalize)
12980 or else Is_Finalizer_Proc (Targ_Id)
12982 Extra := First_Formal_Type (Targ_Id);
12983 Kind := Controlled_Finalization;
12985 -- Controlled initialization actions
12987 elsif Is_Controlled_Proc (Targ_Id, Name_Initialize) then
12988 Extra := First_Formal_Type (Targ_Id);
12989 Kind := Controlled_Initialization;
12991 -- Default_Initial_Condition verification
12993 elsif Is_Default_Initial_Condition_Proc (Targ_Id) then
12994 Extra := First_Formal_Type (Targ_Id);
12995 Kind := Default_Initial_Condition_Verification;
12997 -- Initialization of object
12999 elsif Is_Init_Proc (Targ_Id) then
13000 Extra := First_Formal_Type (Targ_Id);
13001 Kind := Type_Initialization;
13003 -- Initial_Condition verification
13005 elsif Is_Initial_Condition_Proc (Targ_Id) then
13006 Extra := First_Formal_Type (Targ_Id);
13007 Kind := Initial_Condition_Verification;
13011 elsif Is_Generic_Unit (Targ_Id) then
13013 Kind := Instantiation;
13015 -- Internal controlled adjustment actions
13017 elsif Is_TSS (Targ_Id, TSS_Deep_Adjust) then
13018 Extra := First_Formal_Type (Targ_Id);
13019 Kind := Internal_Controlled_Adjustment;
13021 -- Internal controlled finalization actions
13023 elsif Is_TSS (Targ_Id, TSS_Deep_Finalize) then
13024 Extra := First_Formal_Type (Targ_Id);
13025 Kind := Internal_Controlled_Finalization;
13027 -- Internal controlled initialization actions
13029 elsif Is_TSS (Targ_Id, TSS_Deep_Initialize) then
13030 Extra := First_Formal_Type (Targ_Id);
13031 Kind := Internal_Controlled_Initialization;
13033 -- Invariant verification
13035 elsif Is_Invariant_Proc (Targ_Id)
13036 or else Is_Partial_Invariant_Proc (Targ_Id)
13038 Extra := First_Formal_Type (Targ_Id);
13039 Kind := Invariant_Verification;
13041 -- Postcondition verification
13043 elsif Is_Postconditions_Proc (Targ_Id) then
13044 Extra := Find_Enclosing_Scope (Spec_Decl);
13045 Kind := Postcondition_Verification;
13047 -- Protected entry call
13049 elsif Is_Protected_Entry (Targ_Id) then
13051 Kind := Protected_Entry_Call;
13053 -- Protected subprogram call
13055 elsif Is_Protected_Subp (Targ_Id) then
13057 Kind := Protected_Subprogram_Call;
13061 elsif Is_Task_Entry (Targ_Id) then
13063 Kind := Task_Entry_Call;
13065 -- Entry, operator, or subprogram call. This case must come last
13066 -- because most invocations above are variations of this case.
13068 elsif Ekind_In (Targ_Id, E_Entry,
13077 pragma Assert (False);
13079 Kind := No_Invocation;
13081 end Get_Invocation_Attributes;
13086 Extra_Nam : Name_Id;
13087 Kind : Invocation_Kind;
13088 Rel : Invoker_Target_Relation;
13090 -- Start of processing for Record_Invocation_Relation
13093 Rel.Invoker := Invk_Id;
13094 Rel.Target := Targ_Id;
13096 -- Nothing to do when the invocation relation has already been
13097 -- recorded in ALI file of the main unit.
13099 if Is_Saved_Relation (Rel) then
13103 -- Mark the relation as recorded in the ALI file
13105 Set_Is_Saved_Relation (Rel);
13107 -- Declare the invoker in the ALI file
13109 Declare_Invocation_Construct
13110 (Constr_Id => Invk_Id,
13111 In_State => In_State);
13113 -- Obtain the invocation-specific attributes of the relation
13115 Get_Invocation_Attributes (Extra, Kind);
13117 -- Certain invocations lack an extra entity used in error diagnostics
13119 if Present (Extra) then
13120 Extra_Nam := Chars (Extra);
13122 Extra_Nam := No_Name;
13125 -- Add the relation in the ALI file
13127 Add_Invocation_Relation
13128 (Extra => Extra_Nam,
13129 Invoker => Signature_Of (Invk_Id),
13131 Target => Signature_Of (Targ_Id),
13132 Update_Units => False);
13133 end Record_Invocation_Relation;
13135 -----------------------------------
13136 -- Record_Simple_Invocation_Path --
13137 -----------------------------------
13139 procedure Record_Simple_Invocation_Path
13140 (In_State : Processing_In_State)
13142 package Scenarios renames Active_Scenario_Stack;
13144 Last_Targ : constant Entity_Id :=
13145 Target_Of (Scenarios.Last, In_State);
13146 First_Targ : Entity_Id;
13149 -- The path originates from the elaboration of the body. Add an extra
13150 -- relation from the elaboration body procedure to the first active
13153 if In_State.Processing = Invocation_Body_Processing then
13154 Build_Elaborate_Body_Procedure;
13155 First_Targ := Elab_Body_Id;
13157 -- The path originates from the elaboration of the spec. Add an extra
13158 -- relation from the elaboration spec procedure to the first active
13161 elsif In_State.Processing = Invocation_Spec_Processing then
13162 Build_Elaborate_Spec_Procedure;
13163 First_Targ := Elab_Spec_Id;
13166 First_Targ := Target_Of (Scenarios.First, In_State);
13169 -- Record a single relation from the first to the last scenario
13171 if First_Targ /= Last_Targ then
13172 Record_Invocation_Relation
13173 (Invk_Id => First_Targ,
13174 Targ_Id => Last_Targ,
13175 In_State => In_State);
13177 end Record_Simple_Invocation_Path;
13179 ----------------------------
13180 -- Set_Is_Saved_Construct --
13181 ----------------------------
13183 procedure Set_Is_Saved_Construct
13184 (Constr : Entity_Id;
13185 Val : Boolean := True)
13187 pragma Assert (Present (Constr));
13191 NE_Set.Insert (Saved_Constructs_Set, Constr);
13193 NE_Set.Delete (Saved_Constructs_Set, Constr);
13195 end Set_Is_Saved_Construct;
13197 ---------------------------
13198 -- Set_Is_Saved_Relation --
13199 ---------------------------
13201 procedure Set_Is_Saved_Relation
13202 (Rel : Invoker_Target_Relation;
13203 Val : Boolean := True)
13207 IR_Set.Insert (Saved_Relations_Set, Rel);
13209 IR_Set.Delete (Saved_Relations_Set, Rel);
13211 end Set_Is_Saved_Relation;
13217 function Signature_Of (Id : Entity_Id) return Invocation_Signature_Id is
13218 Loc : constant Source_Ptr := Sloc (Id);
13220 function Instantiation_Locations return Name_Id;
13221 pragma Inline (Instantiation_Locations);
13222 -- Create a concatenation of all lines and colums of each instance
13223 -- where source location Loc appears. Return No_Name if no instances
13226 function Qualified_Scope return Name_Id;
13227 pragma Inline (Qualified_Scope);
13228 -- Obtain the qualified name of Id's scope
13230 -----------------------------
13231 -- Instantiation_Locations --
13232 -----------------------------
13234 function Instantiation_Locations return Name_Id is
13235 Buffer : Bounded_String (2052);
13238 SFI : Source_File_Index;
13241 SFI := Get_Source_File_Index (Loc);
13242 Inst := Instantiation (SFI);
13244 -- The location is within an instance. Construct a concatenation
13245 -- of all lines and colums of each individual instance using the
13246 -- following format:
13248 -- line1_column1_line2_column2_ ... _lineN_columnN
13250 if Inst /= No_Location then
13252 Append (Buffer, Nat (Get_Logical_Line_Number (Inst)));
13253 Append (Buffer, '_');
13254 Append (Buffer, Nat (Get_Column_Number (Inst)));
13256 SFI := Get_Source_File_Index (Inst);
13257 Inst := Instantiation (SFI);
13259 exit when Inst = No_Location;
13261 Append (Buffer, '_');
13264 Loc_Nam := Name_Find (Buffer);
13267 -- Otherwise there no instances are involved
13272 end Instantiation_Locations;
13274 ---------------------
13275 -- Qualified_Scope --
13276 ---------------------
13278 function Qualified_Scope return Name_Id is
13282 Scop := Scope (Id);
13284 -- The entity appears within an anonymous concurrent type created
13285 -- for a single protected or task type declaration. Use the entity
13286 -- of the anonymous object as it represents the original scope.
13288 if Is_Concurrent_Type (Scop)
13289 and then Present (Anonymous_Object (Scop))
13291 Scop := Anonymous_Object (Scop);
13294 return Get_Qualified_Name (Scop);
13295 end Qualified_Scope;
13297 -- Start of processing for Signature_Of
13301 Invocation_Signature_Of
13302 (Column => Nat (Get_Column_Number (Loc)),
13303 Line => Nat (Get_Logical_Line_Number (Loc)),
13304 Locations => Instantiation_Locations,
13305 Name => Chars (Id),
13306 Scope => Qualified_Scope);
13314 (Pos : Active_Scenario_Pos;
13315 In_State : Processing_In_State) return Entity_Id
13317 package Scenarios renames Active_Scenario_Stack;
13319 -- Ensure that the position is within the bounds of the active
13322 pragma Assert (Scenarios.First <= Pos);
13323 pragma Assert (Pos <= Scenarios.Last);
13325 Scen_Rep : constant Scenario_Rep_Id :=
13326 Scenario_Representation_Of
13327 (Scenarios.Table (Pos), In_State);
13330 -- The true target of an activation call is the current task type
13331 -- rather than routine Activate_Tasks.
13333 if Kind (Scen_Rep) = Task_Activation_Scenario then
13334 return Activated_Task_Type (Scen_Rep);
13336 return Target (Scen_Rep);
13340 ------------------------------
13341 -- Traverse_Invocation_Body --
13342 ------------------------------
13344 procedure Traverse_Invocation_Body
13346 In_State : Processing_In_State)
13351 Requires_Processing => Is_Invocation_Scenario'Access,
13352 Processor => Process_Invocation_Scenario'Access,
13353 In_State => In_State);
13354 end Traverse_Invocation_Body;
13356 ---------------------------
13357 -- Write_Invocation_Path --
13358 ---------------------------
13360 procedure Write_Invocation_Path (In_State : Processing_In_State) is
13361 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean);
13362 pragma Inline (Write_Target);
13363 -- Write out invocation target Targ_Id to standard output. Flag
13364 -- Is_First should be set when the target is first in a path.
13370 procedure Write_Target (Targ_Id : Entity_Id; Is_First : Boolean) is
13372 if not Is_First then
13373 Write_Str (" --> ");
13376 Write_Name (Get_Qualified_Name (Targ_Id));
13382 package Scenarios renames Active_Scenario_Stack;
13384 First_Seen : Boolean := False;
13386 -- Start of processing for Write_Invocation_Path
13389 -- Nothing to do when flag -gnatd_T (output trace information on
13390 -- invocation path recording) is not in effect.
13392 if not Debug_Flag_Underscore_TT then
13396 -- The path originates from the elaboration of the body. Write the
13397 -- elaboration body procedure.
13399 if In_State.Processing = Invocation_Body_Processing then
13400 Write_Target (Elab_Body_Id, True);
13401 First_Seen := True;
13403 -- The path originates from the elaboration of the spec. Write the
13404 -- elaboration spec procedure.
13406 elsif In_State.Processing = Invocation_Spec_Processing then
13407 Write_Target (Elab_Spec_Id, True);
13408 First_Seen := True;
13411 -- Write each individual target invoked by its corresponding scenario
13412 -- on the active scenario stack.
13414 for Index in Scenarios.First .. Scenarios.Last loop
13416 (Targ_Id => Target_Of (Index, In_State),
13417 Is_First => Index = Scenarios.First and then not First_Seen);
13421 end Write_Invocation_Path;
13422 end Invocation_Graph;
13424 ------------------------
13425 -- Is_Safe_Activation --
13426 ------------------------
13428 function Is_Safe_Activation
13430 Task_Rep : Target_Rep_Id) return Boolean
13433 -- The activation of a task coming from an external instance cannot
13434 -- cause an ABE because the generic was already instantiated. Note
13435 -- that the instantiation itself may lead to an ABE.
13438 In_External_Instance
13440 Target_Decl => Spec_Declaration (Task_Rep));
13441 end Is_Safe_Activation;
13447 function Is_Safe_Call
13449 Subp_Id : Entity_Id;
13450 Subp_Rep : Target_Rep_Id) return Boolean
13452 Body_Decl : constant Node_Id := Body_Declaration (Subp_Rep);
13453 Spec_Decl : constant Node_Id := Spec_Declaration (Subp_Rep);
13456 -- The target is either an abstract subprogram, formal subprogram, or
13457 -- imported, in which case it does not have a body at compile or bind
13458 -- time. Assume that the call is ABE-safe.
13460 if Is_Bodiless_Subprogram (Subp_Id) then
13463 -- The target is an instantiation of a generic subprogram. The call
13464 -- cannot cause an ABE because the generic was already instantiated.
13465 -- Note that the instantiation itself may lead to an ABE.
13467 elsif Is_Generic_Instance (Subp_Id) then
13470 -- The invocation of a target coming from an external instance cannot
13471 -- cause an ABE because the generic was already instantiated. Note that
13472 -- the instantiation itself may lead to an ABE.
13474 elsif In_External_Instance
13476 Target_Decl => Spec_Decl)
13480 -- The target is a subprogram body without a previous declaration. The
13481 -- call cannot cause an ABE because the body has already been seen.
13483 elsif Nkind (Spec_Decl) = N_Subprogram_Body
13484 and then No (Corresponding_Spec (Spec_Decl))
13488 -- The target is a subprogram body stub without a prior declaration.
13489 -- The call cannot cause an ABE because the proper body substitutes
13492 elsif Nkind (Spec_Decl) = N_Subprogram_Body_Stub
13493 and then No (Corresponding_Spec_Of_Stub (Spec_Decl))
13497 -- Subprogram bodies which wrap attribute references used as actuals
13498 -- in instantiations are always ABE-safe. These bodies are artifacts
13501 elsif Present (Body_Decl)
13502 and then Nkind (Body_Decl) = N_Subprogram_Body
13503 and then Was_Attribute_Reference (Body_Decl)
13511 ---------------------------
13512 -- Is_Safe_Instantiation --
13513 ---------------------------
13515 function Is_Safe_Instantiation
13517 Gen_Id : Entity_Id;
13518 Gen_Rep : Target_Rep_Id) return Boolean
13520 Spec_Decl : constant Node_Id := Spec_Declaration (Gen_Rep);
13523 -- The generic is an intrinsic subprogram in which case it does not
13524 -- have a body at compile or bind time. Assume that the instantiation
13527 if Is_Bodiless_Subprogram (Gen_Id) then
13530 -- The instantiation of an external nested generic cannot cause an ABE
13531 -- if the outer generic was already instantiated. Note that the instance
13532 -- of the outer generic may lead to an ABE.
13534 elsif In_External_Instance
13536 Target_Decl => Spec_Decl)
13540 -- The generic is a package. The instantiation cannot cause an ABE when
13541 -- the package has no body.
13543 elsif Ekind (Gen_Id) = E_Generic_Package
13544 and then not Has_Body (Spec_Decl)
13550 end Is_Safe_Instantiation;
13556 function Is_Same_Unit
13557 (Unit_1 : Entity_Id;
13558 Unit_2 : Entity_Id) return Boolean
13561 return Unit_Entity (Unit_1) = Unit_Entity (Unit_2);
13564 -------------------------------
13565 -- Kill_Elaboration_Scenario --
13566 -------------------------------
13568 procedure Kill_Elaboration_Scenario (N : Node_Id) is
13570 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
13571 -- enabled) is in effect because the legacy ABE lechanism does not need
13572 -- to carry out this action.
13574 if Legacy_Elaboration_Checks then
13577 -- Nothing to do when the elaboration phase of the compiler is not
13580 elsif not Elaboration_Phase_Active then
13584 -- Eliminate a recorded scenario when it appears within dead code
13585 -- because it will not be executed at elaboration time.
13587 if Is_Scenario (N) then
13588 Delete_Scenario (N);
13590 end Kill_Elaboration_Scenario;
13592 ----------------------
13593 -- Non_Private_View --
13594 ----------------------
13596 function Non_Private_View (Typ : Entity_Id) return Entity_Id is
13598 if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
13599 return Full_View (Typ);
13603 end Non_Private_View;
13605 ---------------------------------
13606 -- Record_Elaboration_Scenario --
13607 ---------------------------------
13609 procedure Record_Elaboration_Scenario (N : Node_Id) is
13610 procedure Check_Preelaborated_Call
13612 Call_Lvl : Enclosing_Level_Kind);
13613 pragma Inline (Check_Preelaborated_Call);
13614 -- Verify that entry, operator, or subprogram call Call with enclosing
13615 -- level Call_Lvl does not appear at the library level of preelaborated
13618 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id;
13619 pragma Inline (Find_Code_Unit);
13620 -- Return the code unit which contains arbitrary node or entity Nod.
13621 -- This is the unit of the file which physically contains the related
13622 -- construct denoted by Nod except when Nod is within an instantiation.
13623 -- In that case the unit is that of the top-level instantiation.
13625 function In_Preelaborated_Context (Nod : Node_Id) return Boolean;
13626 pragma Inline (In_Preelaborated_Context);
13627 -- Determine whether arbitrary node Nod appears within a preelaborated
13630 procedure Record_Access_Taken
13632 Attr_Lvl : Enclosing_Level_Kind);
13633 pragma Inline (Record_Access_Taken);
13634 -- Record 'Access scenario Attr with enclosing level Attr_Lvl
13636 procedure Record_Call_Or_Task_Activation
13638 Call_Lvl : Enclosing_Level_Kind);
13639 pragma Inline (Record_Call_Or_Task_Activation);
13640 -- Record call scenario Call with enclosing level Call_Lvl
13642 procedure Record_Instantiation
13644 Inst_Lvl : Enclosing_Level_Kind);
13645 pragma Inline (Record_Instantiation);
13646 -- Record instantiation scenario Inst with enclosing level Inst_Lvl
13648 procedure Record_Variable_Assignment
13650 Asmt_Lvl : Enclosing_Level_Kind);
13651 pragma Inline (Record_Variable_Assignment);
13652 -- Record variable assignment scenario Asmt with enclosing level
13655 procedure Record_Variable_Reference
13657 Ref_Lvl : Enclosing_Level_Kind);
13658 pragma Inline (Record_Variable_Reference);
13659 -- Record variable reference scenario Ref with enclosing level Ref_Lvl
13661 ------------------------------
13662 -- Check_Preelaborated_Call --
13663 ------------------------------
13665 procedure Check_Preelaborated_Call
13667 Call_Lvl : Enclosing_Level_Kind)
13670 -- Nothing to do when the call is internally generated because it is
13671 -- assumed that it will never violate preelaboration.
13673 if not Is_Source_Call (Call) then
13676 -- Library-level calls are always considered because they are part of
13677 -- the associated unit's elaboration actions.
13679 elsif Call_Lvl in Library_Level then
13682 -- Calls at the library level of a generic package body have to be
13683 -- checked because they would render an instantiation illegal if the
13684 -- template is marked as preelaborated. Note that this does not apply
13685 -- to calls at the library level of a generic package spec.
13687 elsif Call_Lvl = Generic_Body_Level then
13690 -- Otherwise the call does not appear at the proper level and must
13691 -- not be considered for this check.
13697 -- The call appears within a preelaborated unit. Emit a warning only
13698 -- for internal uses, otherwise this is an error.
13700 if In_Preelaborated_Context (Call) then
13701 Error_Msg_Warn := GNAT_Mode;
13703 ("<<non-static call not allowed in preelaborated unit", Call);
13705 end Check_Preelaborated_Call;
13707 --------------------
13708 -- Find_Code_Unit --
13709 --------------------
13711 function Find_Code_Unit (Nod : Node_Or_Entity_Id) return Entity_Id is
13713 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (Nod))));
13714 end Find_Code_Unit;
13716 ------------------------------
13717 -- In_Preelaborated_Context --
13718 ------------------------------
13720 function In_Preelaborated_Context (Nod : Node_Id) return Boolean is
13721 Body_Id : constant Entity_Id := Find_Code_Unit (Nod);
13722 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id);
13725 -- The node appears within a package body whose corresponding spec is
13726 -- subject to pragma Remote_Call_Interface or Remote_Types. This does
13727 -- not result in a preelaborated context because the package body may
13728 -- be on another machine.
13730 if Ekind (Body_Id) = E_Package_Body
13731 and then Ekind_In (Spec_Id, E_Generic_Package, E_Package)
13732 and then (Is_Remote_Call_Interface (Spec_Id)
13733 or else Is_Remote_Types (Spec_Id))
13737 -- Otherwise the node appears within a preelaborated context when the
13738 -- associated unit is preelaborated.
13741 return Is_Preelaborated_Unit (Spec_Id);
13743 end In_Preelaborated_Context;
13745 -------------------------
13746 -- Record_Access_Taken --
13747 -------------------------
13749 procedure Record_Access_Taken
13751 Attr_Lvl : Enclosing_Level_Kind)
13754 -- Signal any enclosing local exception handlers that the 'Access may
13755 -- raise Program_Error due to a failed ABE check when switch -gnatd.o
13756 -- (conservative elaboration order for indirect calls) is in effect.
13757 -- Marking the exception handlers ensures proper expansion by both
13758 -- the front and back end restriction when No_Exception_Propagation
13761 if Debug_Flag_Dot_O then
13762 Possible_Local_Raise (Attr, Standard_Program_Error);
13765 -- Add 'Access to the appropriate set
13767 if Attr_Lvl = Library_Body_Level then
13768 Add_Library_Body_Scenario (Attr);
13770 elsif Attr_Lvl = Library_Spec_Level
13771 or else Attr_Lvl = Instantiation_Level
13773 Add_Library_Spec_Scenario (Attr);
13776 -- 'Access requires a conditional ABE check when the dynamic model is
13779 Add_Dynamic_ABE_Check_Scenario (Attr);
13780 end Record_Access_Taken;
13782 ------------------------------------
13783 -- Record_Call_Or_Task_Activation --
13784 ------------------------------------
13786 procedure Record_Call_Or_Task_Activation
13788 Call_Lvl : Enclosing_Level_Kind)
13791 -- Signal any enclosing local exception handlers that the call may
13792 -- raise Program_Error due to failed ABE check. Marking the exception
13793 -- handlers ensures proper expansion by both the front and back end
13794 -- restriction when No_Exception_Propagation is in effect.
13796 Possible_Local_Raise (Call, Standard_Program_Error);
13798 -- Perform early detection of guaranteed ABEs in order to suppress
13799 -- the instantiation of generic bodies because gigi cannot handle
13800 -- certain types of premature instantiations.
13802 Process_Guaranteed_ABE
13804 In_State => Guaranteed_ABE_State);
13806 -- Add the call or task activation to the appropriate set
13808 if Call_Lvl = Declaration_Level then
13809 Add_Declaration_Scenario (Call);
13811 elsif Call_Lvl = Library_Body_Level then
13812 Add_Library_Body_Scenario (Call);
13814 elsif Call_Lvl = Library_Spec_Level
13815 or else Call_Lvl = Instantiation_Level
13817 Add_Library_Spec_Scenario (Call);
13820 -- A call or a task activation requires a conditional ABE check when
13821 -- the dynamic model is in effect.
13823 Add_Dynamic_ABE_Check_Scenario (Call);
13824 end Record_Call_Or_Task_Activation;
13826 --------------------------
13827 -- Record_Instantiation --
13828 --------------------------
13830 procedure Record_Instantiation
13832 Inst_Lvl : Enclosing_Level_Kind)
13835 -- Signal enclosing local exception handlers that instantiation may
13836 -- raise Program_Error due to failed ABE check. Marking the exception
13837 -- handlers ensures proper expansion by both the front and back end
13838 -- restriction when No_Exception_Propagation is in effect.
13840 Possible_Local_Raise (Inst, Standard_Program_Error);
13842 -- Perform early detection of guaranteed ABEs in order to suppress
13843 -- the instantiation of generic bodies because gigi cannot handle
13844 -- certain types of premature instantiations.
13846 Process_Guaranteed_ABE
13848 In_State => Guaranteed_ABE_State);
13850 -- Add the instantiation to the appropriate set
13852 if Inst_Lvl = Declaration_Level then
13853 Add_Declaration_Scenario (Inst);
13855 elsif Inst_Lvl = Library_Body_Level then
13856 Add_Library_Body_Scenario (Inst);
13858 elsif Inst_Lvl = Library_Spec_Level
13859 or else Inst_Lvl = Instantiation_Level
13861 Add_Library_Spec_Scenario (Inst);
13864 -- Instantiations of generics subject to SPARK_Mode On require
13865 -- elaboration-related checks even though the instantiations may
13866 -- not appear within elaboration code.
13868 if Is_Suitable_SPARK_Instantiation (Inst) then
13869 Add_SPARK_Scenario (Inst);
13872 -- An instantiation requires a conditional ABE check when the dynamic
13873 -- model is in effect.
13875 Add_Dynamic_ABE_Check_Scenario (Inst);
13876 end Record_Instantiation;
13878 --------------------------------
13879 -- Record_Variable_Assignment --
13880 --------------------------------
13882 procedure Record_Variable_Assignment
13884 Asmt_Lvl : Enclosing_Level_Kind)
13887 -- Add the variable assignment to the appropriate set
13889 if Asmt_Lvl = Library_Body_Level then
13890 Add_Library_Body_Scenario (Asmt);
13892 elsif Asmt_Lvl = Library_Spec_Level
13893 or else Asmt_Lvl = Instantiation_Level
13895 Add_Library_Spec_Scenario (Asmt);
13897 end Record_Variable_Assignment;
13899 -------------------------------
13900 -- Record_Variable_Reference --
13901 -------------------------------
13903 procedure Record_Variable_Reference
13905 Ref_Lvl : Enclosing_Level_Kind)
13908 -- Add the variable reference to the appropriate set
13910 if Ref_Lvl = Library_Body_Level then
13911 Add_Library_Body_Scenario (Ref);
13913 elsif Ref_Lvl = Library_Spec_Level
13914 or else Ref_Lvl = Instantiation_Level
13916 Add_Library_Spec_Scenario (Ref);
13918 end Record_Variable_Reference;
13922 Scen : constant Node_Id := Scenario (N);
13923 Scen_Lvl : Enclosing_Level_Kind;
13925 -- Start of processing for Record_Elaboration_Scenario
13928 -- Nothing to do when switch -gnatH (legacy elaboration checking mode
13929 -- enabled) is in effect because the legacy ABE mechanism does not need
13930 -- to carry out this action.
13932 if Legacy_Elaboration_Checks then
13935 -- Nothing to do for ASIS because ABE checks and diagnostics are not
13936 -- performed in this mode.
13938 elsif ASIS_Mode then
13941 -- Nothing to do when the scenario is being preanalyzed
13943 elsif Preanalysis_Active then
13946 -- Nothing to do when the elaboration phase of the compiler is not
13949 elsif not Elaboration_Phase_Active then
13953 Scen_Lvl := Find_Enclosing_Level (Scen);
13955 -- Ensure that a library-level call does not appear in a preelaborated
13956 -- unit. The check must come before ignoring scenarios within external
13957 -- units or inside generics because calls in those context must also be
13960 if Is_Suitable_Call (Scen) then
13961 Check_Preelaborated_Call (Scen, Scen_Lvl);
13964 -- Nothing to do when the scenario does not appear within the main unit
13966 if not In_Main_Context (Scen) then
13969 -- Nothing to do when the scenario appears within a generic
13971 elsif Inside_A_Generic then
13976 elsif Is_Suitable_Access_Taken (Scen) then
13977 Record_Access_Taken
13979 Attr_Lvl => Scen_Lvl);
13981 -- Call or task activation
13983 elsif Is_Suitable_Call (Scen) then
13984 Record_Call_Or_Task_Activation
13986 Call_Lvl => Scen_Lvl);
13988 -- Derived type declaration
13990 elsif Is_Suitable_SPARK_Derived_Type (Scen) then
13991 Add_SPARK_Scenario (Scen);
13995 elsif Is_Suitable_Instantiation (Scen) then
13996 Record_Instantiation
13998 Inst_Lvl => Scen_Lvl);
14000 -- Refined_State pragma
14002 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then
14003 Add_SPARK_Scenario (Scen);
14005 -- Variable assignment
14007 elsif Is_Suitable_Variable_Assignment (Scen) then
14008 Record_Variable_Assignment
14010 Asmt_Lvl => Scen_Lvl);
14012 -- Variable reference
14014 elsif Is_Suitable_Variable_Reference (Scen) then
14015 Record_Variable_Reference
14017 Ref_Lvl => Scen_Lvl);
14019 end Record_Elaboration_Scenario;
14025 function Scenario (N : Node_Id) return Node_Id is
14026 Orig_N : constant Node_Id := Original_Node (N);
14029 -- An expanded instantiation is rewritten into a spec-body pair where
14030 -- N denotes the spec. In this case the original instantiation is the
14031 -- proper elaboration scenario.
14033 if Nkind (Orig_N) in N_Generic_Instantiation then
14036 -- Otherwise the scenario is already in its proper form
14043 ----------------------
14044 -- Scenario_Storage --
14045 ----------------------
14047 package body Scenario_Storage is
14049 ---------------------
14050 -- Data structures --
14051 ---------------------
14053 -- The following sets store all scenarios
14055 Declaration_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14056 Dynamic_ABE_Check_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14057 Library_Body_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14058 Library_Spec_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14059 SPARK_Scenarios : NE_Set.Membership_Set := NE_Set.Nil;
14061 -------------------------------
14062 -- Finalize_Scenario_Storage --
14063 -------------------------------
14065 procedure Finalize_Scenario_Storage is
14067 NE_Set.Destroy (Declaration_Scenarios);
14068 NE_Set.Destroy (Dynamic_ABE_Check_Scenarios);
14069 NE_Set.Destroy (Library_Body_Scenarios);
14070 NE_Set.Destroy (Library_Spec_Scenarios);
14071 NE_Set.Destroy (SPARK_Scenarios);
14072 end Finalize_Scenario_Storage;
14074 ---------------------------------
14075 -- Initialize_Scenario_Storage --
14076 ---------------------------------
14078 procedure Initialize_Scenario_Storage is
14080 Declaration_Scenarios := NE_Set.Create (1000);
14081 Dynamic_ABE_Check_Scenarios := NE_Set.Create (500);
14082 Library_Body_Scenarios := NE_Set.Create (1000);
14083 Library_Spec_Scenarios := NE_Set.Create (1000);
14084 SPARK_Scenarios := NE_Set.Create (100);
14085 end Initialize_Scenario_Storage;
14087 ------------------------------
14088 -- Add_Declaration_Scenario --
14089 ------------------------------
14091 procedure Add_Declaration_Scenario (N : Node_Id) is
14092 pragma Assert (Present (N));
14094 NE_Set.Insert (Declaration_Scenarios, N);
14095 end Add_Declaration_Scenario;
14097 ------------------------------------
14098 -- Add_Dynamic_ABE_Check_Scenario --
14099 ------------------------------------
14101 procedure Add_Dynamic_ABE_Check_Scenario (N : Node_Id) is
14102 pragma Assert (Present (N));
14105 if not Check_Or_Failure_Generation_OK then
14108 -- Nothing to do if the dynamic model is not in effect
14110 elsif not Dynamic_Elaboration_Checks then
14114 NE_Set.Insert (Dynamic_ABE_Check_Scenarios, N);
14115 end Add_Dynamic_ABE_Check_Scenario;
14117 -------------------------------
14118 -- Add_Library_Body_Scenario --
14119 -------------------------------
14121 procedure Add_Library_Body_Scenario (N : Node_Id) is
14122 pragma Assert (Present (N));
14124 NE_Set.Insert (Library_Body_Scenarios, N);
14125 end Add_Library_Body_Scenario;
14127 -------------------------------
14128 -- Add_Library_Spec_Scenario --
14129 -------------------------------
14131 procedure Add_Library_Spec_Scenario (N : Node_Id) is
14132 pragma Assert (Present (N));
14134 NE_Set.Insert (Library_Spec_Scenarios, N);
14135 end Add_Library_Spec_Scenario;
14137 ------------------------
14138 -- Add_SPARK_Scenario --
14139 ------------------------
14141 procedure Add_SPARK_Scenario (N : Node_Id) is
14142 pragma Assert (Present (N));
14144 NE_Set.Insert (SPARK_Scenarios, N);
14145 end Add_SPARK_Scenario;
14147 ---------------------
14148 -- Delete_Scenario --
14149 ---------------------
14151 procedure Delete_Scenario (N : Node_Id) is
14152 pragma Assert (Present (N));
14155 -- Delete the scenario from whichever set it belongs to
14157 NE_Set.Delete (Declaration_Scenarios, N);
14158 NE_Set.Delete (Dynamic_ABE_Check_Scenarios, N);
14159 NE_Set.Delete (Library_Body_Scenarios, N);
14160 NE_Set.Delete (Library_Spec_Scenarios, N);
14161 NE_Set.Delete (SPARK_Scenarios, N);
14162 end Delete_Scenario;
14164 -----------------------------------
14165 -- Iterate_Declaration_Scenarios --
14166 -----------------------------------
14168 function Iterate_Declaration_Scenarios return NE_Set.Iterator is
14170 return NE_Set.Iterate (Declaration_Scenarios);
14171 end Iterate_Declaration_Scenarios;
14173 -----------------------------------------
14174 -- Iterate_Dynamic_ABE_Check_Scenarios --
14175 -----------------------------------------
14177 function Iterate_Dynamic_ABE_Check_Scenarios return NE_Set.Iterator is
14179 return NE_Set.Iterate (Dynamic_ABE_Check_Scenarios);
14180 end Iterate_Dynamic_ABE_Check_Scenarios;
14182 ------------------------------------
14183 -- Iterate_Library_Body_Scenarios --
14184 ------------------------------------
14186 function Iterate_Library_Body_Scenarios return NE_Set.Iterator is
14188 return NE_Set.Iterate (Library_Body_Scenarios);
14189 end Iterate_Library_Body_Scenarios;
14191 ------------------------------------
14192 -- Iterate_Library_Spec_Scenarios --
14193 ------------------------------------
14195 function Iterate_Library_Spec_Scenarios return NE_Set.Iterator is
14197 return NE_Set.Iterate (Library_Spec_Scenarios);
14198 end Iterate_Library_Spec_Scenarios;
14200 -----------------------------
14201 -- Iterate_SPARK_Scenarios --
14202 -----------------------------
14204 function Iterate_SPARK_Scenarios return NE_Set.Iterator is
14206 return NE_Set.Iterate (SPARK_Scenarios);
14207 end Iterate_SPARK_Scenarios;
14209 ----------------------
14210 -- Replace_Scenario --
14211 ----------------------
14213 procedure Replace_Scenario (Old_N : Node_Id; New_N : Node_Id) is
14214 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set);
14215 -- Determine whether scenario Old_N is present in set Scenarios, and
14216 -- if this is the case it, replace it with New_N.
14218 -------------------------
14219 -- Replace_Scenario_In --
14220 -------------------------
14222 procedure Replace_Scenario_In (Scenarios : NE_Set.Membership_Set) is
14224 -- The set is intentionally checked for existance because node
14225 -- rewriting may occur after Sem_Elab has verified all scenarios
14226 -- and data structures have been destroyed.
14228 if NE_Set.Present (Scenarios)
14229 and then NE_Set.Contains (Scenarios, Old_N)
14231 NE_Set.Delete (Scenarios, Old_N);
14232 NE_Set.Insert (Scenarios, New_N);
14234 end Replace_Scenario_In;
14236 -- Start of processing for Replace_Scenario
14239 Replace_Scenario_In (Declaration_Scenarios);
14240 Replace_Scenario_In (Dynamic_ABE_Check_Scenarios);
14241 Replace_Scenario_In (Library_Body_Scenarios);
14242 Replace_Scenario_In (Library_Spec_Scenarios);
14243 Replace_Scenario_In (SPARK_Scenarios);
14244 end Replace_Scenario;
14245 end Scenario_Storage;
14251 package body Semantics is
14253 --------------------------------
14254 -- Is_Accept_Alternative_Proc --
14255 --------------------------------
14257 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is
14259 -- To qualify, the entity must denote a procedure with a receiving
14263 Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id));
14264 end Is_Accept_Alternative_Proc;
14266 ------------------------
14267 -- Is_Activation_Proc --
14268 ------------------------
14270 function Is_Activation_Proc (Id : Entity_Id) return Boolean is
14272 -- To qualify, the entity must denote one of the runtime procedures
14273 -- in charge of task activation.
14275 if Ekind (Id) = E_Procedure then
14276 if Restricted_Profile then
14277 return Is_RTE (Id, RE_Activate_Restricted_Tasks);
14279 return Is_RTE (Id, RE_Activate_Tasks);
14284 end Is_Activation_Proc;
14286 ----------------------------
14287 -- Is_Ada_Semantic_Target --
14288 ----------------------------
14290 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is
14293 Is_Activation_Proc (Id)
14294 or else Is_Controlled_Proc (Id, Name_Adjust)
14295 or else Is_Controlled_Proc (Id, Name_Finalize)
14296 or else Is_Controlled_Proc (Id, Name_Initialize)
14297 or else Is_Init_Proc (Id)
14298 or else Is_Invariant_Proc (Id)
14299 or else Is_Protected_Entry (Id)
14300 or else Is_Protected_Subp (Id)
14301 or else Is_Protected_Body_Subp (Id)
14302 or else Is_Subprogram_Inst (Id)
14303 or else Is_Task_Entry (Id);
14304 end Is_Ada_Semantic_Target;
14306 --------------------------------
14307 -- Is_Assertion_Pragma_Target --
14308 --------------------------------
14310 function Is_Assertion_Pragma_Target (Id : Entity_Id) return Boolean is
14313 Is_Default_Initial_Condition_Proc (Id)
14314 or else Is_Initial_Condition_Proc (Id)
14315 or else Is_Invariant_Proc (Id)
14316 or else Is_Partial_Invariant_Proc (Id)
14317 or else Is_Postconditions_Proc (Id);
14318 end Is_Assertion_Pragma_Target;
14320 ----------------------------
14321 -- Is_Bodiless_Subprogram --
14322 ----------------------------
14324 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is
14326 -- An abstract subprogram does not have a body
14328 if Ekind_In (Subp_Id, E_Function,
14331 and then Is_Abstract_Subprogram (Subp_Id)
14335 -- A formal subprogram does not have a body
14337 elsif Is_Formal_Subprogram (Subp_Id) then
14340 -- An imported subprogram may have a body, however it is not known at
14341 -- compile or bind time where the body resides and whether it will be
14342 -- elaborated on time.
14344 elsif Is_Imported (Subp_Id) then
14349 end Is_Bodiless_Subprogram;
14351 ----------------------
14352 -- Is_Bridge_Target --
14353 ----------------------
14355 function Is_Bridge_Target (Id : Entity_Id) return Boolean is
14358 Is_Accept_Alternative_Proc (Id)
14359 or else Is_Finalizer_Proc (Id)
14360 or else Is_Partial_Invariant_Proc (Id)
14361 or else Is_Postconditions_Proc (Id)
14362 or else Is_TSS (Id, TSS_Deep_Adjust)
14363 or else Is_TSS (Id, TSS_Deep_Finalize)
14364 or else Is_TSS (Id, TSS_Deep_Initialize);
14365 end Is_Bridge_Target;
14367 ------------------------
14368 -- Is_Controlled_Proc --
14369 ------------------------
14371 function Is_Controlled_Proc
14372 (Subp_Id : Entity_Id;
14373 Subp_Nam : Name_Id) return Boolean
14375 Formal_Id : Entity_Id;
14378 pragma Assert (Nam_In (Subp_Nam, Name_Adjust,
14382 -- To qualify, the subprogram must denote a source procedure with
14383 -- name Adjust, Finalize, or Initialize where the sole formal is
14386 if Comes_From_Source (Subp_Id)
14387 and then Ekind (Subp_Id) = E_Procedure
14388 and then Chars (Subp_Id) = Subp_Nam
14390 Formal_Id := First_Formal (Subp_Id);
14393 Present (Formal_Id)
14394 and then Is_Controlled (Etype (Formal_Id))
14395 and then No (Next_Formal (Formal_Id));
14399 end Is_Controlled_Proc;
14401 ---------------------------------------
14402 -- Is_Default_Initial_Condition_Proc --
14403 ---------------------------------------
14405 function Is_Default_Initial_Condition_Proc
14406 (Id : Entity_Id) return Boolean
14409 -- To qualify, the entity must denote a Default_Initial_Condition
14412 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id);
14413 end Is_Default_Initial_Condition_Proc;
14415 -----------------------
14416 -- Is_Finalizer_Proc --
14417 -----------------------
14419 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is
14421 -- To qualify, the entity must denote a _Finalizer procedure
14423 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
14424 end Is_Finalizer_Proc;
14426 -------------------------------
14427 -- Is_Initial_Condition_Proc --
14428 -------------------------------
14430 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is
14432 -- To qualify, the entity must denote an Initial_Condition procedure
14435 Ekind (Id) = E_Procedure
14436 and then Is_Initial_Condition_Procedure (Id);
14437 end Is_Initial_Condition_Proc;
14439 --------------------
14440 -- Is_Initialized --
14441 --------------------
14443 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is
14445 -- To qualify, the object declaration must have an expression
14448 Present (Expression (Obj_Decl))
14449 or else Has_Init_Expression (Obj_Decl);
14450 end Is_Initialized;
14452 -----------------------
14453 -- Is_Invariant_Proc --
14454 -----------------------
14456 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is
14458 -- To qualify, the entity must denote the "full" invariant procedure
14460 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id);
14461 end Is_Invariant_Proc;
14463 ---------------------------------------
14464 -- Is_Non_Library_Level_Encapsulator --
14465 ---------------------------------------
14467 function Is_Non_Library_Level_Encapsulator
14468 (N : Node_Id) return Boolean
14472 when N_Abstract_Subprogram_Declaration
14473 | N_Aspect_Specification
14474 | N_Component_Declaration
14476 | N_Entry_Declaration
14477 | N_Expression_Function
14478 | N_Formal_Abstract_Subprogram_Declaration
14479 | N_Formal_Concrete_Subprogram_Declaration
14480 | N_Formal_Object_Declaration
14481 | N_Formal_Package_Declaration
14482 | N_Formal_Type_Declaration
14483 | N_Generic_Association
14484 | N_Implicit_Label_Declaration
14485 | N_Incomplete_Type_Declaration
14486 | N_Private_Extension_Declaration
14487 | N_Private_Type_Declaration
14489 | N_Protected_Type_Declaration
14490 | N_Single_Protected_Declaration
14491 | N_Single_Task_Declaration
14492 | N_Subprogram_Body
14493 | N_Subprogram_Declaration
14495 | N_Task_Type_Declaration
14500 return Is_Generic_Declaration_Or_Body (N);
14502 end Is_Non_Library_Level_Encapsulator;
14504 -------------------------------
14505 -- Is_Partial_Invariant_Proc --
14506 -------------------------------
14508 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is
14510 -- To qualify, the entity must denote the "partial" invariant
14514 Ekind (Id) = E_Procedure
14515 and then Is_Partial_Invariant_Procedure (Id);
14516 end Is_Partial_Invariant_Proc;
14518 ----------------------------
14519 -- Is_Postconditions_Proc --
14520 ----------------------------
14522 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is
14524 -- To qualify, the entity must denote a _Postconditions procedure
14527 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions;
14528 end Is_Postconditions_Proc;
14530 ---------------------------
14531 -- Is_Preelaborated_Unit --
14532 ---------------------------
14534 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is
14537 Is_Preelaborated (Id)
14538 or else Is_Pure (Id)
14539 or else Is_Remote_Call_Interface (Id)
14540 or else Is_Remote_Types (Id)
14541 or else Is_Shared_Passive (Id);
14542 end Is_Preelaborated_Unit;
14544 ------------------------
14545 -- Is_Protected_Entry --
14546 ------------------------
14548 function Is_Protected_Entry (Id : Entity_Id) return Boolean is
14550 -- To qualify, the entity must denote an entry defined in a protected
14555 and then Is_Protected_Type (Non_Private_View (Scope (Id)));
14556 end Is_Protected_Entry;
14558 -----------------------
14559 -- Is_Protected_Subp --
14560 -----------------------
14562 function Is_Protected_Subp (Id : Entity_Id) return Boolean is
14564 -- To qualify, the entity must denote a subprogram defined within a
14568 Ekind_In (Id, E_Function, E_Procedure)
14569 and then Is_Protected_Type (Non_Private_View (Scope (Id)));
14570 end Is_Protected_Subp;
14572 ----------------------------
14573 -- Is_Protected_Body_Subp --
14574 ----------------------------
14576 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is
14578 -- To qualify, the entity must denote a subprogram with attribute
14579 -- Protected_Subprogram set.
14582 Ekind_In (Id, E_Function, E_Procedure)
14583 and then Present (Protected_Subprogram (Id));
14584 end Is_Protected_Body_Subp;
14590 function Is_Scenario (N : Node_Id) return Boolean is
14593 when N_Assignment_Statement
14594 | N_Attribute_Reference
14596 | N_Entry_Call_Statement
14599 | N_Function_Instantiation
14601 | N_Package_Instantiation
14602 | N_Procedure_Call_Statement
14603 | N_Procedure_Instantiation
14604 | N_Requeue_Statement
14613 ------------------------------
14614 -- Is_SPARK_Semantic_Target --
14615 ------------------------------
14617 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is
14620 Is_Default_Initial_Condition_Proc (Id)
14621 or else Is_Initial_Condition_Proc (Id);
14622 end Is_SPARK_Semantic_Target;
14624 ------------------------
14625 -- Is_Subprogram_Inst --
14626 ------------------------
14628 function Is_Subprogram_Inst (Id : Entity_Id) return Boolean is
14630 -- To qualify, the entity must denote a function or a procedure which
14631 -- is hidden within an anonymous package, and is a generic instance.
14634 Ekind_In (Id, E_Function, E_Procedure)
14635 and then Is_Hidden (Id)
14636 and then Is_Generic_Instance (Id);
14637 end Is_Subprogram_Inst;
14639 ------------------------------
14640 -- Is_Suitable_Access_Taken --
14641 ------------------------------
14643 function Is_Suitable_Access_Taken (N : Node_Id) return Boolean is
14646 Subp_Id : Entity_Id;
14649 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
14651 if Debug_Flag_Dot_UU then
14654 -- Nothing to do when the scenario is not an attribute reference
14656 elsif Nkind (N) /= N_Attribute_Reference then
14659 -- Nothing to do for internally-generated attributes because they are
14660 -- assumed to be ABE safe.
14662 elsif not Comes_From_Source (N) then
14666 Nam := Attribute_Name (N);
14667 Pref := Prefix (N);
14669 -- Sanitize the prefix of the attribute
14671 if not Is_Entity_Name (Pref) then
14674 elsif No (Entity (Pref)) then
14678 Subp_Id := Entity (Pref);
14680 if not Is_Subprogram_Or_Entry (Subp_Id) then
14684 -- Traverse a possible chain of renamings to obtain the original
14685 -- entry or subprogram which the prefix may rename.
14687 Subp_Id := Get_Renamed_Entity (Subp_Id);
14689 -- To qualify, the attribute must meet the following prerequisites:
14693 -- The prefix must denote a source entry, operator, or subprogram
14694 -- which is not imported.
14696 Comes_From_Source (Subp_Id)
14697 and then Is_Subprogram_Or_Entry (Subp_Id)
14698 and then not Is_Bodiless_Subprogram (Subp_Id)
14700 -- The attribute name must be one of the 'Access forms. Note that
14701 -- 'Unchecked_Access cannot apply to a subprogram.
14703 and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access);
14704 end Is_Suitable_Access_Taken;
14706 ----------------------
14707 -- Is_Suitable_Call --
14708 ----------------------
14710 function Is_Suitable_Call (N : Node_Id) return Boolean is
14712 -- Entry and subprogram calls are intentionally ignored because they
14713 -- may undergo expansion depending on the compilation mode, previous
14714 -- errors, generic context, etc. Call markers play the role of calls
14715 -- and provide a uniform foundation for ABE processing.
14717 return Nkind (N) = N_Call_Marker;
14718 end Is_Suitable_Call;
14720 -------------------------------
14721 -- Is_Suitable_Instantiation --
14722 -------------------------------
14724 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is
14725 Inst : constant Node_Id := Scenario (N);
14728 -- To qualify, the instantiation must come from source
14731 Comes_From_Source (Inst)
14732 and then Nkind (Inst) in N_Generic_Instantiation;
14733 end Is_Suitable_Instantiation;
14735 ------------------------------------
14736 -- Is_Suitable_SPARK_Derived_Type --
14737 ------------------------------------
14739 function Is_Suitable_SPARK_Derived_Type (N : Node_Id) return Boolean is
14744 -- To qualify, the type declaration must denote a derived tagged type
14745 -- with primitive operations, subject to pragma SPARK_Mode On.
14747 if Nkind (N) = N_Full_Type_Declaration
14748 and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
14750 Typ := Defining_Entity (N);
14751 Prag := SPARK_Pragma (Typ);
14754 Is_Tagged_Type (Typ)
14755 and then Has_Primitive_Operations (Typ)
14756 and then Present (Prag)
14757 and then Get_SPARK_Mode_From_Annotation (Prag) = On;
14761 end Is_Suitable_SPARK_Derived_Type;
14763 -------------------------------------
14764 -- Is_Suitable_SPARK_Instantiation --
14765 -------------------------------------
14767 function Is_Suitable_SPARK_Instantiation (N : Node_Id) return Boolean is
14768 Inst : constant Node_Id := Scenario (N);
14770 Gen_Id : Entity_Id;
14774 -- To qualify, both the instantiation and the generic must be subject
14775 -- to SPARK_Mode On.
14777 if Is_Suitable_Instantiation (N) then
14778 Gen_Id := Instantiated_Generic (Inst);
14779 Prag := SPARK_Pragma (Gen_Id);
14782 Is_SPARK_Mode_On_Node (Inst)
14783 and then Present (Prag)
14784 and then Get_SPARK_Mode_From_Annotation (Prag) = On;
14788 end Is_Suitable_SPARK_Instantiation;
14790 --------------------------------------------
14791 -- Is_Suitable_SPARK_Refined_State_Pragma --
14792 --------------------------------------------
14794 function Is_Suitable_SPARK_Refined_State_Pragma
14795 (N : Node_Id) return Boolean
14798 -- To qualfy, the pragma must denote Refined_State
14801 Nkind (N) = N_Pragma
14802 and then Pragma_Name (N) = Name_Refined_State;
14803 end Is_Suitable_SPARK_Refined_State_Pragma;
14805 -------------------------------------
14806 -- Is_Suitable_Variable_Assignment --
14807 -------------------------------------
14809 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is
14811 N_Unit_Id : Entity_Id;
14813 Var_Decl : Node_Id;
14814 Var_Id : Entity_Id;
14815 Var_Unit : Node_Id;
14816 Var_Unit_Id : Entity_Id;
14819 -- Nothing to do when the scenario is not an assignment
14821 if Nkind (N) /= N_Assignment_Statement then
14824 -- Nothing to do for internally-generated assignments because they
14825 -- are assumed to be ABE safe.
14827 elsif not Comes_From_Source (N) then
14830 -- Assignments are ignored in GNAT mode on the assumption that
14831 -- they are ABE-safe. This behaviour parallels that of the old
14834 elsif GNAT_Mode then
14838 Nam := Assignment_Target (N);
14840 -- Sanitize the left hand side of the assignment
14842 if not Is_Entity_Name (Nam) then
14845 elsif No (Entity (Nam)) then
14849 Var_Id := Entity (Nam);
14851 -- Sanitize the variable
14853 if Var_Id = Any_Id then
14856 elsif Ekind (Var_Id) /= E_Variable then
14860 Var_Decl := Declaration_Node (Var_Id);
14862 if Nkind (Var_Decl) /= N_Object_Declaration then
14866 N_Unit_Id := Find_Top_Unit (N);
14867 N_Unit := Unit_Declaration_Node (N_Unit_Id);
14869 Var_Unit_Id := Find_Top_Unit (Var_Decl);
14870 Var_Unit := Unit_Declaration_Node (Var_Unit_Id);
14872 -- To qualify, the assignment must meet the following prerequisites:
14875 Comes_From_Source (Var_Id)
14877 -- The variable must be declared in the spec of compilation unit
14880 and then Nkind (Var_Unit) = N_Package_Declaration
14881 and then Find_Enclosing_Level (Var_Decl) = Library_Spec_Level
14883 -- The assignment must occur in the body of compilation unit U
14885 and then Nkind (N_Unit) = N_Package_Body
14886 and then Present (Corresponding_Body (Var_Unit))
14887 and then Corresponding_Body (Var_Unit) = N_Unit_Id;
14888 end Is_Suitable_Variable_Assignment;
14890 ------------------------------------
14891 -- Is_Suitable_Variable_Reference --
14892 ------------------------------------
14894 function Is_Suitable_Variable_Reference (N : Node_Id) return Boolean is
14896 -- Expanded names and identifiers are intentionally ignored because
14897 -- they be folded, optimized away, etc. Variable references markers
14898 -- play the role of variable references and provide a uniform
14899 -- foundation for ABE processing.
14901 return Nkind (N) = N_Variable_Reference_Marker;
14902 end Is_Suitable_Variable_Reference;
14904 -------------------
14905 -- Is_Task_Entry --
14906 -------------------
14908 function Is_Task_Entry (Id : Entity_Id) return Boolean is
14910 -- To qualify, the entity must denote an entry defined in a task type
14913 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id)));
14916 ------------------------
14917 -- Is_Up_Level_Target --
14918 ------------------------
14920 function Is_Up_Level_Target
14921 (Targ_Decl : Node_Id;
14922 In_State : Processing_In_State) return Boolean
14924 Root : constant Node_Id := Root_Scenario;
14925 Root_Rep : constant Scenario_Rep_Id :=
14926 Scenario_Representation_Of (Root, In_State);
14929 -- The root appears within the declaratons of a block statement,
14930 -- entry body, subprogram body, or task body ignoring enclosing
14931 -- packages. The root is always within the main unit.
14933 if not In_State.Suppress_Up_Level_Targets
14934 and then Level (Root_Rep) = Declaration_Level
14936 -- The target is within the main unit. It acts as an up-level
14937 -- target when it appears within a context which encloses the
14940 -- package body Main_Unit is
14941 -- function Func ...; -- target
14943 -- procedure Proc is
14944 -- X : ... := Func; -- root scenario
14946 if In_Extended_Main_Code_Unit (Targ_Decl) then
14947 return not In_Same_Context (Root, Targ_Decl, Nested_OK => True);
14949 -- Otherwise the target is external to the main unit which makes
14950 -- it an up-level target.
14958 end Is_Up_Level_Target;
14961 ---------------------------
14962 -- Set_Elaboration_Phase --
14963 ---------------------------
14965 procedure Set_Elaboration_Phase (Status : Elaboration_Phase_Status) is
14967 Elaboration_Phase := Status;
14968 end Set_Elaboration_Phase;
14970 ---------------------
14971 -- SPARK_Processor --
14972 ---------------------
14974 package body SPARK_Processor is
14976 -----------------------
14977 -- Local subprograms --
14978 -----------------------
14980 procedure Process_SPARK_Derived_Type
14981 (Typ_Decl : Node_Id;
14982 Typ_Rep : Scenario_Rep_Id;
14983 In_State : Processing_In_State);
14984 pragma Inline (Process_SPARK_Derived_Type);
14985 -- Verify that the freeze node of a derived type denoted by declaration
14986 -- Typ_Decl is within the early call region of each overriding primitive
14987 -- body that belongs to the derived type (SPARK RM 7.7(8)). Typ_Rep is
14988 -- the representation of the type. In_State denotes the current state of
14989 -- the Processing phase.
14991 procedure Process_SPARK_Instantiation
14993 Inst_Rep : Scenario_Rep_Id;
14994 In_State : Processing_In_State);
14995 pragma Inline (Process_SPARK_Instantiation);
14996 -- Verify that instanciation Inst does not precede the generic body it
14997 -- instantiates (SPARK RM 7.7(6)). Inst_Rep is the representation of the
14998 -- instantiation. In_State is the current state of the Processing phase.
15000 procedure Process_SPARK_Refined_State_Pragma
15002 Prag_Rep : Scenario_Rep_Id;
15003 In_State : Processing_In_State);
15004 pragma Inline (Process_SPARK_Refined_State_Pragma);
15005 -- Verify that each constituent of Refined_State pragma Prag which
15006 -- belongs to abstract state mentioned in pragma Initializes has prior
15007 -- elaboration with respect to the main unit (SPARK RM 7.7.1(7)).
15008 -- Prag_Rep is the representation of the pragma. In_State denotes the
15009 -- current state of the Processing phase.
15011 procedure Process_SPARK_Scenario
15013 In_State : Processing_In_State);
15014 pragma Inline (Process_SPARK_Scenario);
15015 -- Top-level dispatcher for verifying SPARK scenarios which are not
15016 -- always executable during elaboration but still need elaboration-
15017 -- related checks. In_State is the current state of the Processing
15020 ---------------------------------
15021 -- Check_SPARK_Model_In_Effect --
15022 ---------------------------------
15024 SPARK_Model_Warning_Posted : Boolean := False;
15025 -- This flag prevents the same SPARK model-related warning from being
15026 -- emitted multiple times.
15028 procedure Check_SPARK_Model_In_Effect is
15029 Spec_Id : constant Entity_Id :=
15030 Unique_Entity (Cunit_Entity (Main_Unit));
15033 -- Do not emit the warning multiple times as this creates useless
15036 if SPARK_Model_Warning_Posted then
15039 -- SPARK rule verification requires the "strict" static model
15041 elsif Static_Elaboration_Checks
15042 and not Relaxed_Elaboration_Checks
15046 -- Any other combination of models does not guarantee the absence of
15047 -- ABE problems for SPARK rule verification purposes. Note that there
15048 -- is no need to check for the presence of the legacy ABE mechanism
15049 -- because the legacy code has its own dedicated processing for SPARK
15053 SPARK_Model_Warning_Posted := True;
15056 ("??SPARK elaboration checks require static elaboration model",
15059 if Dynamic_Elaboration_Checks then
15061 ("\dynamic elaboration model is in effect", Spec_Id);
15064 pragma Assert (Relaxed_Elaboration_Checks);
15066 ("\relaxed elaboration model is in effect", Spec_Id);
15069 end Check_SPARK_Model_In_Effect;
15071 ---------------------------
15072 -- Check_SPARK_Scenarios --
15073 ---------------------------
15075 procedure Check_SPARK_Scenarios is
15076 Iter : NE_Set.Iterator;
15080 Iter := Iterate_SPARK_Scenarios;
15081 while NE_Set.Has_Next (Iter) loop
15082 NE_Set.Next (Iter, N);
15084 Process_SPARK_Scenario
15086 In_State => SPARK_State);
15088 end Check_SPARK_Scenarios;
15090 --------------------------------
15091 -- Process_SPARK_Derived_Type --
15092 --------------------------------
15094 procedure Process_SPARK_Derived_Type
15095 (Typ_Decl : Node_Id;
15096 Typ_Rep : Scenario_Rep_Id;
15097 In_State : Processing_In_State)
15099 pragma Unreferenced (In_State);
15101 Typ : constant Entity_Id := Target (Typ_Rep);
15103 Stop_Check : exception;
15104 -- This exception is raised when the freeze node violates the
15105 -- placement rules.
15107 procedure Check_Overriding_Primitive
15110 pragma Inline (Check_Overriding_Primitive);
15111 -- Verify that freeze node FNode is within the early call region of
15112 -- overriding primitive Prim's body.
15114 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr;
15115 pragma Inline (Freeze_Node_Location);
15116 -- Return a more accurate source location associated with freeze node
15119 function Precedes_Source_Construct (N : Node_Id) return Boolean;
15120 pragma Inline (Precedes_Source_Construct);
15121 -- Determine whether arbitrary node N appears prior to some source
15124 procedure Suggest_Elaborate_Body
15126 Body_Decl : Node_Id;
15127 Error_Nod : Node_Id);
15128 pragma Inline (Suggest_Elaborate_Body);
15129 -- Suggest the use of pragma Elaborate_Body when the pragma will
15130 -- allow for node N to appear within the early call region of
15131 -- subprogram body Body_Decl. The suggestion is attached to
15132 -- Error_Nod as a continuation error.
15134 --------------------------------
15135 -- Check_Overriding_Primitive --
15136 --------------------------------
15138 procedure Check_Overriding_Primitive
15142 Prim_Decl : constant Node_Id := Unit_Declaration_Node (Prim);
15143 Body_Decl : Node_Id;
15144 Body_Id : Entity_Id;
15148 -- Nothing to do for predefined primitives because they are
15149 -- artifacts of tagged type expansion and cannot override source
15152 if Is_Predefined_Dispatching_Operation (Prim) then
15156 Body_Id := Corresponding_Body (Prim_Decl);
15158 -- Nothing to do when the primitive does not have a corresponding
15159 -- body. This can happen when the unit with the bodies is not the
15160 -- main unit subjected to ABE checks.
15162 if No (Body_Id) then
15165 -- The primitive overrides a parent or progenitor primitive
15167 elsif Present (Overridden_Operation (Prim)) then
15169 -- Nothing to do when overriding an interface primitive happens
15170 -- by inheriting a non-interface primitive as the check would
15171 -- be done on the parent primitive.
15173 if Present (Alias (Prim)) then
15177 -- Nothing to do when the primitive is not overriding. The body of
15178 -- such a primitive cannot be targeted by a dispatching call which
15179 -- is executable during elaboration, and cannot cause an ABE.
15185 Body_Decl := Unit_Declaration_Node (Body_Id);
15186 Region := Find_Early_Call_Region (Body_Decl);
15188 -- The freeze node appears prior to the early call region of the
15191 -- IMPORTANT: This check must always be performed even when
15192 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
15193 -- specified because the static model cannot guarantee the absence
15194 -- of ABEs in the presence of dispatching calls.
15196 if Earlier_In_Extended_Unit (FNode, Region) then
15197 Error_Msg_Node_2 := Prim;
15199 ("first freezing point of type & must appear within early "
15200 & "call region of primitive body & (SPARK RM 7.7(8))",
15203 Error_Msg_Sloc := Sloc (Region);
15204 Error_Msg_N ("\region starts #", Typ_Decl);
15206 Error_Msg_Sloc := Sloc (Body_Decl);
15207 Error_Msg_N ("\region ends #", Typ_Decl);
15209 Error_Msg_Sloc := Freeze_Node_Location (FNode);
15210 Error_Msg_N ("\first freezing point #", Typ_Decl);
15212 -- If applicable, suggest the use of pragma Elaborate_Body in
15213 -- the associated package spec.
15215 Suggest_Elaborate_Body
15217 Body_Decl => Body_Decl,
15218 Error_Nod => Typ_Decl);
15222 end Check_Overriding_Primitive;
15224 --------------------------
15225 -- Freeze_Node_Location --
15226 --------------------------
15228 function Freeze_Node_Location (FNode : Node_Id) return Source_Ptr is
15229 Context : constant Node_Id := Parent (FNode);
15230 Loc : constant Source_Ptr := Sloc (FNode);
15232 Prv_Decls : List_Id;
15233 Vis_Decls : List_Id;
15236 -- In general, the source location of the freeze node is as close
15237 -- as possible to the real freeze point, except when the freeze
15238 -- node is at the "bottom" of a package spec.
15240 if Nkind (Context) = N_Package_Specification then
15241 Prv_Decls := Private_Declarations (Context);
15242 Vis_Decls := Visible_Declarations (Context);
15244 -- The freeze node appears in the private declarations of the
15247 if Present (Prv_Decls)
15248 and then List_Containing (FNode) = Prv_Decls
15252 -- The freeze node appears in the visible declarations of the
15253 -- package and there are no private declarations.
15255 elsif Present (Vis_Decls)
15256 and then List_Containing (FNode) = Vis_Decls
15257 and then (No (Prv_Decls) or else Is_Empty_List (Prv_Decls))
15261 -- Otherwise the freeze node is not in the "last" declarative
15262 -- list of the package. Use the existing source location of the
15269 -- The freeze node appears at the "bottom" of the package when
15270 -- it is in the "last" declarative list and is either the last
15271 -- in the list or is followed by internal constructs only. In
15272 -- that case the more appropriate source location is that of
15273 -- the package end label.
15275 if not Precedes_Source_Construct (FNode) then
15276 return Sloc (End_Label (Context));
15281 end Freeze_Node_Location;
15283 -------------------------------
15284 -- Precedes_Source_Construct --
15285 -------------------------------
15287 function Precedes_Source_Construct (N : Node_Id) return Boolean is
15292 while Present (Decl) loop
15293 if Comes_From_Source (Decl) then
15296 -- A generated body for a source expression function is treated
15297 -- as a source construct.
15299 elsif Nkind (Decl) = N_Subprogram_Body
15300 and then Was_Expression_Function (Decl)
15301 and then Comes_From_Source (Original_Node (Decl))
15310 end Precedes_Source_Construct;
15312 ----------------------------
15313 -- Suggest_Elaborate_Body --
15314 ----------------------------
15316 procedure Suggest_Elaborate_Body
15318 Body_Decl : Node_Id;
15319 Error_Nod : Node_Id)
15321 Unit_Id : constant Node_Id := Unit (Cunit (Main_Unit));
15325 -- The suggestion applies only when the subprogram body resides in
15326 -- a compilation package body, and a pragma Elaborate_Body would
15327 -- allow for the node to appear in the early call region of the
15328 -- subprogram body. This implies that all code from the subprogram
15329 -- body up to the node is preelaborable.
15331 if Nkind (Unit_Id) = N_Package_Body then
15333 -- Find the start of the early call region again assuming that
15334 -- the package spec has pragma Elaborate_Body. Note that the
15335 -- internal data structures are intentionally not updated
15336 -- because this is a speculative search.
15339 Find_Early_Call_Region
15340 (Body_Decl => Body_Decl,
15341 Assume_Elab_Body => True,
15342 Skip_Memoization => True);
15344 -- If the node appears within the early call region, assuming
15345 -- that the package spec carries pragma Elaborate_Body, then it
15346 -- is safe to suggest the pragma.
15348 if Earlier_In_Extended_Unit (Region, N) then
15349 Error_Msg_Name_1 := Name_Elaborate_Body;
15351 ("\consider adding pragma % in spec of unit &",
15352 Error_Nod, Defining_Entity (Unit_Id));
15355 end Suggest_Elaborate_Body;
15359 FNode : constant Node_Id := Freeze_Node (Typ);
15360 Prims : constant Elist_Id := Direct_Primitive_Operations (Typ);
15362 Prim_Elmt : Elmt_Id;
15364 -- Start of processing for Process_SPARK_Derived_Type
15367 -- A type should have its freeze node set by the time SPARK scenarios
15368 -- are being verified.
15370 pragma Assert (Present (FNode));
15372 -- Verify that the freeze node of the derived type is within the
15373 -- early call region of each overriding primitive body
15374 -- (SPARK RM 7.7(8)).
15376 if Present (Prims) then
15377 Prim_Elmt := First_Elmt (Prims);
15378 while Present (Prim_Elmt) loop
15379 Check_Overriding_Primitive
15380 (Prim => Node (Prim_Elmt),
15383 Next_Elmt (Prim_Elmt);
15390 end Process_SPARK_Derived_Type;
15392 ---------------------------------
15393 -- Process_SPARK_Instantiation --
15394 ---------------------------------
15396 procedure Process_SPARK_Instantiation
15398 Inst_Rep : Scenario_Rep_Id;
15399 In_State : Processing_In_State)
15401 Gen_Id : constant Entity_Id := Target (Inst_Rep);
15402 Gen_Rep : constant Target_Rep_Id :=
15403 Target_Representation_Of (Gen_Id, In_State);
15404 Body_Decl : constant Node_Id := Body_Declaration (Gen_Rep);
15407 -- The instantiation and the generic body are both in the main unit
15409 if Present (Body_Decl)
15410 and then In_Extended_Main_Code_Unit (Body_Decl)
15412 -- If the instantiation appears prior to the generic body, then the
15413 -- instantiation is illegal (SPARK RM 7.7(6)).
15415 -- IMPORTANT: This check must always be performed even when
15416 -- -gnatd.v (enforce SPARK elaboration rules in SPARK code) is not
15417 -- specified because the rule prevents use-before-declaration of
15418 -- objects that may precede the generic body.
15420 and then Earlier_In_Extended_Unit (Inst, Body_Decl)
15423 ("cannot instantiate & before body seen", Inst, Gen_Id);
15425 end Process_SPARK_Instantiation;
15427 ----------------------------
15428 -- Process_SPARK_Scenario --
15429 ----------------------------
15431 procedure Process_SPARK_Scenario
15433 In_State : Processing_In_State)
15435 Scen : constant Node_Id := Scenario (N);
15438 -- Ensure that a suitable elaboration model is in effect for SPARK
15439 -- rule verification.
15441 Check_SPARK_Model_In_Effect;
15443 -- Add the current scenario to the stack of active scenarios
15445 Push_Active_Scenario (Scen);
15449 if Is_Suitable_SPARK_Derived_Type (Scen) then
15450 Process_SPARK_Derived_Type
15452 Typ_Rep => Scenario_Representation_Of (Scen, In_State),
15453 In_State => In_State);
15457 elsif Is_Suitable_SPARK_Instantiation (Scen) then
15458 Process_SPARK_Instantiation
15460 Inst_Rep => Scenario_Representation_Of (Scen, In_State),
15461 In_State => In_State);
15463 -- Refined_State pragma
15465 elsif Is_Suitable_SPARK_Refined_State_Pragma (Scen) then
15466 Process_SPARK_Refined_State_Pragma
15468 Prag_Rep => Scenario_Representation_Of (Scen, In_State),
15469 In_State => In_State);
15472 -- Remove the current scenario from the stack of active scenarios
15473 -- once all ABE diagnostics and checks have been performed.
15475 Pop_Active_Scenario (Scen);
15476 end Process_SPARK_Scenario;
15478 ----------------------------------------
15479 -- Process_SPARK_Refined_State_Pragma --
15480 ----------------------------------------
15482 procedure Process_SPARK_Refined_State_Pragma
15484 Prag_Rep : Scenario_Rep_Id;
15485 In_State : Processing_In_State)
15487 pragma Unreferenced (Prag_Rep);
15489 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id);
15490 pragma Inline (Check_SPARK_Constituent);
15491 -- Ensure that a single constituent Constit_Id is elaborated prior to
15494 procedure Check_SPARK_Constituents (Constits : Elist_Id);
15495 pragma Inline (Check_SPARK_Constituents);
15496 -- Ensure that all constituents found in list Constits are elaborated
15497 -- prior to the main unit.
15499 procedure Check_SPARK_Initialized_State (State : Node_Id);
15500 pragma Inline (Check_SPARK_Initialized_State);
15501 -- Ensure that the constituents of single abstract state State are
15502 -- elaborated prior to the main unit.
15504 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id);
15505 pragma Inline (Check_SPARK_Initialized_States);
15506 -- Ensure that the constituents of all abstract states which appear
15507 -- in the Initializes pragma of package Pack_Id are elaborated prior
15508 -- to the main unit.
15510 -----------------------------
15511 -- Check_SPARK_Constituent --
15512 -----------------------------
15514 procedure Check_SPARK_Constituent (Constit_Id : Entity_Id) is
15518 -- Nothing to do for "null" constituents
15520 if Nkind (Constit_Id) = N_Null then
15523 -- Nothing to do for illegal constituents
15525 elsif Error_Posted (Constit_Id) then
15529 SM_Prag := SPARK_Pragma (Constit_Id);
15531 -- The check applies only when the constituent is subject to
15532 -- pragma SPARK_Mode On.
15534 if Present (SM_Prag)
15535 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On
15537 -- An external constituent of an abstract state which appears
15538 -- in the Initializes pragma of a package spec imposes an
15539 -- Elaborate requirement on the context of the main unit.
15540 -- Determine whether the context has a pragma strong enough to
15541 -- meet the requirement.
15543 -- IMPORTANT: This check is performed only when -gnatd.v
15544 -- (enforce SPARK elaboration rules in SPARK code) is in effect
15545 -- because the static model can ensure the prior elaboration of
15546 -- the unit which contains a constituent by installing implicit
15547 -- Elaborate pragma.
15549 if Debug_Flag_Dot_V then
15550 Meet_Elaboration_Requirement
15552 Targ_Id => Constit_Id,
15553 Req_Nam => Name_Elaborate,
15554 In_State => In_State);
15556 -- Otherwise ensure that the unit with the external constituent
15557 -- is elaborated prior to the main unit.
15560 Ensure_Prior_Elaboration
15562 Unit_Id => Find_Top_Unit (Constit_Id),
15563 Prag_Nam => Name_Elaborate,
15564 In_State => In_State);
15567 end Check_SPARK_Constituent;
15569 ------------------------------
15570 -- Check_SPARK_Constituents --
15571 ------------------------------
15573 procedure Check_SPARK_Constituents (Constits : Elist_Id) is
15574 Constit_Elmt : Elmt_Id;
15577 if Present (Constits) then
15578 Constit_Elmt := First_Elmt (Constits);
15579 while Present (Constit_Elmt) loop
15580 Check_SPARK_Constituent (Node (Constit_Elmt));
15581 Next_Elmt (Constit_Elmt);
15584 end Check_SPARK_Constituents;
15586 -----------------------------------
15587 -- Check_SPARK_Initialized_State --
15588 -----------------------------------
15590 procedure Check_SPARK_Initialized_State (State : Node_Id) is
15592 State_Id : Entity_Id;
15595 -- Nothing to do for "null" initialization items
15597 if Nkind (State) = N_Null then
15600 -- Nothing to do for illegal states
15602 elsif Error_Posted (State) then
15606 State_Id := Entity_Of (State);
15608 -- Sanitize the state
15610 if No (State_Id) then
15613 elsif Error_Posted (State_Id) then
15616 elsif Ekind (State_Id) /= E_Abstract_State then
15620 -- The check is performed only when the abstract state is subject
15621 -- to SPARK_Mode On.
15623 SM_Prag := SPARK_Pragma (State_Id);
15625 if Present (SM_Prag)
15626 and then Get_SPARK_Mode_From_Annotation (SM_Prag) = On
15628 Check_SPARK_Constituents (Refinement_Constituents (State_Id));
15630 end Check_SPARK_Initialized_State;
15632 ------------------------------------
15633 -- Check_SPARK_Initialized_States --
15634 ------------------------------------
15636 procedure Check_SPARK_Initialized_States (Pack_Id : Entity_Id) is
15637 Init_Prag : constant Node_Id :=
15638 Get_Pragma (Pack_Id, Pragma_Initializes);
15644 if Present (Init_Prag) then
15645 Inits := Expression (Get_Argument (Init_Prag, Pack_Id));
15647 -- Avoid processing a "null" initialization list. The only
15648 -- other alternative is an aggregate.
15650 if Nkind (Inits) = N_Aggregate then
15652 -- The initialization items appear in list form:
15654 -- (state1, state2)
15656 if Present (Expressions (Inits)) then
15657 Init := First (Expressions (Inits));
15658 while Present (Init) loop
15659 Check_SPARK_Initialized_State (Init);
15664 -- The initialization items appear in associated form:
15666 -- (state1 => item1,
15667 -- state2 => (item2, item3))
15669 if Present (Component_Associations (Inits)) then
15670 Init := First (Component_Associations (Inits));
15671 while Present (Init) loop
15672 Check_SPARK_Initialized_State (Init);
15678 end Check_SPARK_Initialized_States;
15682 Pack_Body : constant Node_Id := Find_Related_Package_Or_Body (Prag);
15684 -- Start of processing for Process_SPARK_Refined_State_Pragma
15687 -- Pragma Refined_State must be associated with a package body
15690 (Present (Pack_Body) and then Nkind (Pack_Body) = N_Package_Body);
15692 -- Verify that each external contitunent of an abstract state
15693 -- mentioned in pragma Initializes is properly elaborated.
15695 Check_SPARK_Initialized_States (Unique_Defining_Entity (Pack_Body));
15696 end Process_SPARK_Refined_State_Pragma;
15697 end SPARK_Processor;
15699 -------------------------------
15700 -- Spec_And_Body_From_Entity --
15701 -------------------------------
15703 procedure Spec_And_Body_From_Entity
15705 Spec_Decl : out Node_Id;
15706 Body_Decl : out Node_Id)
15709 Spec_And_Body_From_Node
15710 (N => Unit_Declaration_Node (Id),
15711 Spec_Decl => Spec_Decl,
15712 Body_Decl => Body_Decl);
15713 end Spec_And_Body_From_Entity;
15715 -----------------------------
15716 -- Spec_And_Body_From_Node --
15717 -----------------------------
15719 procedure Spec_And_Body_From_Node
15721 Spec_Decl : out Node_Id;
15722 Body_Decl : out Node_Id)
15724 Body_Id : Entity_Id;
15725 Spec_Id : Entity_Id;
15728 -- Assume that the construct lacks spec and body
15730 Body_Decl := Empty;
15731 Spec_Decl := Empty;
15735 if Nkind_In (N, N_Package_Body,
15740 Spec_Id := Corresponding_Spec (N);
15742 -- The body completes a previous declaration
15744 if Present (Spec_Id) then
15745 Spec_Decl := Unit_Declaration_Node (Spec_Id);
15747 -- Otherwise the body acts as the initial declaration, and is both a
15748 -- spec and body. There is no need to look for an optional body.
15758 elsif Nkind_In (N, N_Entry_Declaration,
15759 N_Generic_Package_Declaration,
15760 N_Generic_Subprogram_Declaration,
15761 N_Package_Declaration,
15762 N_Protected_Type_Declaration,
15763 N_Subprogram_Declaration,
15764 N_Task_Type_Declaration)
15768 -- Expression function
15770 elsif Nkind (N) = N_Expression_Function then
15771 Spec_Id := Corresponding_Spec (N);
15772 pragma Assert (Present (Spec_Id));
15774 Spec_Decl := Unit_Declaration_Node (Spec_Id);
15778 elsif Nkind (N) in N_Generic_Instantiation then
15779 Spec_Decl := Instance_Spec (N);
15780 pragma Assert (Present (Spec_Decl));
15784 elsif Nkind (N) in N_Body_Stub then
15785 Spec_Id := Corresponding_Spec_Of_Stub (N);
15787 -- The stub completes a previous declaration
15789 if Present (Spec_Id) then
15790 Spec_Decl := Unit_Declaration_Node (Spec_Id);
15792 -- Otherwise the stub acts as a spec
15799 -- Obtain an optional or mandatory body
15801 if Present (Spec_Decl) then
15802 Body_Id := Corresponding_Body (Spec_Decl);
15804 if Present (Body_Id) then
15805 Body_Decl := Unit_Declaration_Node (Body_Id);
15808 end Spec_And_Body_From_Node;
15810 -------------------------------
15811 -- Static_Elaboration_Checks --
15812 -------------------------------
15814 function Static_Elaboration_Checks return Boolean is
15816 return not Dynamic_Elaboration_Checks;
15817 end Static_Elaboration_Checks;
15823 function Unit_Entity (Unit_Id : Entity_Id) return Entity_Id is
15824 function Is_Subunit (Id : Entity_Id) return Boolean;
15825 pragma Inline (Is_Subunit);
15826 -- Determine whether the entity of an initial declaration denotes a
15833 function Is_Subunit (Id : Entity_Id) return Boolean is
15834 Decl : constant Node_Id := Unit_Declaration_Node (Id);
15838 Nkind_In (Decl, N_Generic_Package_Declaration,
15839 N_Generic_Subprogram_Declaration,
15840 N_Package_Declaration,
15841 N_Protected_Type_Declaration,
15842 N_Subprogram_Declaration,
15843 N_Task_Type_Declaration)
15844 and then Present (Corresponding_Body (Decl))
15845 and then Nkind (Parent (Unit_Declaration_Node
15846 (Corresponding_Body (Decl)))) = N_Subunit;
15853 -- Start of processing for Unit_Entity
15856 Id := Unique_Entity (Unit_Id);
15858 -- Skip all subunits found in the scope chain which ends at the input
15861 while Is_Subunit (Id) loop
15868 ---------------------------------
15869 -- Update_Elaboration_Scenario --
15870 ---------------------------------
15872 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is
15874 -- Nothing to do when the elaboration phase of the compiler is not
15877 if not Elaboration_Phase_Active then
15880 -- Nothing to do when the old and new scenarios are one and the same
15882 elsif Old_N = New_N then
15886 -- A scenario is being transformed by Atree.Rewrite. Update all relevant
15887 -- internal data structures to reflect this change. This ensures that a
15888 -- potential run-time conditional ABE check or a guaranteed ABE failure
15889 -- is inserted at the proper place in the tree.
15891 if Is_Scenario (Old_N) then
15892 Replace_Scenario (Old_N, New_N);
15894 end Update_Elaboration_Scenario;
15896 ---------------------------------------------------------------------------
15898 -- 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 --
15900 -- M E C H A N I S M --
15902 ---------------------------------------------------------------------------
15904 -- This section contains the implementation of the pre-18.x legacy ABE
15905 -- mechanism. The mechanism can be activated using switch -gnatH (legacy
15906 -- elaboration checking mode enabled).
15908 -----------------------------
15909 -- Description of Approach --
15910 -----------------------------
15912 -- Every non-static call that is encountered by Sem_Res results in a call
15913 -- to Check_Elab_Call, with N being the call node, and Outer set to its
15914 -- default value of True. In addition X'Access is treated like a call
15915 -- for the access-to-procedure case, and in SPARK mode only we also
15916 -- check variable references.
15918 -- The goal of Check_Elab_Call is to determine whether or not the reference
15919 -- in question can generate an access before elaboration error (raising
15920 -- Program_Error) either by directly calling a subprogram whose body
15921 -- has not yet been elaborated, or indirectly, by calling a subprogram
15922 -- whose body has been elaborated, but which contains a call to such a
15925 -- In addition, in SPARK mode, we are checking for a variable reference in
15926 -- another package, which requires an explicit Elaborate_All pragma.
15928 -- The only references that we need to look at the outer level are
15929 -- references that occur in elaboration code. There are two cases. The
15930 -- reference can be at the outer level of elaboration code, or it can
15931 -- be within another unit, e.g. the elaboration code of a subprogram.
15933 -- In the case of an elaboration call at the outer level, we must trace
15934 -- all calls to outer level routines either within the current unit or to
15935 -- other units that are with'ed. For calls within the current unit, we can
15936 -- determine if the body has been elaborated or not, and if it has not,
15937 -- then a warning is generated.
15939 -- Note that there are two subcases. If the original call directly calls a
15940 -- subprogram whose body has not been elaborated, then we know that an ABE
15941 -- will take place, and we replace the call by a raise of Program_Error.
15942 -- If the call is indirect, then we don't know that the PE will be raised,
15943 -- since the call might be guarded by a conditional. In this case we set
15944 -- Do_Elab_Check on the call so that a dynamic check is generated, and
15945 -- output a warning.
15947 -- For calls to a subprogram in a with'ed unit or a 'Access or variable
15948 -- reference (SPARK mode case), we require that a pragma Elaborate_All
15949 -- or pragma Elaborate be present, or that the referenced unit have a
15950 -- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
15951 -- of these conditions is met, then a warning is generated that a pragma
15952 -- Elaborate_All may be needed (error in the SPARK case), or an implicit
15953 -- pragma is generated.
15955 -- For the case of an elaboration call at some inner level, we are
15956 -- interested in tracing only calls to subprograms at the same level, i.e.
15957 -- those that can be called during elaboration. Any calls to outer level
15958 -- routines cannot cause ABE's as a result of the original call (there
15959 -- might be an outer level call to the subprogram from outside that causes
15960 -- the ABE, but that gets analyzed separately).
15962 -- Note that we never trace calls to inner level subprograms, since these
15963 -- cannot result in ABE's unless there is an elaboration problem at a lower
15964 -- level, which will be separately detected.
15966 -- Note on pragma Elaborate. The checking here assumes that a pragma
15967 -- Elaborate on a with'ed unit guarantees that subprograms within the unit
15968 -- can be called without causing an ABE. This is not in fact the case since
15969 -- pragma Elaborate does not guarantee the transitive coverage guaranteed
15970 -- by Elaborate_All. However, we decide to trust the user in this case.
15972 --------------------------------------
15973 -- Instantiation Elaboration Errors --
15974 --------------------------------------
15976 -- A special case arises when an instantiation appears in a context that is
15977 -- known to be before the body is elaborated, e.g.
15979 -- generic package x is ...
15981 -- package xx is new x;
15983 -- package body x is ...
15985 -- In this situation it is certain that an elaboration error will occur,
15986 -- and an unconditional raise Program_Error statement is inserted before
15987 -- the instantiation, and a warning generated.
15989 -- The problem is that in this case we have no place to put the body of
15990 -- the instantiation. We can't put it in the normal place, because it is
15991 -- too early, and will cause errors to occur as a result of referencing
15992 -- entities before they are declared.
15994 -- Our approach in this case is simply to avoid creating the body of the
15995 -- instantiation in such a case. The instantiation spec is modified to
15996 -- include dummy bodies for all subprograms, so that the resulting code
15997 -- does not contain subprogram specs with no corresponding bodies.
15999 -- The following table records the recursive call chain for output in the
16000 -- Output routine. Each entry records the call node and the entity of the
16001 -- called routine. The number of entries in the table (i.e. the value of
16002 -- Elab_Call.Last) indicates the current depth of recursion and is used to
16003 -- identify the outer level.
16005 type Elab_Call_Element is record
16010 package Elab_Call is new Table.Table
16011 (Table_Component_Type => Elab_Call_Element,
16012 Table_Index_Type => Int,
16013 Table_Low_Bound => 1,
16014 Table_Initial => 50,
16015 Table_Increment => 100,
16016 Table_Name => "Elab_Call");
16018 -- The following table records all calls that have been processed starting
16019 -- from an outer level call. The table prevents both infinite recursion and
16020 -- useless reanalysis of calls within the same context. The use of context
16021 -- is important because it allows for proper checks in more complex code:
16024 -- Call; -- requires a check
16025 -- Call; -- does not need a check thanks to the table
16027 -- Call; -- requires a check, different context
16030 -- Call; -- requires a check, different context
16032 type Visited_Element is record
16033 Subp_Id : Entity_Id;
16034 -- The entity of the subprogram being called
16037 -- The context where the call to the subprogram occurs
16040 package Elab_Visited is new Table.Table
16041 (Table_Component_Type => Visited_Element,
16042 Table_Index_Type => Int,
16043 Table_Low_Bound => 1,
16044 Table_Initial => 200,
16045 Table_Increment => 100,
16046 Table_Name => "Elab_Visited");
16048 -- The following table records delayed calls which must be examined after
16049 -- all generic bodies have been instantiated.
16051 type Delay_Element is record
16053 -- The parameter N from the call to Check_Internal_Call. Note that this
16054 -- node may get rewritten over the delay period by expansion in the call
16055 -- case (but not in the instantiation case).
16058 -- The parameter E from the call to Check_Internal_Call
16060 Orig_Ent : Entity_Id;
16061 -- The parameter Orig_Ent from the call to Check_Internal_Call
16063 Curscop : Entity_Id;
16064 -- The current scope of the call. This is restored when we complete the
16065 -- delayed call, so that we do this in the right scope.
16067 Outer_Scope : Entity_Id;
16068 -- Save scope of outer level call
16070 From_Elab_Code : Boolean;
16071 -- Save indication of whether this call is from elaboration code
16073 In_Task_Activation : Boolean;
16074 -- Save indication of whether this call is from a task body. Tasks are
16075 -- activated at the "begin", which is after all local procedure bodies,
16076 -- so calls to those procedures can't fail, even if they occur after the
16079 From_SPARK_Code : Boolean;
16080 -- Save indication of whether this call is under SPARK_Mode => On
16083 package Delay_Check is new Table.Table
16084 (Table_Component_Type => Delay_Element,
16085 Table_Index_Type => Int,
16086 Table_Low_Bound => 1,
16087 Table_Initial => 1000,
16088 Table_Increment => 100,
16089 Table_Name => "Delay_Check");
16091 C_Scope : Entity_Id;
16092 -- Top-level scope of current scope. Compute this only once at the outer
16093 -- level, i.e. for a call to Check_Elab_Call from outside this unit.
16095 Outer_Level_Sloc : Source_Ptr;
16096 -- Save Sloc value for outer level call node for comparisons of source
16097 -- locations. A body is too late if it appears after the *outer* level
16098 -- call, not the particular call that is being analyzed.
16100 From_Elab_Code : Boolean;
16101 -- This flag shows whether the outer level call currently being examined
16102 -- is or is not in elaboration code. We are only interested in calls to
16103 -- routines in other units if this flag is True.
16105 In_Task_Activation : Boolean := False;
16106 -- This flag indicates whether we are performing elaboration checks on task
16107 -- bodies, at the point of activation. If true, we do not raise
16108 -- Program_Error for calls to local procedures, because all local bodies
16109 -- are known to be elaborated. However, we still need to trace such calls,
16110 -- because a local procedure could call a procedure in another package,
16111 -- so we might need an implicit Elaborate_All.
16113 Delaying_Elab_Checks : Boolean := True;
16114 -- This is set True till the compilation is complete, including the
16115 -- insertion of all instance bodies. Then when Check_Elab_Calls is called,
16116 -- the delay table is used to make the delayed calls and this flag is reset
16117 -- to False, so that the calls are processed.
16119 -----------------------
16120 -- Local Subprograms --
16121 -----------------------
16123 -- Note: Outer_Scope in all following specs represents the scope of
16124 -- interest of the outer level call. If it is set to Standard_Standard,
16125 -- then it means the outer level call was at elaboration level, and that
16126 -- thus all calls are of interest. If it was set to some other scope,
16127 -- then the original call was an inner call, and we are not interested
16128 -- in calls that go outside this scope.
16130 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id);
16131 -- Analysis of construct N shows that we should set Elaborate_All_Desirable
16132 -- for the WITH clause for unit U (which will always be present). A special
16133 -- case is when N is a function or procedure instantiation, in which case
16134 -- it is sufficient to set Elaborate_Desirable, since in this case there is
16135 -- no possibility of transitive elaboration issues.
16137 procedure Check_A_Call
16140 Outer_Scope : Entity_Id;
16141 Inter_Unit_Only : Boolean;
16142 Generate_Warnings : Boolean := True;
16143 In_Init_Proc : Boolean := False);
16144 -- This is the internal recursive routine that is called to check for
16145 -- possible elaboration error. The argument N is a subprogram call or
16146 -- generic instantiation, or 'Access attribute reference to be checked, and
16147 -- E is the entity of the called subprogram, or instantiated generic unit,
16148 -- or subprogram referenced by 'Access.
16150 -- In SPARK mode, N can also be a variable reference, since in SPARK this
16151 -- also triggers a requirement for Elaborate_All, and in this case E is the
16152 -- entity being referenced.
16154 -- Outer_Scope is the outer level scope for the original reference.
16155 -- Inter_Unit_Only is set if the call is only to be checked in the
16156 -- case where it is to another unit (and skipped if within a unit).
16157 -- Generate_Warnings is set to False to suppress warning messages about
16158 -- missing pragma Elaborate_All's. These messages are not wanted for
16159 -- inner calls in the dynamic model. Note that an instance of the Access
16160 -- attribute applied to a subprogram also generates a call to this
16161 -- procedure (since the referenced subprogram may be called later
16162 -- indirectly). Flag In_Init_Proc should be set whenever the current
16163 -- context is a type init proc.
16165 -- Note: this might better be called Check_A_Reference to recognize the
16166 -- variable case for SPARK, but we prefer to retain the historical name
16167 -- since in practice this is mostly about checking calls for the possible
16168 -- occurrence of an access-before-elaboration exception.
16170 procedure Check_Bad_Instantiation (N : Node_Id);
16171 -- N is a node for an instantiation (if called with any other node kind,
16172 -- Check_Bad_Instantiation ignores the call). This subprogram checks for
16173 -- the special case of a generic instantiation of a generic spec in the
16174 -- same declarative part as the instantiation where a body is present and
16175 -- has not yet been seen. This is an obvious error, but needs to be checked
16176 -- specially at the time of the instantiation, since it is a case where we
16177 -- cannot insert the body anywhere. If this case is detected, warnings are
16178 -- generated, and a raise of Program_Error is inserted. In addition any
16179 -- subprograms in the generic spec are stubbed, and the Bad_Instantiation
16180 -- flag is set on the instantiation node. The caller in Sem_Ch12 uses this
16181 -- flag as an indication that no attempt should be made to insert an
16184 procedure Check_Internal_Call
16187 Outer_Scope : Entity_Id;
16188 Orig_Ent : Entity_Id);
16189 -- N is a function call or procedure statement call node and E is the
16190 -- entity of the called function, which is within the current compilation
16191 -- unit (where subunits count as part of the parent). This call checks if
16192 -- this call, or any call within any accessed body could cause an ABE, and
16193 -- if so, outputs a warning. Orig_Ent differs from E only in the case of
16194 -- renamings, and points to the original name of the entity. This is used
16195 -- for error messages. Outer_Scope is the outer level scope for the
16198 procedure Check_Internal_Call_Continue
16201 Outer_Scope : Entity_Id;
16202 Orig_Ent : Entity_Id);
16203 -- The processing for Check_Internal_Call is divided up into two phases,
16204 -- and this represents the second phase. The second phase is delayed if
16205 -- Delaying_Elab_Checks is set to True. In this delayed case, the first
16206 -- phase makes an entry in the Delay_Check table, which is processed when
16207 -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to
16208 -- Check_Internal_Call. Outer_Scope is the outer level scope for the
16211 function Get_Referenced_Ent (N : Node_Id) return Entity_Id;
16212 -- N is either a function or procedure call or an access attribute that
16213 -- references a subprogram. This call retrieves the relevant entity. If
16214 -- this is a call to a protected subprogram, the entity is a selected
16215 -- component. The callable entity may be absent, in which case Empty is
16216 -- returned. This happens with non-analyzed calls in nested generics.
16218 -- If SPARK_Mode is On, then N can also be a reference to an E_Variable
16219 -- entity, in which case, the value returned is simply this entity.
16221 function Has_Generic_Body (N : Node_Id) return Boolean;
16222 -- N is a generic package instantiation node, and this routine determines
16223 -- if this package spec does in fact have a generic body. If so, then
16224 -- True is returned, otherwise False. Note that this is not at all the
16225 -- same as checking if the unit requires a body, since it deals with
16226 -- the case of optional bodies accurately (i.e. if a body is optional,
16227 -- then it looks to see if a body is actually present). Note: this
16228 -- function can only do a fully correct job if in generating code mode
16229 -- where all bodies have to be present. If we are operating in semantics
16230 -- check only mode, then in some cases of optional bodies, a result of
16231 -- False may incorrectly be given. In practice this simply means that
16232 -- some cases of warnings for incorrect order of elaboration will only
16233 -- be given when generating code, which is not a big problem (and is
16234 -- inevitable, given the optional body semantics of Ada).
16236 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty);
16237 -- Given code for an elaboration check (or unconditional raise if the check
16238 -- is not needed), inserts the code in the appropriate place. N is the call
16239 -- or instantiation node for which the check code is required. C is the
16240 -- test whose failure triggers the raise.
16242 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean;
16243 -- Returns True if node N is a call to a generic formal subprogram
16245 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean;
16246 -- Determine whether entity Id denotes a [Deep_]Finalize procedure
16248 procedure Output_Calls
16250 Check_Elab_Flag : Boolean);
16251 -- Outputs chain of calls stored in the Elab_Call table. The caller has
16252 -- already generated the main warning message, so the warnings generated
16253 -- are all continuation messages. The argument is the call node at which
16254 -- the messages are to be placed. When Check_Elab_Flag is set, calls are
16255 -- enumerated only when flag Elab_Warning is set for the dynamic case or
16256 -- when flag Elab_Info_Messages is set for the static case.
16258 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean;
16259 -- Given two scopes, determine whether they are the same scope from an
16260 -- elaboration point of view, i.e. packages and blocks are ignored.
16262 procedure Set_C_Scope;
16263 -- On entry C_Scope is set to some scope. On return, C_Scope is reset
16264 -- to be the enclosing compilation unit of this scope.
16266 procedure Set_Elaboration_Constraint
16270 -- The current unit U may depend semantically on some unit P that is not
16271 -- in the current context. If there is an elaboration call that reaches P,
16272 -- we need to indicate that P requires an Elaborate_All, but this is not
16273 -- effective in U's ali file, if there is no with_clause for P. In this
16274 -- case we add the Elaborate_All on the unit Q that directly or indirectly
16275 -- makes P available. This can happen in two cases:
16277 -- a) Q declares a subtype of a type declared in P, and the call is an
16278 -- initialization call for an object of that subtype.
16280 -- b) Q declares an object of some tagged type whose root type is
16281 -- declared in P, and the initialization call uses object notation on
16282 -- that object to reach a primitive operation or a classwide operation
16285 -- If P appears in the context of U, the current processing is correct.
16286 -- Otherwise we must identify these two cases to retrieve Q and place the
16287 -- Elaborate_All_Desirable on it.
16289 function Spec_Entity (E : Entity_Id) return Entity_Id;
16290 -- Given a compilation unit entity, if it is a spec entity, it is returned
16291 -- unchanged. If it is a body entity, then the spec for the corresponding
16292 -- spec is returned
16294 function Within (E1, E2 : Entity_Id) return Boolean;
16295 -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
16296 -- of its contained scopes, False otherwise.
16298 function Within_Elaborate_All
16299 (Unit : Unit_Number_Type;
16300 E : Entity_Id) return Boolean;
16301 -- Return True if we are within the scope of an Elaborate_All for E, or if
16302 -- we are within the scope of an Elaborate_All for some other unit U, and U
16303 -- with's E. This prevents spurious warnings when the called entity is
16304 -- renamed within U, or in case of generic instances.
16306 --------------------------------------
16307 -- Activate_Elaborate_All_Desirable --
16308 --------------------------------------
16310 procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is
16311 UN : constant Unit_Number_Type := Get_Code_Unit (N);
16312 CU : constant Node_Id := Cunit (UN);
16313 UE : constant Entity_Id := Cunit_Entity (UN);
16314 Unm : constant Unit_Name_Type := Unit_Name (UN);
16315 CI : constant List_Id := Context_Items (CU);
16319 procedure Add_To_Context_And_Mark (Itm : Node_Id);
16320 -- This procedure is called when the elaborate indication must be
16321 -- applied to a unit not in the context of the referencing unit. The
16322 -- unit gets added to the context as an implicit with.
16324 function In_Withs_Of (UEs : Entity_Id) return Boolean;
16325 -- UEs is the spec entity of a unit. If the unit to be marked is
16326 -- in the context item list of this unit spec, then the call returns
16327 -- True and Itm is left set to point to the relevant N_With_Clause node.
16329 procedure Set_Elab_Flag (Itm : Node_Id);
16330 -- Sets Elaborate_[All_]Desirable as appropriate on Itm
16332 -----------------------------
16333 -- Add_To_Context_And_Mark --
16334 -----------------------------
16336 procedure Add_To_Context_And_Mark (Itm : Node_Id) is
16337 CW : constant Node_Id :=
16338 Make_With_Clause (Sloc (Itm),
16339 Name => Name (Itm));
16342 Set_Library_Unit (CW, Library_Unit (Itm));
16343 Set_Implicit_With (CW);
16345 -- Set elaborate all desirable on copy and then append the copy to
16346 -- the list of body with's and we are done.
16348 Set_Elab_Flag (CW);
16349 Append_To (CI, CW);
16350 end Add_To_Context_And_Mark;
16356 function In_Withs_Of (UEs : Entity_Id) return Boolean is
16357 UNs : constant Unit_Number_Type := Get_Source_Unit (UEs);
16358 CUs : constant Node_Id := Cunit (UNs);
16359 CIs : constant List_Id := Context_Items (CUs);
16362 Itm := First (CIs);
16363 while Present (Itm) loop
16364 if Nkind (Itm) = N_With_Clause then
16366 Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
16379 -------------------
16380 -- Set_Elab_Flag --
16381 -------------------
16383 procedure Set_Elab_Flag (Itm : Node_Id) is
16385 if Nkind (N) in N_Subprogram_Instantiation then
16386 Set_Elaborate_Desirable (Itm);
16388 Set_Elaborate_All_Desirable (Itm);
16392 -- Start of processing for Activate_Elaborate_All_Desirable
16395 -- Do not set binder indication if expansion is disabled, as when
16396 -- compiling a generic unit.
16398 if not Expander_Active then
16402 -- If an instance of a generic package contains a controlled object (so
16403 -- we're calling Initialize at elaboration time), and the instance is in
16404 -- a package body P that says "with P;", then we need to return without
16405 -- adding "pragma Elaborate_All (P);" to P.
16407 if U = Main_Unit_Entity then
16412 while Present (Itm) loop
16413 if Nkind (Itm) = N_With_Clause then
16414 Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
16416 -- If we find it, then mark elaborate all desirable and return
16419 Set_Elab_Flag (Itm);
16427 -- If we fall through then the with clause is not present in the
16428 -- current unit. One legitimate possibility is that the with clause
16429 -- is present in the spec when we are a body.
16431 if Is_Body_Name (Unm)
16432 and then In_Withs_Of (Spec_Entity (UE))
16434 Add_To_Context_And_Mark (Itm);
16438 -- Similarly, we may be in the spec or body of a child unit, where
16439 -- the unit in question is with'ed by some ancestor of the child unit.
16441 if Is_Child_Name (Unm) then
16448 Pkg := Scope (Pkg);
16449 exit when Pkg = Standard_Standard;
16451 if In_Withs_Of (Pkg) then
16452 Add_To_Context_And_Mark (Itm);
16459 -- Here if we do not find with clause on spec or body. We just ignore
16460 -- this case; it means that the elaboration involves some other unit
16461 -- than the unit being compiled, and will be caught elsewhere.
16462 end Activate_Elaborate_All_Desirable;
16468 procedure Check_A_Call
16471 Outer_Scope : Entity_Id;
16472 Inter_Unit_Only : Boolean;
16473 Generate_Warnings : Boolean := True;
16474 In_Init_Proc : Boolean := False)
16476 Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
16477 -- Indicates if we have Access attribute case
16479 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean;
16480 -- True if we're calling an instance of a generic subprogram, or a
16481 -- subprogram in an instance of a generic package, and the call is
16482 -- outside that instance.
16484 procedure Elab_Warning
16487 Ent : Node_Or_Entity_Id);
16488 -- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
16489 -- dynamic or static elaboration model), N and Ent. Msg_D is a real
16490 -- warning (output if Msg_D is non-null and Elab_Warnings is set),
16491 -- Msg_S is an info message (output if Elab_Info_Messages is set).
16493 function Find_W_Scope return Entity_Id;
16494 -- Find top-level scope for called entity (not following renamings
16495 -- or derivations). This is where the Elaborate_All will go if it is
16496 -- needed. We start with the called entity, except in the case of an
16497 -- initialization procedure outside the current package, where the init
16498 -- proc is in the root package, and we start from the entity of the name
16501 -----------------------------------
16502 -- Call_To_Instance_From_Outside --
16503 -----------------------------------
16505 function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is
16506 Scop : Entity_Id := Id;
16510 if Scop = Standard_Standard then
16514 if Is_Generic_Instance (Scop) then
16515 return not In_Open_Scopes (Scop);
16518 Scop := Scope (Scop);
16520 end Call_To_Instance_From_Outside;
16526 procedure Elab_Warning
16529 Ent : Node_Or_Entity_Id)
16532 -- Dynamic elaboration checks, real warning
16534 if Dynamic_Elaboration_Checks then
16535 if not Access_Case then
16536 if Msg_D /= "" and then Elab_Warnings then
16537 Error_Msg_NE (Msg_D, N, Ent);
16540 -- In the access case emit first warning message as well,
16541 -- otherwise list of calls will appear as errors.
16543 elsif Elab_Warnings then
16544 Error_Msg_NE (Msg_S, N, Ent);
16547 -- Static elaboration checks, info message
16550 if Elab_Info_Messages then
16551 Error_Msg_NE (Msg_S, N, Ent);
16560 function Find_W_Scope return Entity_Id is
16561 Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N);
16562 W_Scope : Entity_Id;
16565 if Is_Init_Proc (Refed_Ent)
16566 and then not In_Same_Extended_Unit (N, Refed_Ent)
16568 W_Scope := Scope (Refed_Ent);
16573 -- Now loop through scopes to get to the enclosing compilation unit
16575 while not Is_Compilation_Unit (W_Scope) loop
16576 W_Scope := Scope (W_Scope);
16584 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
16585 -- Indicates if we have instantiation case
16587 Loc : constant Source_Ptr := Sloc (N);
16589 Variable_Case : constant Boolean :=
16590 Nkind (N) in N_Has_Entity
16591 and then Present (Entity (N))
16592 and then Ekind (Entity (N)) = E_Variable;
16593 -- Indicates if we have variable reference case
16595 W_Scope : constant Entity_Id := Find_W_Scope;
16596 -- Top-level scope of directly called entity for subprogram. This
16597 -- differs from E_Scope in the case where renamings or derivations
16598 -- are involved, since it does not follow these links. W_Scope is
16599 -- generally in a visible unit, and it is this scope that may require
16600 -- an Elaborate_All. However, there are some cases (initialization
16601 -- calls and calls involving object notation) where W_Scope might not
16602 -- be in the context of the current unit, and there is an intermediate
16603 -- package that is, in which case the Elaborate_All has to be placed
16604 -- on this intermediate package. These special cases are handled in
16605 -- Set_Elaboration_Constraint.
16608 Callee_Unit_Internal : Boolean;
16609 Caller_Unit_Internal : Boolean;
16611 Inst_Callee : Source_Ptr;
16612 Inst_Caller : Source_Ptr;
16613 Unit_Callee : Unit_Number_Type;
16614 Unit_Caller : Unit_Number_Type;
16616 Body_Acts_As_Spec : Boolean;
16617 -- Set to true if call is to body acting as spec (no separate spec)
16619 Cunit_SC : Boolean := False;
16620 -- Set to suppress dynamic elaboration checks where one of the
16621 -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
16622 -- if a pragma Elaborate[_All] applies to that scope, in which case
16623 -- warnings on the scope are also suppressed. For the internal case,
16624 -- we ignore this flag.
16626 E_Scope : Entity_Id;
16627 -- Top-level scope of entity for called subprogram. This value includes
16628 -- following renamings and derivations, so this scope can be in a
16629 -- non-visible unit. This is the scope that is to be investigated to
16630 -- see whether an elaboration check is required.
16633 -- Flag set when the subprogram being invoked is the procedure generated
16634 -- for pragma Default_Initial_Condition.
16636 SPARK_Elab_Errors : Boolean;
16637 -- Flag set when an entity is called or a variable is read during SPARK
16638 -- dynamic elaboration.
16640 -- Start of processing for Check_A_Call
16643 -- If the call is known to be within a local Suppress Elaboration
16644 -- pragma, nothing to check. This can happen in task bodies. But
16645 -- we ignore this for a call to a generic formal.
16647 if Nkind (N) in N_Subprogram_Call
16648 and then No_Elaboration_Check (N)
16649 and then not Is_Call_Of_Generic_Formal (N)
16653 -- If this is a rewrite of a Valid_Scalars attribute, then nothing to
16654 -- check, we don't mind in this case if the call occurs before the body
16655 -- since this is all generated code.
16657 elsif Nkind (Original_Node (N)) = N_Attribute_Reference
16658 and then Attribute_Name (Original_Node (N)) = Name_Valid_Scalars
16662 -- Intrinsics such as instances of Unchecked_Deallocation do not have
16663 -- any body, so elaboration checking is not needed, and would be wrong.
16665 elsif Is_Intrinsic_Subprogram (E) then
16668 -- Do not consider references to internal variables for SPARK semantics
16670 elsif Variable_Case and then not Comes_From_Source (E) then
16674 -- Proceed with check
16678 -- For a variable reference, just set Body_Acts_As_Spec to False
16680 if Variable_Case then
16681 Body_Acts_As_Spec := False;
16683 -- Additional checks for all other cases
16686 -- Go to parent for derived subprogram, or to original subprogram in
16687 -- the case of a renaming (Alias covers both these cases).
16690 if (Suppress_Elaboration_Warnings (Ent)
16691 or else Elaboration_Checks_Suppressed (Ent))
16692 and then (Inst_Case or else No (Alias (Ent)))
16697 -- Nothing to do for imported entities
16699 if Is_Imported (Ent) then
16703 exit when Inst_Case or else No (Alias (Ent));
16704 Ent := Alias (Ent);
16707 Decl := Unit_Declaration_Node (Ent);
16709 if Nkind (Decl) = N_Subprogram_Body then
16710 Body_Acts_As_Spec := True;
16712 elsif Nkind_In (Decl, N_Subprogram_Declaration,
16713 N_Subprogram_Body_Stub)
16716 Body_Acts_As_Spec := False;
16718 -- If we have none of an instantiation, subprogram body or subprogram
16719 -- declaration, or in the SPARK case, a variable reference, then
16720 -- it is not a case that we want to check. (One case is a call to a
16721 -- generic formal subprogram, where we do not want the check in the
16731 if Elaboration_Checks_Suppressed (E_Scope)
16732 or else Suppress_Elaboration_Warnings (E_Scope)
16737 -- Exit when we get to compilation unit, not counting subunits
16739 exit when Is_Compilation_Unit (E_Scope)
16740 and then (Is_Child_Unit (E_Scope)
16741 or else Scope (E_Scope) = Standard_Standard);
16743 pragma Assert (E_Scope /= Standard_Standard);
16745 -- Move up a scope looking for compilation unit
16747 E_Scope := Scope (E_Scope);
16750 -- No checks needed for pure or preelaborated compilation units
16752 if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then
16756 -- If the generic entity is within a deeper instance than we are, then
16757 -- either the instantiation to which we refer itself caused an ABE, in
16758 -- which case that will be handled separately, or else we know that the
16759 -- body we need appears as needed at the point of the instantiation.
16760 -- However, this assumption is only valid if we are in static mode.
16762 if not Dynamic_Elaboration_Checks
16764 Instantiation_Depth (Sloc (Ent)) > Instantiation_Depth (Sloc (N))
16769 -- Do not give a warning for a package with no body
16771 if Ekind (Ent) = E_Generic_Package and then not Has_Generic_Body (N) then
16775 -- Case of entity is in same unit as call or instantiation. In the
16776 -- instantiation case, W_Scope may be different from E_Scope; we want
16777 -- the unit in which the instantiation occurs, since we're analyzing
16778 -- based on the expansion.
16780 if W_Scope = C_Scope then
16781 if not Inter_Unit_Only then
16782 Check_Internal_Call (N, Ent, Outer_Scope, E);
16788 -- Case of entity is not in current unit (i.e. with'ed unit case)
16790 -- We are only interested in such calls if the outer call was from
16791 -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode.
16793 if not From_Elab_Code and then not Dynamic_Elaboration_Checks then
16797 -- Nothing to do if some scope said that no checks were required
16803 -- Nothing to do for a generic instance, because a call to an instance
16804 -- cannot fail the elaboration check, because the body of the instance
16805 -- is always elaborated immediately after the spec.
16807 if Call_To_Instance_From_Outside (Ent) then
16811 -- Nothing to do if subprogram with no separate spec. However, a call
16812 -- to Deep_Initialize may result in a call to a user-defined Initialize
16813 -- procedure, which imposes a body dependency. This happens only if the
16814 -- type is controlled and the Initialize procedure is not inherited.
16816 if Body_Acts_As_Spec then
16817 if Is_TSS (Ent, TSS_Deep_Initialize) then
16819 Typ : constant Entity_Id := Etype (First_Formal (Ent));
16823 if not Is_Controlled (Typ) then
16826 Init := Find_Prim_Op (Typ, Name_Initialize);
16828 if Comes_From_Source (Init) then
16841 -- Check cases of internal units
16843 Callee_Unit_Internal := In_Internal_Unit (E_Scope);
16845 -- Do not give a warning if the with'ed unit is internal and this is
16846 -- the generic instantiation case (this saves a lot of hassle dealing
16847 -- with the Text_IO special child units)
16849 if Callee_Unit_Internal and Inst_Case then
16853 if C_Scope = Standard_Standard then
16854 Caller_Unit_Internal := False;
16856 Caller_Unit_Internal := In_Internal_Unit (C_Scope);
16859 -- Do not give a warning if the with'ed unit is internal and the caller
16860 -- is not internal (since the binder always elaborates internal units
16863 if Callee_Unit_Internal and not Caller_Unit_Internal then
16867 -- For now, if debug flag -gnatdE is not set, do no checking for one
16868 -- internal unit withing another. This fixes the problem with the sgi
16869 -- build and storage errors. To be resolved later ???
16871 if (Callee_Unit_Internal and Caller_Unit_Internal)
16872 and not Debug_Flag_EE
16877 if Is_TSS (E, TSS_Deep_Initialize) then
16881 -- If the call is in an instance, and the called entity is not
16882 -- defined in the same instance, then the elaboration issue focuses
16883 -- around the unit containing the template, it is this unit that
16884 -- requires an Elaborate_All.
16886 -- However, if we are doing dynamic elaboration, we need to chase the
16887 -- call in the usual manner.
16889 -- We also need to chase the call in the usual manner if it is a call
16890 -- to a generic formal parameter, since that case was not handled as
16891 -- part of the processing of the template.
16893 Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N)));
16894 Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent)));
16896 if Inst_Caller = No_Location then
16897 Unit_Caller := No_Unit;
16899 Unit_Caller := Get_Source_Unit (N);
16902 if Inst_Callee = No_Location then
16903 Unit_Callee := No_Unit;
16905 Unit_Callee := Get_Source_Unit (Ent);
16908 if Unit_Caller /= No_Unit
16909 and then Unit_Callee /= Unit_Caller
16910 and then not Dynamic_Elaboration_Checks
16911 and then not Is_Call_Of_Generic_Formal (N)
16913 E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller));
16915 -- If we don't get a spec entity, just ignore call. Not quite
16916 -- clear why this check is necessary. ???
16918 if No (E_Scope) then
16922 -- Otherwise step to enclosing compilation unit
16924 while not Is_Compilation_Unit (E_Scope) loop
16925 E_Scope := Scope (E_Scope);
16928 -- For the case where N is not an instance, and is not a call within
16929 -- instance to other than a generic formal, we recompute E_Scope
16930 -- for the error message, since we do NOT want to go to the unit
16931 -- that has the ultimate declaration in the case of renaming and
16932 -- derivation and we also want to go to the generic unit in the
16933 -- case of an instance, and no further.
16936 -- Loop to carefully follow renamings and derivations one step
16937 -- outside the current unit, but not further.
16939 if not (Inst_Case or Variable_Case)
16940 and then Present (Alias (Ent))
16942 E_Scope := Alias (Ent);
16948 while not Is_Compilation_Unit (E_Scope) loop
16949 E_Scope := Scope (E_Scope);
16952 -- If E_Scope is the same as C_Scope, it means that there
16953 -- definitely was a local renaming or derivation, and we
16954 -- are not yet out of the current unit.
16956 exit when E_Scope /= C_Scope;
16957 Ent := Alias (Ent);
16960 -- If no alias, there could be a previous error, but not if we've
16961 -- already reached the outermost level (Standard).
16969 if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then
16973 -- Determine whether the Default_Initial_Condition procedure of some
16974 -- type is being invoked.
16976 Is_DIC := Ekind (Ent) = E_Procedure and then Is_DIC_Procedure (Ent);
16978 -- Checks related to Default_Initial_Condition fall under the SPARK
16979 -- umbrella because this is a SPARK-specific annotation.
16981 SPARK_Elab_Errors :=
16982 SPARK_Mode = On and (Is_DIC or Dynamic_Elaboration_Checks);
16984 -- Now check if an Elaborate_All (or dynamic check) is needed
16986 if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors)
16987 and then Generate_Warnings
16988 and then not Suppress_Elaboration_Warnings (Ent)
16989 and then not Elaboration_Checks_Suppressed (Ent)
16990 and then not Suppress_Elaboration_Warnings (E_Scope)
16991 and then not Elaboration_Checks_Suppressed (E_Scope)
16993 -- Instantiation case
16996 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then
16998 ("instantiation of & during elaboration in SPARK", N, Ent);
17001 ("instantiation of & may raise Program_Error?l?",
17002 "info: instantiation of & during elaboration?$?", Ent);
17005 -- Indirect call case, info message only in static elaboration
17006 -- case, because the attribute reference itself cannot raise an
17007 -- exception. Note that SPARK does not permit indirect calls.
17009 elsif Access_Case then
17010 Elab_Warning ("", "info: access to & during elaboration?$?", Ent);
17012 -- Variable reference in SPARK mode
17014 elsif Variable_Case then
17015 if Comes_From_Source (Ent) and then SPARK_Elab_Errors then
17017 ("reference to & during elaboration in SPARK", N, Ent);
17020 -- Subprogram call case
17023 if Nkind (Name (N)) in N_Has_Entity
17024 and then Is_Init_Proc (Entity (Name (N)))
17025 and then Comes_From_Source (Ent)
17028 ("implicit call to & may raise Program_Error?l?",
17029 "info: implicit call to & during elaboration?$?",
17032 elsif SPARK_Elab_Errors then
17034 -- Emit a specialized error message when the elaboration of an
17035 -- object of a private type evaluates the expression of pragma
17036 -- Default_Initial_Condition. This prevents the internal name
17037 -- of the procedure from appearing in the error message.
17041 ("call to Default_Initial_Condition during elaboration in "
17045 ("call to & during elaboration in SPARK", N, Ent);
17050 ("call to & may raise Program_Error?l?",
17051 "info: call to & during elaboration?$?",
17056 Error_Msg_Qual_Level := Nat'Last;
17058 -- Case of Elaborate_All not present and required, for SPARK this
17059 -- is an error, so give an error message.
17061 if SPARK_Elab_Errors then
17062 Error_Msg_NE -- CODEFIX
17063 ("\Elaborate_All pragma required for&", N, W_Scope);
17065 -- Otherwise we generate an implicit pragma. For a subprogram
17066 -- instantiation, Elaborate is good enough, since no transitive
17067 -- call is possible at elaboration time in this case.
17069 elsif Nkind (N) in N_Subprogram_Instantiation then
17071 ("\missing pragma Elaborate for&?l?",
17072 "\implicit pragma Elaborate for& generated?$?",
17075 -- For all other cases, we need an implicit Elaborate_All
17079 ("\missing pragma Elaborate_All for&?l?",
17080 "\implicit pragma Elaborate_All for & generated?$?",
17084 Error_Msg_Qual_Level := 0;
17086 -- Take into account the flags related to elaboration warning
17087 -- messages when enumerating the various calls involved. This
17088 -- ensures the proper pairing of the main warning and the
17089 -- clarification messages generated by Output_Calls.
17091 Output_Calls (N, Check_Elab_Flag => True);
17093 -- Set flag to prevent further warnings for same unit unless in
17094 -- All_Errors_Mode.
17096 if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
17097 Set_Suppress_Elaboration_Warnings (W_Scope);
17101 -- Check for runtime elaboration check required
17103 if Dynamic_Elaboration_Checks then
17104 if not Elaboration_Checks_Suppressed (Ent)
17105 and then not Elaboration_Checks_Suppressed (W_Scope)
17106 and then not Elaboration_Checks_Suppressed (E_Scope)
17107 and then not Cunit_SC
17109 -- Runtime elaboration check required. Generate check of the
17110 -- elaboration Boolean for the unit containing the entity.
17112 -- Note that for this case, we do check the real unit (the one
17113 -- from following renamings, since that is the issue).
17115 -- Could this possibly miss a useless but required PE???
17117 Insert_Elab_Check (N,
17118 Make_Attribute_Reference (Loc,
17119 Attribute_Name => Name_Elaborated,
17121 New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
17123 -- Prevent duplicate elaboration checks on the same call, which
17124 -- can happen if the body enclosing the call appears itself in a
17125 -- call whose elaboration check is delayed.
17127 if Nkind (N) in N_Subprogram_Call then
17128 Set_No_Elaboration_Check (N);
17132 -- Case of static elaboration model
17135 -- Do not do anything if elaboration checks suppressed. Note that
17136 -- we check Ent here, not E, since we want the real entity for the
17137 -- body to see if checks are suppressed for it, not the dummy
17138 -- entry for renamings or derivations.
17140 if Elaboration_Checks_Suppressed (Ent)
17141 or else Elaboration_Checks_Suppressed (E_Scope)
17142 or else Elaboration_Checks_Suppressed (W_Scope)
17146 -- Do not generate an Elaborate_All for finalization routines
17147 -- that perform partial clean up as part of initialization.
17149 elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then
17152 -- Here we need to generate an implicit elaborate all
17155 -- Generate Elaborate_All warning unless suppressed
17157 if (Elab_Info_Messages and Generate_Warnings and not Inst_Case)
17158 and then not Suppress_Elaboration_Warnings (Ent)
17159 and then not Suppress_Elaboration_Warnings (E_Scope)
17160 and then not Suppress_Elaboration_Warnings (W_Scope)
17162 Error_Msg_Node_2 := W_Scope;
17164 ("info: call to& in elaboration code requires pragma "
17165 & "Elaborate_All on&?$?", N, E);
17168 -- Set indication for binder to generate Elaborate_All
17170 Set_Elaboration_Constraint (N, E, W_Scope);
17175 -----------------------------
17176 -- Check_Bad_Instantiation --
17177 -----------------------------
17179 procedure Check_Bad_Instantiation (N : Node_Id) is
17183 -- Nothing to do if we do not have an instantiation (happens in some
17184 -- error cases, and also in the formal package declaration case)
17186 if Nkind (N) not in N_Generic_Instantiation then
17189 -- Nothing to do if serious errors detected (avoid cascaded errors)
17191 elsif Serious_Errors_Detected /= 0 then
17194 -- Nothing to do if not in full analysis mode
17196 elsif not Full_Analysis then
17199 -- Nothing to do if inside a generic template
17201 elsif Inside_A_Generic then
17204 -- Nothing to do if a library level instantiation
17206 elsif Nkind (Parent (N)) = N_Compilation_Unit then
17209 -- Nothing to do if we are compiling a proper body for semantic
17210 -- purposes only. The generic body may be in another proper body.
17213 Nkind (Parent (Unit_Declaration_Node (Main_Unit_Entity))) = N_Subunit
17218 Ent := Get_Generic_Entity (N);
17220 -- The case we are interested in is when the generic spec is in the
17221 -- current declarative part
17223 if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
17224 or else not In_Same_Extended_Unit (N, Ent)
17229 -- If the generic entity is within a deeper instance than we are, then
17230 -- either the instantiation to which we refer itself caused an ABE, in
17231 -- which case that will be handled separately. Otherwise, we know that
17232 -- the body we need appears as needed at the point of the instantiation.
17233 -- If they are both at the same level but not within the same instance
17234 -- then the body of the generic will be in the earlier instance.
17237 D1 : constant Nat := Instantiation_Depth (Sloc (Ent));
17238 D2 : constant Nat := Instantiation_Depth (Sloc (N));
17245 and then Is_Generic_Instance (Scope (Ent))
17246 and then not In_Open_Scopes (Scope (Ent))
17252 -- Now we can proceed, if the entity being called has a completion,
17253 -- then we are definitely OK, since we have already seen the body.
17255 if Has_Completion (Ent) then
17259 -- If there is no body, then nothing to do
17261 if not Has_Generic_Body (N) then
17265 -- Here we definitely have a bad instantiation
17267 Error_Msg_Warn := SPARK_Mode /= On;
17268 Error_Msg_NE ("cannot instantiate& before body seen<<", N, Ent);
17269 Error_Msg_N ("\Program_Error [<<", N);
17271 Insert_Elab_Check (N);
17272 Set_Is_Known_Guaranteed_ABE (N);
17273 end Check_Bad_Instantiation;
17275 ---------------------
17276 -- Check_Elab_Call --
17277 ---------------------
17279 procedure Check_Elab_Call
17281 Outer_Scope : Entity_Id := Empty;
17282 In_Init_Proc : Boolean := False)
17288 pragma Assert (Legacy_Elaboration_Checks);
17290 -- If the reference is not in the main unit, there is nothing to check.
17291 -- Elaboration call from units in the context of the main unit will lead
17292 -- to semantic dependencies when those units are compiled.
17294 if not In_Extended_Main_Code_Unit (N) then
17298 -- For an entry call, check relevant restriction
17300 if Nkind (N) = N_Entry_Call_Statement
17301 and then not In_Subprogram_Or_Concurrent_Unit
17303 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
17305 -- Nothing to do if this is not an expected type of reference (happens
17306 -- in some error conditions, and in some cases where rewriting occurs).
17308 elsif Nkind (N) not in N_Subprogram_Call
17309 and then Nkind (N) /= N_Attribute_Reference
17310 and then (SPARK_Mode /= On
17311 or else Nkind (N) not in N_Has_Entity
17312 or else No (Entity (N))
17313 or else Ekind (Entity (N)) /= E_Variable)
17317 -- Nothing to do if this is a call already rewritten for elab checking.
17318 -- Such calls appear as the targets of If_Expressions.
17320 -- This check MUST be wrong, it catches far too much
17322 elsif Nkind (Parent (N)) = N_If_Expression then
17325 -- Nothing to do if inside a generic template
17327 elsif Inside_A_Generic
17328 and then No (Enclosing_Generic_Body (N))
17332 -- Nothing to do if call is being preanalyzed, as when within a
17333 -- pre/postcondition, a predicate, or an invariant.
17335 elsif In_Spec_Expression then
17339 -- Nothing to do if this is a call to a postcondition, which is always
17340 -- within a subprogram body, even though the current scope may be the
17341 -- enclosing scope of the subprogram.
17343 if Nkind (N) = N_Procedure_Call_Statement
17344 and then Is_Entity_Name (Name (N))
17345 and then Chars (Entity (Name (N))) = Name_uPostconditions
17350 -- Here we have a reference at elaboration time that must be checked
17352 if Debug_Flag_Underscore_LL then
17353 Write_Str (" Check_Elab_Ref: ");
17355 if Nkind (N) = N_Attribute_Reference then
17356 if not Is_Entity_Name (Prefix (N)) then
17357 Write_Str ("<<not entity name>>");
17359 Write_Name (Chars (Entity (Prefix (N))));
17362 Write_Str ("'Access");
17364 elsif No (Name (N)) or else not Is_Entity_Name (Name (N)) then
17365 Write_Str ("<<not entity name>> ");
17368 Write_Name (Chars (Entity (Name (N))));
17371 Write_Str (" reference at ");
17372 Write_Location (Sloc (N));
17376 -- Climb up the tree to make sure we are not inside default expression
17377 -- of a parameter specification or a record component, since in both
17378 -- these cases, we will be doing the actual reference later, not now,
17379 -- and it is at the time of the actual reference (statically speaking)
17380 -- that we must do our static check, not at the time of its initial
17383 -- However, we have to check references within component definitions
17384 -- (e.g. a function call that determines an array component bound),
17385 -- so we terminate the loop in that case.
17388 while Present (P) loop
17389 if Nkind_In (P, N_Parameter_Specification,
17390 N_Component_Declaration)
17394 -- The reference occurs within the constraint of a component,
17395 -- so it must be checked.
17397 elsif Nkind (P) = N_Component_Definition then
17405 -- Stuff that happens only at the outer level
17407 if No (Outer_Scope) then
17408 Elab_Visited.Set_Last (0);
17410 -- Nothing to do if current scope is Standard (this is a bit odd, but
17411 -- it happens in the case of generic instantiations).
17413 C_Scope := Current_Scope;
17415 if C_Scope = Standard_Standard then
17419 -- First case, we are in elaboration code
17421 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
17423 if From_Elab_Code then
17425 -- Complain if ref that comes from source in preelaborated unit
17426 -- and we are not inside a subprogram (i.e. we are in elab code).
17428 if Comes_From_Source (N)
17429 and then In_Preelaborated_Unit
17430 and then not In_Inlined_Body
17431 and then Nkind (N) /= N_Attribute_Reference
17433 -- This is a warning in GNAT mode allowing such calls to be
17434 -- used in the predefined library with appropriate care.
17436 Error_Msg_Warn := GNAT_Mode;
17438 ("<<non-static call not allowed in preelaborated unit", N);
17442 -- Second case, we are inside a subprogram or concurrent unit, which
17443 -- means we are not in elaboration code.
17446 -- In this case, the issue is whether we are inside the
17447 -- declarative part of the unit in which we live, or inside its
17448 -- statements. In the latter case, there is no issue of ABE calls
17449 -- at this level (a call from outside to the unit in which we live
17450 -- might cause an ABE, but that will be detected when we analyze
17451 -- that outer level call, as it recurses into the called unit).
17453 -- Climb up the tree, doing this test, and also testing for being
17454 -- inside a default expression, which, as discussed above, is not
17455 -- checked at this stage.
17464 -- If we find a parentless subtree, it seems safe to assume
17465 -- that we are not in a declarative part and that no
17466 -- checking is required.
17472 if Is_List_Member (P) then
17473 L := List_Containing (P);
17480 exit when Nkind (P) = N_Subunit;
17482 -- Filter out case of default expressions, where we do not
17483 -- do the check at this stage.
17485 if Nkind_In (P, N_Parameter_Specification,
17486 N_Component_Declaration)
17491 -- A protected body has no elaboration code and contains
17492 -- only other bodies.
17494 if Nkind (P) = N_Protected_Body then
17497 elsif Nkind_In (P, N_Subprogram_Body,
17502 if L = Declarations (P) then
17505 -- We are not in elaboration code, but we are doing
17506 -- dynamic elaboration checks, in this case, we still
17507 -- need to do the reference, since the subprogram we are
17508 -- in could be called from another unit, also in dynamic
17509 -- elaboration check mode, at elaboration time.
17511 elsif Dynamic_Elaboration_Checks then
17513 -- We provide a debug flag to disable this check. That
17514 -- way we have an easy work around for regressions
17515 -- that are caused by this new check. This debug flag
17516 -- can be removed later.
17518 if Debug_Flag_DD then
17522 -- Do the check in this case
17526 elsif Nkind (P) = N_Task_Body then
17528 -- The check is deferred until Check_Task_Activation
17529 -- but we need to capture local suppress pragmas
17530 -- that may inhibit checks on this call.
17532 Ent := Get_Referenced_Ent (N);
17537 elsif Elaboration_Checks_Suppressed (Current_Scope)
17538 or else Elaboration_Checks_Suppressed (Ent)
17539 or else Elaboration_Checks_Suppressed (Scope (Ent))
17541 if Nkind (N) in N_Subprogram_Call then
17542 Set_No_Elaboration_Check (N);
17548 -- Static model, call is not in elaboration code, we
17549 -- never need to worry, because in the static model the
17550 -- top-level caller always takes care of things.
17561 Ent := Get_Referenced_Ent (N);
17567 -- Determine whether a prior call to the same subprogram was already
17568 -- examined within the same context. If this is the case, then there is
17569 -- no need to proceed with the various warnings and checks because the
17570 -- work was already done for the previous call.
17573 Self : constant Visited_Element :=
17574 (Subp_Id => Ent, Context => Parent (N));
17577 for Index in 1 .. Elab_Visited.Last loop
17578 if Self = Elab_Visited.Table (Index) then
17584 -- See if we need to analyze this reference. We analyze it if either of
17585 -- the following conditions is met:
17587 -- It is an inner level call (since in this case it was triggered
17588 -- by an outer level call from elaboration code), but only if the
17589 -- call is within the scope of the original outer level call.
17591 -- It is an outer level reference from elaboration code, or a call to
17592 -- an entity is in the same elaboration scope.
17594 -- And in these cases, we will check both inter-unit calls and
17595 -- intra-unit (within a single unit) calls.
17597 C_Scope := Current_Scope;
17599 -- If not outer level reference, then we follow it if it is within the
17600 -- original scope of the outer reference.
17602 if Present (Outer_Scope)
17603 and then Within (Scope (Ent), Outer_Scope)
17609 Outer_Scope => Outer_Scope,
17610 Inter_Unit_Only => False,
17611 In_Init_Proc => In_Init_Proc);
17613 -- Nothing to do if elaboration checks suppressed for this scope.
17614 -- However, an interesting exception, the fact that elaboration checks
17615 -- are suppressed within an instance (because we can trace the body when
17616 -- we process the template) does not extend to calls to generic formal
17619 elsif Elaboration_Checks_Suppressed (Current_Scope)
17620 and then not Is_Call_Of_Generic_Formal (N)
17624 elsif From_Elab_Code then
17626 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
17628 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
17630 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
17632 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode
17633 -- is set, then we will do the check, but only in the inter-unit case
17634 -- (this is to accommodate unguarded elaboration calls from other units
17635 -- in which this same mode is set). We don't want warnings in this case,
17636 -- it would generate warnings having nothing to do with elaboration.
17638 elsif Dynamic_Elaboration_Checks then
17644 Inter_Unit_Only => True,
17645 Generate_Warnings => False);
17647 -- Otherwise nothing to do
17653 -- A call to an Init_Proc in elaboration code may bring additional
17654 -- dependencies, if some of the record components thereof have
17655 -- initializations that are function calls that come from source. We
17656 -- treat the current node as a call to each of these functions, to check
17657 -- their elaboration impact.
17659 if Is_Init_Proc (Ent) and then From_Elab_Code then
17660 Process_Init_Proc : declare
17661 Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
17663 function Check_Init_Call (Nod : Node_Id) return Traverse_Result;
17664 -- Find subprogram calls within body of Init_Proc for Traverse
17665 -- instantiation below.
17667 procedure Traverse_Body is new Traverse_Proc (Check_Init_Call);
17668 -- Traversal procedure to find all calls with body of Init_Proc
17670 ---------------------
17671 -- Check_Init_Call --
17672 ---------------------
17674 function Check_Init_Call (Nod : Node_Id) return Traverse_Result is
17678 if Nkind (Nod) in N_Subprogram_Call
17679 and then Is_Entity_Name (Name (Nod))
17681 Func := Entity (Name (Nod));
17683 if Comes_From_Source (Func) then
17685 (N, Func, Standard_Standard, Inter_Unit_Only => True);
17693 end Check_Init_Call;
17695 -- Start of processing for Process_Init_Proc
17698 if Nkind (Unit_Decl) = N_Subprogram_Body then
17699 Traverse_Body (Handled_Statement_Sequence (Unit_Decl));
17701 end Process_Init_Proc;
17703 end Check_Elab_Call;
17705 -----------------------
17706 -- Check_Elab_Assign --
17707 -----------------------
17709 procedure Check_Elab_Assign (N : Node_Id) is
17713 Pkg_Spec : Entity_Id;
17714 Pkg_Body : Entity_Id;
17717 pragma Assert (Legacy_Elaboration_Checks);
17719 -- For record or array component, check prefix. If it is an access type,
17720 -- then there is nothing to do (we do not know what is being assigned),
17721 -- but otherwise this is an assignment to the prefix.
17723 if Nkind_In (N, N_Indexed_Component,
17724 N_Selected_Component,
17727 if not Is_Access_Type (Etype (Prefix (N))) then
17728 Check_Elab_Assign (Prefix (N));
17734 -- For type conversion, check expression
17736 if Nkind (N) = N_Type_Conversion then
17737 Check_Elab_Assign (Expression (N));
17741 -- Nothing to do if this is not an entity reference otherwise get entity
17743 if Is_Entity_Name (N) then
17749 -- What we are looking for is a reference in the body of a package that
17750 -- modifies a variable declared in the visible part of the package spec.
17753 and then Comes_From_Source (N)
17754 and then not Suppress_Elaboration_Warnings (Ent)
17755 and then Ekind (Ent) = E_Variable
17756 and then not In_Private_Part (Ent)
17757 and then Is_Library_Level_Entity (Ent)
17759 Scop := Current_Scope;
17761 if No (Scop) or else Scop = Standard_Standard then
17763 elsif Ekind (Scop) = E_Package
17764 and then Is_Compilation_Unit (Scop)
17768 Scop := Scope (Scop);
17772 -- Here Scop points to the containing library package
17775 Pkg_Body := Body_Entity (Pkg_Spec);
17777 -- All OK if the package has an Elaborate_Body pragma
17779 if Has_Pragma_Elaborate_Body (Scop) then
17783 -- OK if entity being modified is not in containing package spec
17785 if not In_Same_Source_Unit (Scop, Ent) then
17789 -- All OK if entity appears in generic package or generic instance.
17790 -- We just get too messed up trying to give proper warnings in the
17791 -- presence of generics. Better no message than a junk one.
17793 Scop := Scope (Ent);
17794 while Present (Scop) and then Scop /= Pkg_Spec loop
17795 if Ekind (Scop) = E_Generic_Package then
17797 elsif Ekind (Scop) = E_Package
17798 and then Is_Generic_Instance (Scop)
17803 Scop := Scope (Scop);
17806 -- All OK if in task, don't issue warnings there
17808 if In_Task_Activation then
17812 -- OK if no package body
17814 if No (Pkg_Body) then
17818 -- OK if reference is not in package body
17820 if not In_Same_Source_Unit (Pkg_Body, N) then
17824 -- OK if package body has no handled statement sequence
17827 HSS : constant Node_Id :=
17828 Handled_Statement_Sequence (Declaration_Node (Pkg_Body));
17830 if No (HSS) or else not Comes_From_Source (HSS) then
17835 -- We definitely have a case of a modification of an entity in
17836 -- the package spec from the elaboration code of the package body.
17837 -- We may not give the warning (because there are some additional
17838 -- checks to avoid too many false positives), but it would be a good
17839 -- idea for the binder to try to keep the body elaboration close to
17840 -- the spec elaboration.
17842 Set_Elaborate_Body_Desirable (Pkg_Spec);
17844 -- All OK in gnat mode (we know what we are doing)
17850 -- All OK if all warnings suppressed
17852 if Warning_Mode = Suppress then
17856 -- All OK if elaboration checks suppressed for entity
17858 if Checks_May_Be_Suppressed (Ent)
17859 and then Is_Check_Suppressed (Ent, Elaboration_Check)
17864 -- OK if the entity is initialized. Note that the No_Initialization
17865 -- flag usually means that the initialization has been rewritten into
17866 -- assignments, but that still counts for us.
17869 Decl : constant Node_Id := Declaration_Node (Ent);
17871 if Nkind (Decl) = N_Object_Declaration
17872 and then (Present (Expression (Decl))
17873 or else No_Initialization (Decl))
17879 -- Here is where we give the warning
17881 -- All OK if warnings suppressed on the entity
17883 if not Has_Warnings_Off (Ent) then
17884 Error_Msg_Sloc := Sloc (Ent);
17887 ("??& can be accessed by clients before this initialization",
17890 ("\??add Elaborate_Body to spec to ensure & is initialized",
17894 if not All_Errors_Mode then
17895 Set_Suppress_Elaboration_Warnings (Ent);
17898 end Check_Elab_Assign;
17900 ----------------------
17901 -- Check_Elab_Calls --
17902 ----------------------
17904 -- WARNING: This routine manages SPARK regions
17906 procedure Check_Elab_Calls is
17907 Saved_SM : SPARK_Mode_Type;
17908 Saved_SMP : Node_Id;
17911 pragma Assert (Legacy_Elaboration_Checks);
17913 -- If expansion is disabled, do not generate any checks, unless we
17914 -- are in GNATprove mode, so that errors are issued in GNATprove for
17915 -- violations of static elaboration rules in SPARK code. Also skip
17916 -- checks if any subunits are missing because in either case we lack the
17917 -- full information that we need, and no object file will be created in
17920 if (not Expander_Active and not GNATprove_Mode)
17921 or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
17922 or else Subunits_Missing
17927 -- Skip delayed calls if we had any errors
17929 if Serious_Errors_Detected = 0 then
17930 Delaying_Elab_Checks := False;
17931 Expander_Mode_Save_And_Set (True);
17933 for J in Delay_Check.First .. Delay_Check.Last loop
17934 Push_Scope (Delay_Check.Table (J).Curscop);
17935 From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
17936 In_Task_Activation := Delay_Check.Table (J).In_Task_Activation;
17938 Saved_SM := SPARK_Mode;
17939 Saved_SMP := SPARK_Mode_Pragma;
17941 -- Set appropriate value of SPARK_Mode
17943 if Delay_Check.Table (J).From_SPARK_Code then
17947 Check_Internal_Call_Continue
17948 (N => Delay_Check.Table (J).N,
17949 E => Delay_Check.Table (J).E,
17950 Outer_Scope => Delay_Check.Table (J).Outer_Scope,
17951 Orig_Ent => Delay_Check.Table (J).Orig_Ent);
17953 Restore_SPARK_Mode (Saved_SM, Saved_SMP);
17957 -- Set Delaying_Elab_Checks back on for next main compilation
17959 Expander_Mode_Restore;
17960 Delaying_Elab_Checks := True;
17962 end Check_Elab_Calls;
17964 ------------------------------
17965 -- Check_Elab_Instantiation --
17966 ------------------------------
17968 procedure Check_Elab_Instantiation
17970 Outer_Scope : Entity_Id := Empty)
17975 pragma Assert (Legacy_Elaboration_Checks);
17977 -- Check for and deal with bad instantiation case. There is some
17978 -- duplicated code here, but we will worry about this later ???
17980 Check_Bad_Instantiation (N);
17982 if Is_Known_Guaranteed_ABE (N) then
17986 -- Nothing to do if we do not have an instantiation (happens in some
17987 -- error cases, and also in the formal package declaration case)
17989 if Nkind (N) not in N_Generic_Instantiation then
17993 -- Nothing to do if inside a generic template
17995 if Inside_A_Generic then
17999 -- Nothing to do if the instantiation is not in the main unit
18001 if not In_Extended_Main_Code_Unit (N) then
18005 Ent := Get_Generic_Entity (N);
18006 From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
18008 -- See if we need to analyze this instantiation. We analyze it if
18009 -- either of the following conditions is met:
18011 -- It is an inner level instantiation (since in this case it was
18012 -- triggered by an outer level call from elaboration code), but
18013 -- only if the instantiation is within the scope of the original
18014 -- outer level call.
18016 -- It is an outer level instantiation from elaboration code, or the
18017 -- instantiated entity is in the same elaboration scope.
18019 -- And in these cases, we will check both the inter-unit case and
18020 -- the intra-unit (within a single unit) case.
18022 C_Scope := Current_Scope;
18024 if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then
18026 Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
18028 elsif From_Elab_Code then
18030 Check_A_Call (N, Ent, Standard_Standard, Inter_Unit_Only => False);
18032 elsif Same_Elaboration_Scope (C_Scope, Scope (Ent)) then
18034 Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False);
18036 -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is
18037 -- set, then we will do the check, but only in the inter-unit case (this
18038 -- is to accommodate unguarded elaboration calls from other units in
18039 -- which this same mode is set). We inhibit warnings in this case, since
18040 -- this instantiation is not occurring in elaboration code.
18042 elsif Dynamic_Elaboration_Checks then
18048 Inter_Unit_Only => True,
18049 Generate_Warnings => False);
18054 end Check_Elab_Instantiation;
18056 -------------------------
18057 -- Check_Internal_Call --
18058 -------------------------
18060 procedure Check_Internal_Call
18063 Outer_Scope : Entity_Id;
18064 Orig_Ent : Entity_Id)
18066 function Within_Initial_Condition (Call : Node_Id) return Boolean;
18067 -- Determine whether call Call occurs within pragma Initial_Condition or
18068 -- pragma Check with check_kind set to Initial_Condition.
18070 ------------------------------
18071 -- Within_Initial_Condition --
18072 ------------------------------
18074 function Within_Initial_Condition (Call : Node_Id) return Boolean is
18080 -- Traverse the parent chain looking for an enclosing pragma
18083 while Present (Par) loop
18084 if Nkind (Par) = N_Pragma then
18085 Nam := Pragma_Name (Par);
18087 -- Pragma Initial_Condition appears in its alternative from as
18088 -- Check (Initial_Condition, ...).
18090 if Nam = Name_Check then
18091 Args := Pragma_Argument_Associations (Par);
18093 -- Pragma Check should have at least two arguments
18095 pragma Assert (Present (Args));
18098 Chars (Expression (First (Args))) = Name_Initial_Condition;
18102 elsif Nam = Name_Initial_Condition then
18105 -- Since pragmas are never nested within other pragmas, stop
18112 -- Prevent the search from going too far
18114 elsif Is_Body_Or_Package_Declaration (Par) then
18118 Par := Parent (Par);
18120 -- If assertions are not enabled, the check pragma is rewritten
18121 -- as an if_statement in sem_prag, to generate various warnings
18122 -- on boolean expressions. Retrieve the original pragma.
18124 if Nkind (Original_Node (Par)) = N_Pragma then
18125 Par := Original_Node (Par);
18130 end Within_Initial_Condition;
18134 Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
18136 -- Start of processing for Check_Internal_Call
18139 -- For P'Access, we want to warn if the -gnatw.f switch is set, and the
18140 -- node comes from source.
18142 if Nkind (N) = N_Attribute_Reference
18143 and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O)
18144 or else not Comes_From_Source (N))
18148 -- If not function or procedure call, instantiation, or 'Access, then
18149 -- ignore call (this happens in some error cases and rewriting cases).
18151 elsif not Nkind_In (N, N_Attribute_Reference,
18153 N_Procedure_Call_Statement)
18154 and then not Inst_Case
18158 -- Nothing to do if this is a call or instantiation that has already
18159 -- been found to be a sure ABE.
18161 elsif Nkind (N) /= N_Attribute_Reference
18162 and then Is_Known_Guaranteed_ABE (N)
18166 -- Nothing to do if errors already detected (avoid cascaded errors)
18168 elsif Serious_Errors_Detected /= 0 then
18171 -- Nothing to do if not in full analysis mode
18173 elsif not Full_Analysis then
18176 -- Nothing to do if analyzing in special spec-expression mode, since the
18177 -- call is not actually being made at this time.
18179 elsif In_Spec_Expression then
18182 -- Nothing to do for call to intrinsic subprogram
18184 elsif Is_Intrinsic_Subprogram (E) then
18187 -- Nothing to do if call is within a generic unit
18189 elsif Inside_A_Generic then
18192 -- Nothing to do when the call appears within pragma Initial_Condition.
18193 -- The pragma is part of the elaboration statements of a package body
18194 -- and may only call external subprograms or subprograms whose body is
18195 -- already available.
18197 elsif Within_Initial_Condition (N) then
18201 -- Delay this call if we are still delaying calls
18203 if Delaying_Elab_Checks then
18207 Orig_Ent => Orig_Ent,
18208 Curscop => Current_Scope,
18209 Outer_Scope => Outer_Scope,
18210 From_Elab_Code => From_Elab_Code,
18211 In_Task_Activation => In_Task_Activation,
18212 From_SPARK_Code => SPARK_Mode = On));
18215 -- Otherwise, call phase 2 continuation right now
18218 Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
18220 end Check_Internal_Call;
18222 ----------------------------------
18223 -- Check_Internal_Call_Continue --
18224 ----------------------------------
18226 procedure Check_Internal_Call_Continue
18229 Outer_Scope : Entity_Id;
18230 Orig_Ent : Entity_Id)
18232 function Find_Elab_Reference (N : Node_Id) return Traverse_Result;
18233 -- Function applied to each node as we traverse the body. Checks for
18234 -- call or entity reference that needs checking, and if so checks it.
18235 -- Always returns OK, so entire tree is traversed, except that as
18236 -- described below subprogram bodies are skipped for now.
18238 procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference);
18239 -- Traverse procedure using above Find_Elab_Reference function
18241 -------------------------
18242 -- Find_Elab_Reference --
18243 -------------------------
18245 function Find_Elab_Reference (N : Node_Id) return Traverse_Result is
18249 -- If user has specified that there are no entry calls in elaboration
18250 -- code, do not trace past an accept statement, because the rendez-
18251 -- vous will happen after elaboration.
18253 if Nkind_In (Original_Node (N), N_Accept_Statement,
18254 N_Selective_Accept)
18255 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
18259 -- If we have a function call, check it
18261 elsif Nkind (N) = N_Function_Call then
18262 Check_Elab_Call (N, Outer_Scope);
18265 -- If we have a procedure call, check the call, and also check
18266 -- arguments that are assignments (OUT or IN OUT mode formals).
18268 elsif Nkind (N) = N_Procedure_Call_Statement then
18269 Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E));
18271 Actual := First_Actual (N);
18272 while Present (Actual) loop
18273 if Known_To_Be_Assigned (Actual) then
18274 Check_Elab_Assign (Actual);
18277 Next_Actual (Actual);
18282 -- If we have an access attribute for a subprogram, check it.
18283 -- Suppress this behavior under debug flag.
18285 elsif not Debug_Flag_Dot_UU
18286 and then Nkind (N) = N_Attribute_Reference
18287 and then Nam_In (Attribute_Name (N), Name_Access,
18288 Name_Unrestricted_Access)
18289 and then Is_Entity_Name (Prefix (N))
18290 and then Is_Subprogram (Entity (Prefix (N)))
18292 Check_Elab_Call (N, Outer_Scope);
18295 -- In SPARK mode, if we have an entity reference to a variable, then
18296 -- check it. For now we consider any reference.
18298 elsif SPARK_Mode = On
18299 and then Nkind (N) in N_Has_Entity
18300 and then Present (Entity (N))
18301 and then Ekind (Entity (N)) = E_Variable
18303 Check_Elab_Call (N, Outer_Scope);
18306 -- If we have a generic instantiation, check it
18308 elsif Nkind (N) in N_Generic_Instantiation then
18309 Check_Elab_Instantiation (N, Outer_Scope);
18312 -- Skip subprogram bodies that come from source (wait for call to
18313 -- analyze these). The reason for the come from source test is to
18314 -- avoid catching task bodies.
18316 -- For task bodies, we should really avoid these too, waiting for the
18317 -- task activation, but that's too much trouble to catch for now, so
18318 -- we go in unconditionally. This is not so terrible, it means the
18319 -- error backtrace is not quite complete, and we are too eager to
18320 -- scan bodies of tasks that are unused, but this is hardly very
18323 elsif Nkind (N) = N_Subprogram_Body
18324 and then Comes_From_Source (N)
18328 elsif Nkind (N) = N_Assignment_Statement
18329 and then Comes_From_Source (N)
18331 Check_Elab_Assign (Name (N));
18337 end Find_Elab_Reference;
18339 Inst_Case : constant Boolean := Is_Generic_Unit (E);
18340 Loc : constant Source_Ptr := Sloc (N);
18345 -- Start of processing for Check_Internal_Call_Continue
18348 -- Save outer level call if at outer level
18350 if Elab_Call.Last = 0 then
18351 Outer_Level_Sloc := Loc;
18354 -- If the call is to a function that renames a literal, no check needed
18356 if Ekind (E) = E_Enumeration_Literal then
18360 -- Register the subprogram as examined within this particular context.
18361 -- This ensures that calls to the same subprogram but in different
18362 -- contexts receive warnings and checks of their own since the calls
18363 -- may be reached through different flow paths.
18365 Elab_Visited.Append ((Subp_Id => E, Context => Parent (N)));
18367 Sbody := Unit_Declaration_Node (E);
18369 if not Nkind_In (Sbody, N_Subprogram_Body, N_Package_Body) then
18370 Ebody := Corresponding_Body (Sbody);
18375 Sbody := Unit_Declaration_Node (Ebody);
18379 -- If the body appears after the outer level call or instantiation then
18380 -- we have an error case handled below.
18382 if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody))
18383 and then not In_Task_Activation
18387 -- If we have the instantiation case we are done, since we now know that
18388 -- the body of the generic appeared earlier.
18390 elsif Inst_Case then
18393 -- Otherwise we have a call, so we trace through the called body to see
18394 -- if it has any problems.
18397 pragma Assert (Nkind (Sbody) = N_Subprogram_Body);
18399 Elab_Call.Append ((Cloc => Loc, Ent => E));
18401 if Debug_Flag_Underscore_LL then
18402 Write_Str ("Elab_Call.Last = ");
18403 Write_Int (Int (Elab_Call.Last));
18404 Write_Str (" Ent = ");
18405 Write_Name (Chars (E));
18406 Write_Str (" at ");
18407 Write_Location (Sloc (N));
18411 -- Now traverse declarations and statements of subprogram body. Note
18412 -- that we cannot simply Traverse (Sbody), since traverse does not
18413 -- normally visit subprogram bodies.
18418 Decl := First (Declarations (Sbody));
18419 while Present (Decl) loop
18425 Traverse (Handled_Statement_Sequence (Sbody));
18427 Elab_Call.Decrement_Last;
18431 -- Here is the case of calling a subprogram where the body has not yet
18432 -- been encountered. A warning message is needed, except if this is the
18433 -- case of appearing within an aspect specification that results in
18434 -- a check call, we do not really have such a situation, so no warning
18435 -- is needed (e.g. the case of a precondition, where the call appears
18436 -- textually before the body, but in actual fact is moved to the
18437 -- appropriate subprogram body and so does not need a check).
18446 -- Keep looking at parents if we are still in the subexpression
18448 if Nkind (P) in N_Subexpr then
18451 -- Here P is the parent of the expression, check for special case
18454 O := Original_Node (P);
18456 -- Definitely not the special case if orig node is not a pragma
18458 exit when Nkind (O) /= N_Pragma;
18460 -- Check we have an If statement or a null statement (happens
18461 -- when the If has been expanded to be True).
18463 exit when not Nkind_In (P, N_If_Statement, N_Null_Statement);
18465 -- Our special case will be indicated either by the pragma
18466 -- coming from an aspect ...
18468 if Present (Corresponding_Aspect (O)) then
18471 -- Or, in the case of an initial condition, specifically by a
18472 -- Check pragma specifying an Initial_Condition check.
18474 elsif Pragma_Name (O) = Name_Check
18477 (Expression (First (Pragma_Argument_Associations (O)))) =
18478 Name_Initial_Condition
18482 -- For anything else, we have an error
18491 -- Not that special case, warning and dynamic check is required
18493 -- If we have nothing in the call stack, then this is at the outer
18494 -- level, and the ABE is bound to occur, unless it's a 'Access, or
18495 -- it's a renaming.
18497 if Elab_Call.Last = 0 then
18498 Error_Msg_Warn := SPARK_Mode /= On;
18501 Insert_Check : Boolean := True;
18502 -- This flag is set to True if an elaboration check should be
18506 if In_Task_Activation then
18507 Insert_Check := False;
18509 elsif Inst_Case then
18511 ("cannot instantiate& before body seen<<", N, Orig_Ent);
18513 elsif Nkind (N) = N_Attribute_Reference then
18515 ("Access attribute of & before body seen<<", N, Orig_Ent);
18516 Error_Msg_N ("\possible Program_Error on later references<", N);
18517 Insert_Check := False;
18519 elsif Nkind (Unit_Declaration_Node (Orig_Ent)) /=
18520 N_Subprogram_Renaming_Declaration
18523 ("cannot call& before body seen<<", N, Orig_Ent);
18525 elsif not Is_Generic_Actual_Subprogram (Orig_Ent) then
18526 Insert_Check := False;
18529 if Insert_Check then
18530 Error_Msg_N ("\Program_Error [<<", N);
18531 Insert_Elab_Check (N);
18535 -- Call is not at outer level
18538 -- Do not generate elaboration checks in GNATprove mode because the
18539 -- elaboration counter and the check are both forms of expansion.
18541 if GNATprove_Mode then
18544 -- Generate an elaboration check
18546 elsif not Elaboration_Checks_Suppressed (E) then
18547 Set_Elaboration_Entity_Required (E);
18549 -- Create a declaration of the elaboration entity, and insert it
18550 -- prior to the subprogram or the generic unit, within the same
18551 -- scope. Since the subprogram may be overloaded, create a unique
18554 if No (Elaboration_Entity (E)) then
18556 Loce : constant Source_Ptr := Sloc (E);
18557 Ent : constant Entity_Id :=
18558 Make_Defining_Identifier (Loc,
18559 New_External_Name (Chars (E), 'E', -1));
18562 Set_Elaboration_Entity (E, Ent);
18563 Push_Scope (Scope (E));
18565 Insert_Action (Declaration_Node (E),
18566 Make_Object_Declaration (Loce,
18567 Defining_Identifier => Ent,
18568 Object_Definition =>
18569 New_Occurrence_Of (Standard_Short_Integer, Loce),
18571 Make_Integer_Literal (Loc, Uint_0)));
18573 -- Set elaboration flag at the point of the body
18575 Set_Elaboration_Flag (Sbody, E);
18577 -- Kill current value indication. This is necessary because
18578 -- the tests of this flag are inserted out of sequence and
18579 -- must not pick up bogus indications of the wrong constant
18580 -- value. Also, this is never a true constant, since one way
18581 -- or another, it gets reset.
18583 Set_Current_Value (Ent, Empty);
18584 Set_Last_Assignment (Ent, Empty);
18585 Set_Is_True_Constant (Ent, False);
18592 -- raise Program_Error with "access before elaboration";
18595 Insert_Elab_Check (N,
18596 Make_Attribute_Reference (Loc,
18597 Attribute_Name => Name_Elaborated,
18598 Prefix => New_Occurrence_Of (E, Loc)));
18601 -- Generate the warning
18603 if not Suppress_Elaboration_Warnings (E)
18604 and then not Elaboration_Checks_Suppressed (E)
18606 -- Suppress this warning if we have a function call that occurred
18607 -- within an assertion expression, since we can get false warnings
18608 -- in this case, due to the out of order handling in this case.
18611 (Nkind (Original_Node (N)) /= N_Function_Call
18612 or else not In_Assertion_Expression_Pragma (Original_Node (N)))
18614 Error_Msg_Warn := SPARK_Mode /= On;
18618 ("instantiation of& may occur before body is seen<l<",
18621 -- A rather specific check. For Finalize/Adjust/Initialize, if
18622 -- the type has Warnings_Off set, suppress the warning.
18624 if Nam_In (Chars (E), Name_Adjust,
18627 and then Present (First_Formal (E))
18630 T : constant Entity_Id := Etype (First_Formal (E));
18632 if Is_Controlled (T) then
18633 if Warnings_Off (T)
18634 or else (Ekind (T) = E_Private_Type
18635 and then Warnings_Off (Full_View (T)))
18643 -- Go ahead and give warning if not this special case
18646 ("call to& may occur before body is seen<l<", N, Orig_Ent);
18649 Error_Msg_N ("\Program_Error ]<l<", N);
18651 -- There is no need to query the elaboration warning message flags
18652 -- because the main message is an error, not a warning, therefore
18653 -- all the clarification messages produces by Output_Calls must be
18654 -- emitted unconditionally.
18658 Output_Calls (N, Check_Elab_Flag => False);
18661 end Check_Internal_Call_Continue;
18663 ---------------------------
18664 -- Check_Task_Activation --
18665 ---------------------------
18667 procedure Check_Task_Activation (N : Node_Id) is
18668 Loc : constant Source_Ptr := Sloc (N);
18669 Inter_Procs : constant Elist_Id := New_Elmt_List;
18670 Intra_Procs : constant Elist_Id := New_Elmt_List;
18673 Task_Scope : Entity_Id;
18674 Cunit_SC : Boolean := False;
18677 Enclosing : Entity_Id;
18679 procedure Add_Task_Proc (Typ : Entity_Id);
18680 -- Add to Task_Procs the task body procedure(s) of task types in Typ.
18681 -- For record types, this procedure recurses over component types.
18683 procedure Collect_Tasks (Decls : List_Id);
18684 -- Collect the types of the tasks that are to be activated in the given
18685 -- list of declarations, in order to perform elaboration checks on the
18686 -- corresponding task procedures that are called implicitly here.
18688 function Outer_Unit (E : Entity_Id) return Entity_Id;
18689 -- find enclosing compilation unit of Entity, ignoring subunits, or
18690 -- else enclosing subprogram. If E is not a package, there is no need
18691 -- for inter-unit elaboration checks.
18693 -------------------
18694 -- Add_Task_Proc --
18695 -------------------
18697 procedure Add_Task_Proc (Typ : Entity_Id) is
18699 Proc : Entity_Id := Empty;
18702 if Is_Task_Type (Typ) then
18703 Proc := Get_Task_Body_Procedure (Typ);
18705 elsif Is_Array_Type (Typ)
18706 and then Has_Task (Base_Type (Typ))
18708 Add_Task_Proc (Component_Type (Typ));
18710 elsif Is_Record_Type (Typ)
18711 and then Has_Task (Base_Type (Typ))
18713 Comp := First_Component (Typ);
18714 while Present (Comp) loop
18715 Add_Task_Proc (Etype (Comp));
18716 Comp := Next_Component (Comp);
18720 -- If the task type is another unit, we will perform the usual
18721 -- elaboration check on its enclosing unit. If the type is in the
18722 -- same unit, we can trace the task body as for an internal call,
18723 -- but we only need to examine other external calls, because at
18724 -- the point the task is activated, internal subprogram bodies
18725 -- will have been elaborated already. We keep separate lists for
18726 -- each kind of task.
18728 -- Skip this test if errors have occurred, since in this case
18729 -- we can get false indications.
18731 if Serious_Errors_Detected /= 0 then
18735 if Present (Proc) then
18736 if Outer_Unit (Scope (Proc)) = Enclosing then
18738 if No (Corresponding_Body (Unit_Declaration_Node (Proc)))
18740 (not Is_Generic_Instance (Scope (Proc))
18741 or else Scope (Proc) = Scope (Defining_Identifier (Decl)))
18743 Error_Msg_Warn := SPARK_Mode /= On;
18745 ("task will be activated before elaboration of its body<<",
18747 Error_Msg_N ("\Program_Error [<<", Decl);
18750 (Corresponding_Body (Unit_Declaration_Node (Proc)))
18752 Append_Elmt (Proc, Intra_Procs);
18756 -- No need for multiple entries of the same type
18758 Elmt := First_Elmt (Inter_Procs);
18759 while Present (Elmt) loop
18760 if Node (Elmt) = Proc then
18767 Append_Elmt (Proc, Inter_Procs);
18772 -------------------
18773 -- Collect_Tasks --
18774 -------------------
18776 procedure Collect_Tasks (Decls : List_Id) is
18778 if Present (Decls) then
18779 Decl := First (Decls);
18780 while Present (Decl) loop
18781 if Nkind (Decl) = N_Object_Declaration
18782 and then Has_Task (Etype (Defining_Identifier (Decl)))
18784 Add_Task_Proc (Etype (Defining_Identifier (Decl)));
18796 function Outer_Unit (E : Entity_Id) return Entity_Id is
18801 while Present (Outer) loop
18802 if Elaboration_Checks_Suppressed (Outer) then
18806 exit when Is_Child_Unit (Outer)
18807 or else Scope (Outer) = Standard_Standard
18808 or else Ekind (Outer) /= E_Package;
18809 Outer := Scope (Outer);
18815 -- Start of processing for Check_Task_Activation
18818 pragma Assert (Legacy_Elaboration_Checks);
18820 Enclosing := Outer_Unit (Current_Scope);
18822 -- Find all tasks declared in the current unit
18824 if Nkind (N) = N_Package_Body then
18825 P := Unit_Declaration_Node (Corresponding_Spec (N));
18827 Collect_Tasks (Declarations (N));
18828 Collect_Tasks (Visible_Declarations (Specification (P)));
18829 Collect_Tasks (Private_Declarations (Specification (P)));
18831 elsif Nkind (N) = N_Package_Declaration then
18832 Collect_Tasks (Visible_Declarations (Specification (N)));
18833 Collect_Tasks (Private_Declarations (Specification (N)));
18836 Collect_Tasks (Declarations (N));
18839 -- We only perform detailed checks in all tasks that are library level
18840 -- entities. If the master is a subprogram or task, activation will
18841 -- depend on the activation of the master itself.
18843 -- Should dynamic checks be added in the more general case???
18845 if Ekind (Enclosing) /= E_Package then
18849 -- For task types defined in other units, we want the unit containing
18850 -- the task body to be elaborated before the current one.
18852 Elmt := First_Elmt (Inter_Procs);
18853 while Present (Elmt) loop
18854 Ent := Node (Elmt);
18855 Task_Scope := Outer_Unit (Scope (Ent));
18857 if not Is_Compilation_Unit (Task_Scope) then
18860 elsif Suppress_Elaboration_Warnings (Task_Scope)
18861 or else Elaboration_Checks_Suppressed (Task_Scope)
18865 elsif Dynamic_Elaboration_Checks then
18866 if not Elaboration_Checks_Suppressed (Ent)
18867 and then not Cunit_SC
18868 and then not Restriction_Active
18869 (No_Entry_Calls_In_Elaboration_Code)
18871 -- Runtime elaboration check required. Generate check of the
18872 -- elaboration counter for the unit containing the entity.
18874 Insert_Elab_Check (N,
18875 Make_Attribute_Reference (Loc,
18877 New_Occurrence_Of (Spec_Entity (Task_Scope), Loc),
18878 Attribute_Name => Name_Elaborated));
18882 -- Force the binder to elaborate other unit first
18884 if Elab_Info_Messages
18885 and then not Suppress_Elaboration_Warnings (Ent)
18886 and then not Elaboration_Checks_Suppressed (Ent)
18887 and then not Suppress_Elaboration_Warnings (Task_Scope)
18888 and then not Elaboration_Checks_Suppressed (Task_Scope)
18890 Error_Msg_Node_2 := Task_Scope;
18892 ("info: activation of an instance of task type & requires "
18893 & "pragma Elaborate_All on &?$?", N, Ent);
18896 Activate_Elaborate_All_Desirable (N, Task_Scope);
18897 Set_Suppress_Elaboration_Warnings (Task_Scope);
18903 -- For tasks declared in the current unit, trace other calls within the
18904 -- task procedure bodies, which are available.
18906 if not Debug_Flag_Dot_Y then
18907 In_Task_Activation := True;
18909 Elmt := First_Elmt (Intra_Procs);
18910 while Present (Elmt) loop
18911 Ent := Node (Elmt);
18912 Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
18916 In_Task_Activation := False;
18918 end Check_Task_Activation;
18920 ------------------------
18921 -- Get_Referenced_Ent --
18922 ------------------------
18924 function Get_Referenced_Ent (N : Node_Id) return Entity_Id is
18928 if Nkind (N) in N_Has_Entity
18929 and then Present (Entity (N))
18930 and then Ekind (Entity (N)) = E_Variable
18935 if Nkind (N) = N_Attribute_Reference then
18943 elsif Nkind (Nam) = N_Selected_Component then
18944 return Entity (Selector_Name (Nam));
18945 elsif not Is_Entity_Name (Nam) then
18948 return Entity (Nam);
18950 end Get_Referenced_Ent;
18952 ----------------------
18953 -- Has_Generic_Body --
18954 ----------------------
18956 function Has_Generic_Body (N : Node_Id) return Boolean is
18957 Ent : constant Entity_Id := Get_Generic_Entity (N);
18958 Decl : constant Node_Id := Unit_Declaration_Node (Ent);
18961 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id;
18962 -- Determine if the list of nodes headed by N and linked by Next
18963 -- contains a package body for the package spec entity E, and if so
18964 -- return the package body. If not, then returns Empty.
18966 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id;
18967 -- This procedure is called load the unit whose name is given by Nam.
18968 -- This unit is being loaded to see whether it contains an optional
18969 -- generic body. The returned value is the loaded unit, which is always
18970 -- a package body (only package bodies can contain other entities in the
18971 -- sense in which Has_Generic_Body is interested). We only attempt to
18972 -- load bodies if we are generating code. If we are in semantics check
18973 -- only mode, then it would be wrong to load bodies that are not
18974 -- required from a semantic point of view, so in this case we return
18975 -- Empty. The result is that the caller may incorrectly decide that a
18976 -- generic spec does not have a body when in fact it does, but the only
18977 -- harm in this is that some warnings on elaboration problems may be
18978 -- lost in semantic checks only mode, which is not big loss. We also
18979 -- return Empty if we go for a body and it is not there.
18981 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id;
18982 -- PE is the entity for a package spec. This function locates the
18983 -- corresponding package body, returning Empty if none is found. The
18984 -- package body returned is fully parsed but may not yet be analyzed,
18985 -- so only syntactic fields should be referenced.
18991 function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id is
18996 while Present (Nod) loop
18998 -- If we found the package body we are looking for, return it
19000 if Nkind (Nod) = N_Package_Body
19001 and then Chars (Defining_Unit_Name (Nod)) = Chars (E)
19005 -- If we found the stub for the body, go after the subunit,
19006 -- loading it if necessary.
19008 elsif Nkind (Nod) = N_Package_Body_Stub
19009 and then Chars (Defining_Identifier (Nod)) = Chars (E)
19011 if Present (Library_Unit (Nod)) then
19012 return Unit (Library_Unit (Nod));
19015 return Load_Package_Body (Get_Unit_Name (Nod));
19018 -- If neither package body nor stub, keep looking on chain
19028 -----------------------
19029 -- Load_Package_Body --
19030 -----------------------
19032 function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id is
19033 U : Unit_Number_Type;
19036 if Operating_Mode /= Generate_Code then
19046 if U = No_Unit then
19049 return Unit (Cunit (U));
19052 end Load_Package_Body;
19054 -------------------------------
19055 -- Locate_Corresponding_Body --
19056 -------------------------------
19058 function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id is
19059 Spec : constant Node_Id := Declaration_Node (PE);
19060 Decl : constant Node_Id := Parent (Spec);
19061 Scop : constant Entity_Id := Scope (PE);
19065 if Is_Library_Level_Entity (PE) then
19067 -- If package is a library unit that requires a body, we have no
19068 -- choice but to go after that body because it might contain an
19069 -- optional body for the original generic package.
19071 if Unit_Requires_Body (PE) then
19073 -- Load the body. Note that we are a little careful here to use
19074 -- Spec to get the unit number, rather than PE or Decl, since
19075 -- in the case where the package is itself a library level
19076 -- instantiation, Spec will properly reference the generic
19077 -- template, which is what we really want.
19081 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec))));
19083 -- But if the package is a library unit that does NOT require
19084 -- a body, then no body is permitted, so we are sure that there
19085 -- is no body for the original generic package.
19091 -- Otherwise look and see if we are embedded in a further package
19093 elsif Is_Package_Or_Generic_Package (Scop) then
19095 -- If so, get the body of the enclosing package, and look in
19096 -- its package body for the package body we are looking for.
19098 PBody := Locate_Corresponding_Body (Scop);
19103 return Find_Body_In (PE, First (Declarations (PBody)));
19106 -- If we are not embedded in a further package, then the body
19107 -- must be in the same declarative part as we are.
19110 return Find_Body_In (PE, Next (Decl));
19112 end Locate_Corresponding_Body;
19114 -- Start of processing for Has_Generic_Body
19117 if Present (Corresponding_Body (Decl)) then
19120 elsif Unit_Requires_Body (Ent) then
19123 -- Compilation units cannot have optional bodies
19125 elsif Is_Compilation_Unit (Ent) then
19128 -- Otherwise look at what scope we are in
19131 Scop := Scope (Ent);
19133 -- Case of entity is in other than a package spec, in this case
19134 -- the body, if present, must be in the same declarative part.
19136 if not Is_Package_Or_Generic_Package (Scop) then
19141 -- Declaration node may get us a spec, so if so, go to
19142 -- the parent declaration.
19144 P := Declaration_Node (Ent);
19145 while not Is_List_Member (P) loop
19149 return Present (Find_Body_In (Ent, Next (P)));
19152 -- If the entity is in a package spec, then we have to locate
19153 -- the corresponding package body, and look there.
19157 PBody : constant Node_Id := Locate_Corresponding_Body (Scop);
19165 (Find_Body_In (Ent, (First (Declarations (PBody)))));
19170 end Has_Generic_Body;
19172 -----------------------
19173 -- Insert_Elab_Check --
19174 -----------------------
19176 procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty) is
19178 Loc : constant Source_Ptr := Sloc (N);
19181 -- The check (N_Raise_Program_Error) node to be inserted
19184 -- If expansion is disabled, do not generate any checks. Also
19185 -- skip checks if any subunits are missing because in either
19186 -- case we lack the full information that we need, and no object
19187 -- file will be created in any case.
19189 if not Expander_Active or else Subunits_Missing then
19193 -- If we have a generic instantiation, where Instance_Spec is set,
19194 -- then this field points to a generic instance spec that has
19195 -- been inserted before the instantiation node itself, so that
19196 -- is where we want to insert a check.
19198 if Nkind (N) in N_Generic_Instantiation
19199 and then Present (Instance_Spec (N))
19201 Nod := Instance_Spec (N);
19206 -- Build check node, possibly with condition
19209 Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration);
19211 if Present (C) then
19212 Set_Condition (Chk, Make_Op_Not (Loc, Right_Opnd => C));
19215 -- If we are inserting at the top level, insert in Aux_Decls
19217 if Nkind (Parent (Nod)) = N_Compilation_Unit then
19219 ADN : constant Node_Id := Aux_Decls_Node (Parent (Nod));
19222 if No (Declarations (ADN)) then
19223 Set_Declarations (ADN, New_List (Chk));
19225 Append_To (Declarations (ADN), Chk);
19231 -- Otherwise just insert as an action on the node in question
19234 Insert_Action (Nod, Chk);
19236 end Insert_Elab_Check;
19238 -------------------------------
19239 -- Is_Call_Of_Generic_Formal --
19240 -------------------------------
19242 function Is_Call_Of_Generic_Formal (N : Node_Id) return Boolean is
19244 return Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement)
19246 -- Always return False if debug flag -gnatd.G is set
19248 and then not Debug_Flag_Dot_GG
19250 -- For now, we detect this by looking for the strange identifier
19251 -- node, whose Chars reflect the name of the generic formal, but
19252 -- the Chars of the Entity references the generic actual.
19254 and then Nkind (Name (N)) = N_Identifier
19255 and then Chars (Name (N)) /= Chars (Entity (Name (N)));
19256 end Is_Call_Of_Generic_Formal;
19258 -------------------------------
19259 -- Is_Finalization_Procedure --
19260 -------------------------------
19262 function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is
19264 -- Check whether Id is a procedure with at least one parameter
19266 if Ekind (Id) = E_Procedure and then Present (First_Formal (Id)) then
19268 Typ : constant Entity_Id := Etype (First_Formal (Id));
19269 Deep_Fin : Entity_Id := Empty;
19270 Fin : Entity_Id := Empty;
19273 -- If the type of the first formal does not require finalization
19274 -- actions, then this is definitely not [Deep_]Finalize.
19276 if not Needs_Finalization (Typ) then
19280 -- At this point we have the following scenario:
19282 -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
19284 -- Recover the two possible versions of [Deep_]Finalize using the
19285 -- type of the first parameter and compare with the input.
19287 Deep_Fin := TSS (Typ, TSS_Deep_Finalize);
19289 if Is_Controlled (Typ) then
19290 Fin := Find_Prim_Op (Typ, Name_Finalize);
19293 return (Present (Deep_Fin) and then Id = Deep_Fin)
19294 or else (Present (Fin) and then Id = Fin);
19299 end Is_Finalization_Procedure;
19305 procedure Output_Calls
19307 Check_Elab_Flag : Boolean)
19309 function Emit (Flag : Boolean) return Boolean;
19310 -- Determine whether to emit an error message based on the combination
19311 -- of flags Check_Elab_Flag and Flag.
19313 function Is_Printable_Error_Name return Boolean;
19314 -- An internal function, used to determine if a name, stored in the
19315 -- Name_Buffer, is either a non-internal name, or is an internal name
19316 -- that is printable by the error message circuits (i.e. it has a single
19317 -- upper case letter at the end).
19323 function Emit (Flag : Boolean) return Boolean is
19325 if Check_Elab_Flag then
19332 -----------------------------
19333 -- Is_Printable_Error_Name --
19334 -----------------------------
19336 function Is_Printable_Error_Name return Boolean is
19338 if not Is_Internal_Name then
19341 elsif Name_Len = 1 then
19345 Name_Len := Name_Len - 1;
19346 return not Is_Internal_Name;
19348 end Is_Printable_Error_Name;
19354 -- Start of processing for Output_Calls
19357 for J in reverse 1 .. Elab_Call.Last loop
19358 Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
19360 Ent := Elab_Call.Table (J).Ent;
19361 Get_Name_String (Chars (Ent));
19363 -- Dynamic elaboration model, warnings controlled by -gnatwl
19365 if Dynamic_Elaboration_Checks then
19366 if Emit (Elab_Warnings) then
19367 if Is_Generic_Unit (Ent) then
19368 Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
19369 elsif Is_Init_Proc (Ent) then
19370 Error_Msg_N ("\\?l?initialization procedure called #", N);
19371 elsif Is_Printable_Error_Name then
19372 Error_Msg_NE ("\\?l?& called #", N, Ent);
19374 Error_Msg_N ("\\?l?called #", N);
19378 -- Static elaboration model, info messages controlled by -gnatel
19381 if Emit (Elab_Info_Messages) then
19382 if Is_Generic_Unit (Ent) then
19383 Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
19384 elsif Is_Init_Proc (Ent) then
19385 Error_Msg_N ("\\?$?initialization procedure called #", N);
19386 elsif Is_Printable_Error_Name then
19387 Error_Msg_NE ("\\?$?& called #", N, Ent);
19389 Error_Msg_N ("\\?$?called #", N);
19396 ----------------------------
19397 -- Same_Elaboration_Scope --
19398 ----------------------------
19400 function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
19405 -- Find elaboration scope for Scop1
19406 -- This is either a subprogram or a compilation unit.
19409 while S1 /= Standard_Standard
19410 and then not Is_Compilation_Unit (S1)
19411 and then Ekind_In (S1, E_Package, E_Protected_Type, E_Block)
19416 -- Find elaboration scope for Scop2
19419 while S2 /= Standard_Standard
19420 and then not Is_Compilation_Unit (S2)
19421 and then Ekind_In (S2, E_Package, E_Protected_Type, E_Block)
19427 end Same_Elaboration_Scope;
19433 procedure Set_C_Scope is
19435 while not Is_Compilation_Unit (C_Scope) loop
19436 C_Scope := Scope (C_Scope);
19440 --------------------------------
19441 -- Set_Elaboration_Constraint --
19442 --------------------------------
19444 procedure Set_Elaboration_Constraint
19449 Elab_Unit : Entity_Id;
19451 -- Check whether this is a call to an Initialize subprogram for a
19452 -- controlled type. Note that Call can also be a 'Access attribute
19453 -- reference, which now generates an elaboration check.
19455 Init_Call : constant Boolean :=
19456 Nkind (Call) = N_Procedure_Call_Statement
19457 and then Chars (Subp) = Name_Initialize
19458 and then Comes_From_Source (Subp)
19459 and then Present (Parameter_Associations (Call))
19460 and then Is_Controlled (Etype (First_Actual (Call)));
19463 -- If the unit is mentioned in a with_clause of the current unit, it is
19464 -- visible, and we can set the elaboration flag.
19466 if Is_Immediately_Visible (Scop)
19467 or else (Is_Child_Unit (Scop) and then Is_Visible_Lib_Unit (Scop))
19469 Activate_Elaborate_All_Desirable (Call, Scop);
19470 Set_Suppress_Elaboration_Warnings (Scop);
19474 -- If this is not an initialization call or a call using object notation
19475 -- we know that the unit of the called entity is in the context, and we
19476 -- can set the flag as well. The unit need not be visible if the call
19477 -- occurs within an instantiation.
19479 if Is_Init_Proc (Subp)
19481 or else Nkind (Original_Node (Call)) = N_Selected_Component
19483 null; -- detailed processing follows.
19486 Activate_Elaborate_All_Desirable (Call, Scop);
19487 Set_Suppress_Elaboration_Warnings (Scop);
19491 -- If the unit is not in the context, there must be an intermediate unit
19492 -- that is, on which we need to place to elaboration flag. This happens
19493 -- with init proc calls.
19495 if Is_Init_Proc (Subp) or else Init_Call then
19497 -- The initialization call is on an object whose type is not declared
19498 -- in the same scope as the subprogram. The type of the object must
19499 -- be a subtype of the type of operation. This object is the first
19500 -- actual in the call.
19503 Typ : constant Entity_Id :=
19504 Etype (First (Parameter_Associations (Call)));
19506 Elab_Unit := Scope (Typ);
19507 while (Present (Elab_Unit))
19508 and then not Is_Compilation_Unit (Elab_Unit)
19510 Elab_Unit := Scope (Elab_Unit);
19514 -- If original node uses selected component notation, the prefix is
19515 -- visible and determines the scope that must be elaborated. After
19516 -- rewriting, the prefix is the first actual in the call.
19518 elsif Nkind (Original_Node (Call)) = N_Selected_Component then
19519 Elab_Unit := Scope (Etype (First (Parameter_Associations (Call))));
19521 -- Not one of special cases above
19524 -- Using previously computed scope. If the elaboration check is
19525 -- done after analysis, the scope is not visible any longer, but
19526 -- must still be in the context.
19531 Activate_Elaborate_All_Desirable (Call, Elab_Unit);
19532 Set_Suppress_Elaboration_Warnings (Elab_Unit);
19533 end Set_Elaboration_Constraint;
19539 function Spec_Entity (E : Entity_Id) return Entity_Id is
19543 -- Check for case of body entity
19544 -- Why is the check for E_Void needed???
19546 if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then
19550 Decl := Parent (Decl);
19551 exit when Nkind (Decl) in N_Proper_Body;
19554 return Corresponding_Spec (Decl);
19565 function Within (E1, E2 : Entity_Id) return Boolean is
19572 elsif Scop = Standard_Standard then
19575 Scop := Scope (Scop);
19580 --------------------------
19581 -- Within_Elaborate_All --
19582 --------------------------
19584 function Within_Elaborate_All
19585 (Unit : Unit_Number_Type;
19586 E : Entity_Id) return Boolean
19588 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
19589 pragma Pack (Unit_Number_Set);
19591 Seen : Unit_Number_Set := (others => False);
19592 -- Seen (X) is True after we have seen unit X in the walk. This is used
19593 -- to prevent processing the same unit more than once.
19595 Result : Boolean := False;
19597 procedure Helper (Unit : Unit_Number_Type);
19598 -- This helper procedure does all the work for Within_Elaborate_All. It
19599 -- walks the dependency graph, and sets Result to True if it finds an
19600 -- appropriate Elaborate_All.
19606 procedure Helper (Unit : Unit_Number_Type) is
19607 CU : constant Node_Id := Cunit (Unit);
19611 Elab_Id : Entity_Id;
19615 if Seen (Unit) then
19618 Seen (Unit) := True;
19621 -- First, check for Elaborate_Alls on this unit
19623 Item := First (Context_Items (CU));
19624 while Present (Item) loop
19625 if Nkind (Item) = N_Pragma
19626 and then Pragma_Name (Item) = Name_Elaborate_All
19628 -- Return if some previous error on the pragma itself. The
19629 -- pragma may be unanalyzed, because of a previous error, or
19630 -- if it is the context of a subunit, inherited by its parent.
19632 if Error_Posted (Item) or else not Analyzed (Item) then
19638 (Expression (First (Pragma_Argument_Associations (Item))));
19640 if E = Elab_Id then
19645 Par := Parent (Unit_Declaration_Node (Elab_Id));
19647 Item2 := First (Context_Items (Par));
19648 while Present (Item2) loop
19649 if Nkind (Item2) = N_With_Clause
19650 and then Entity (Name (Item2)) = E
19651 and then not Limited_Present (Item2)
19664 -- Second, recurse on with's. We could do this as part of the above
19665 -- loop, but it's probably more efficient to have two loops, because
19666 -- the relevant Elaborate_All is likely to be on the initial unit. In
19667 -- other words, we're walking the with's breadth-first. This part is
19668 -- only necessary in the dynamic elaboration model.
19670 if Dynamic_Elaboration_Checks then
19671 Item := First (Context_Items (CU));
19672 while Present (Item) loop
19673 if Nkind (Item) = N_With_Clause
19674 and then not Limited_Present (Item)
19676 -- Note: the following call to Get_Cunit_Unit_Number does a
19677 -- linear search, which could be slow, but it's OK because
19678 -- we're about to give a warning anyway. Also, there might
19679 -- be hundreds of units, but not millions. If it turns out
19680 -- to be a problem, we could store the Get_Cunit_Unit_Number
19681 -- in each N_Compilation_Unit node, but that would involve
19682 -- rearranging N_Compilation_Unit_Aux to make room.
19684 Helper (Get_Cunit_Unit_Number (Library_Unit (Item)));
19696 -- Start of processing for Within_Elaborate_All
19701 end Within_Elaborate_All;