1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1997-2017, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Debug; use Debug;
28 with Einfo; use Einfo;
29 with Errout; use Errout;
30 with Exp_Ch11; use Exp_Ch11;
31 with Exp_Tss; use Exp_Tss;
32 with Exp_Util; use Exp_Util;
34 with Lib.Load; use Lib.Load;
35 with Namet; use Namet;
36 with Nlists; use Nlists;
37 with Nmake; use Nmake;
39 with Restrict; use Restrict;
40 with Rident; use Rident;
41 with Rtsfind; use Rtsfind;
43 with Sem_Aux; use Sem_Aux;
44 with Sem_Ch7; use Sem_Ch7;
45 with Sem_Ch8; use Sem_Ch8;
46 with Sem_Prag; use Sem_Prag;
47 with Sem_Util; use Sem_Util;
48 with Sinfo; use Sinfo;
49 with Snames; use Snames;
50 with Stand; use Stand;
52 with Tbuild; use Tbuild;
53 with Uintp; use Uintp;
54 with Uname; use Uname;
56 with GNAT.HTable; use GNAT.HTable;
58 package body Sem_Elab is
60 -----------------------------------------
61 -- Access-before-elaboration mechanism --
62 -----------------------------------------
64 -- The access-before-elaboration (ABE) mechanism implemented in this unit
65 -- has the following objectives:
67 -- * Diagnose at compile-time or install run-time checks to prevent ABE
68 -- access to data and behaviour.
70 -- The high level idea is to accurately diagnose ABE issues within a
71 -- single unit because the ABE mechanism can inspect the whole unit.
72 -- As soon as the elaboration graph extends to an external unit, the
73 -- diagnostics stop because the body of the unit may not be available.
74 -- Due to control and data flow, the ABE mechanism cannot accurately
75 -- determine whether a particular scenario will be elaborated or not.
76 -- Conditional ABE checks are therefore used to verify the elaboration
77 -- status of a local and external target at run time.
79 -- * Supply elaboration dependencies for a unit to binde
81 -- The ABE mechanism registers each outgoing elaboration edge for the
82 -- main unit in its ALI file. GNATbind and binde can then reconstruct
83 -- the full elaboration graph and determine the proper elaboration
84 -- order for all units in the compilation.
86 -- The ABE mechanism supports three models of elaboration:
88 -- * Dynamic model - This is the most permissive of the three models.
89 -- When the dynamic model is in effect, the mechanism performs very
90 -- little diagnostics and generates run-time checks to detect ABE
91 -- issues. The behaviour of this model is identical to that specified
92 -- by the Ada RM. This model is enabled with switch -gnatE.
94 -- * Static model - This is the middle ground of the three models. When
95 -- the static model is in effect, the mechanism diagnoses and installs
96 -- run-time checks to detect ABE issues in the main unit. In addition,
97 -- the mechanism generates implicit Elaborate or Elaborate_All pragmas
98 -- to ensure the prior elaboration of withed units. The model employs
99 -- textual order, with clause context, and elaboration-related source
100 -- pragmas. This is the default model.
102 -- * SPARK model - This is the most conservative of the three models and
103 -- impelements the semantics defined in SPARK RM 7.7. The SPARK model
104 -- is in effect only when a context resides in a SPARK_Mode On region,
105 -- otherwise the mechanism falls back to one of the previous models.
107 -- The ABE mechanism consists of a "recording" phase and a "processing"
114 -- * Bridge target - A type of target. A bridge target is a link between
115 -- scenarios. It is usually a byproduct of expansion and does not have
116 -- any direct ABE ramifications.
118 -- * Call marker - A special node used to indicate the presence of a call
119 -- in the tree in case expansion transforms or eliminates the original
120 -- call. N_Call_Marker nodes do not have static and run-time semantics.
122 -- * Conditional ABE - A type of ABE. A conditional ABE occurs when the
123 -- elaboration or invocation of a target by a scenario within the main
124 -- unit causes an ABE, but does not cause an ABE for another scenarios
125 -- within the main unit.
127 -- * Declaration level - A type of enclosing level. A scenario or target is
128 -- at the declaration level when it appears within the declarations of a
129 -- block statement, entry body, subprogram body, or task body, ignoring
130 -- enclosing packges.
132 -- * Generic library level - A type of enclosing level. A scenario or
133 -- target is at the generic library level if it appears in a generic
134 -- package library unit, ignoring enclosing packages.
136 -- * Guaranteed ABE - A type of ABE. A guaranteed ABE occurs when the
137 -- elaboration or invocation of a target by all scenarios within the
138 -- main unit causes an ABE.
140 -- * Instantiation library level - A type of enclosing level. A scenario
141 -- or target is at the instantiation library level if it appears in an
142 -- instantiation library unit, ignoring enclosing packages.
144 -- * Library level - A type of enclosing level. A scenario or target is at
145 -- the library level if it appears in a package library unit, ignoring
146 -- enclosng packages.
148 -- * Non-library level encapsulator - A construct that cannot be elaborated
149 -- on its own and requires elaboration by a top level scenario.
151 -- * Scenario - A construct or context which may be elaborated or executed
152 -- by elaboration code. The scenarios recognized by the ABE mechanism are
155 -- - '[Unrestricted_]Access of entries, operators, and subprograms
157 -- - Assignments to variables
159 -- - Calls to entries, operators, and subprograms
163 -- - Reads of variables
167 -- * Target - A construct referenced by a scenario. The targets recognized
168 -- by the ABE mechanism are as follows:
170 -- - For '[Unrestricted_]Access of entries, operators, and subprograms,
171 -- the target is the entry, operator, or subprogram.
173 -- - For assignments to variables, the target is the variable
175 -- - For calls, the target is the entry, operator, or subprogram
177 -- - For instantiations, the target is the generic template
179 -- - For reads of variables, the target is the variable
181 -- - For task activation, the target is the task body
183 -- * Top level scenario - A scenario which appears in a non-generic main
184 -- unit. Depending on the elaboration model is in effect, the following
185 -- addotional restrictions apply:
187 -- - Dynamic model - No restrictions
189 -- - SPARK model - Falls back to either the dynamic or static model
191 -- - Static model - The scenario must be at the library level
193 ---------------------
194 -- Recording phase --
195 ---------------------
197 -- The Recording phase coincides with the analysis/resolution phase of the
198 -- compiler. It has the following objectives:
200 -- * Record all top level scenarios for examination by the Processing
203 -- Saving only a certain number of nodes improves the performance of
204 -- the ABE mechanism. This eliminates the need to examine the whole
205 -- tree in a separate pass.
207 -- * Detect and diagnose calls in preelaborable or pure units, including
210 -- This diagnostic is carried out during the Recording phase because it
211 -- does not need the heavy recursive traversal done by the Processing
214 -- * Detect and diagnose guaranteed ABEs caused by instantiations,
215 -- calls, and task activation.
217 -- The issues detected by the ABE mechanism are reported as warnings
218 -- because they do not violate Ada semantics. Forward instantiations
219 -- may thus reach gigi, however gigi cannot handle certain kinds of
220 -- premature instantiations and may crash. To avoid this limitation,
221 -- the ABE mechanism must identify forward instantiations as early as
222 -- possible and suppress their bodies. Calls and task activations are
223 -- included in this category for completeness.
225 ----------------------
226 -- Processing phase --
227 ----------------------
229 -- The Processing phase is a separate pass which starts after instantiating
230 -- and/or inlining of bodies, but before the removal of Ghost code. It has
231 -- the following objectives:
233 -- * Examine all top level scenarios saved during the Recording phase
235 -- The top level scenarios act as roots for depth-first traversal of
236 -- the call/instantiation/task activation graph. The traversal stops
237 -- when an outgoing edge leaves the main unit.
239 -- * Depending on the elaboration model in effect, perform the following
242 -- - Dynamic model - Diagnose guaranteed ABEs and install run-time
243 -- conditional ABE checks.
245 -- - SPARK model - Enforce the SPARK elaboration rules
247 -- - Static model - Diagnose conditional/guaranteed ABEs, install
248 -- run-time conditional ABE checks, and guarantee the elaboration
249 -- of external units.
251 -- * Examine nested scenarios
253 -- Nested scenarios discovered during the depth-first traversal are
254 -- in turn subjected to the same actions outlined above and examined
255 -- for the next level of nested scenarios.
261 -- +------------------------ Recording phase ---------------------------+
263 -- | Record_Elaboration_Scenario |
265 -- | +--> Check_Preelaborated_Call |
267 -- | +--> Process_Guaranteed_ABE |
269 -- +------------------------- | --------------------------------------+
273 -- Top_Level_Scenarios
274 -- +-----------+-----------+ .. +-----------+
275 -- | Scenario1 | Scenario2 | .. | ScenarioN |
276 -- +-----------+-----------+ .. +-----------+
279 -- +------------------------- | --------------------------------------+
281 -- | Check_Elaboration_Scenarios |
284 -- | +----------- Process_Scenario <-----------+ |
286 -- | +--> Process_Access Is_Suitable_Scenario |
288 -- | +--> Process_Activation_Call --+ | |
289 -- | | +---> Traverse_Body |
290 -- | +--> Process_Call -------------+ |
292 -- | +--> Process_Instantiation |
294 -- | +--> Process_Variable_Assignment |
296 -- | +--> Process_Variable_Read |
298 -- +------------------------- Processing phase -------------------------+
300 ----------------------
301 -- Important points --
302 ----------------------
304 -- The Processing phase starts after the analysis, resolution, expansion
305 -- phase has completed. As a result, no current semantic information is
306 -- available. The scope stack is empty, global flags such as In_Instance
307 -- or Inside_A_Generic become useless. To remedy this, the ABE mechanism
308 -- must either save or recompute semantic information.
310 -- Expansion heavily transforms calls and to some extent instantiations. To
311 -- remedy this, the ABE mechanism generates N_Call_Marker nodes in order to
312 -- capture the target and relevant attributes of the original call.
314 -- The diagnostics of the ABE mechanism depend on accurate source locations
315 -- to determine the spacial relation of nodes.
321 -- The following switches may be used to control the behavior of the ABE
324 -- -gnatdE elaboration checks on predefined units
326 -- The ABE mechanism considers scenarios which appear in internal
327 -- units (Ada, GNAT, Interfaces, System).
329 -- -gnatd.G ignore calls through generic formal parameters for elaboration
331 -- The ABE mechanism does not generate N_Call_Marker nodes for
332 -- calls which occur in expanded instances, and invoke generic
333 -- actual subprograms through generic formal subprograms. As a
334 -- result, the calls are not recorded or processed.
336 -- If switches -gnatd.G and -gnatdL are used together, then the
337 -- ABE mechanism effectively ignores all calls which cause the
338 -- elaboration flow to "leave" the instance.
340 -- -gnatdL ignore external calls from instances for elaboration
342 -- The ABE mechanism does not generate N_Call_Marker nodes for
343 -- calls which occur in expanded instances, do not invoke generic
344 -- actual subprograms through formal subprograms, and the target
345 -- is external to the instance. As a result, the calls are not
346 -- recorded or processed.
348 -- If switches -gnatd.G and -gnatdL are used together, then the
349 -- ABE mechanism effectively ignores all calls which cause the
350 -- elaboration flow to "leave" the instance.
352 -- -gnatd.o conservative elaboration order for indirect calls
354 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
355 -- operator, or subprogram as an immediate invocation of the
356 -- target. As a result, it performs ABE checks and diagnostics on
357 -- the immediate call.
359 -- -gnatd.U ignore indirect calls for static elaboration
361 -- The ABE mechanism does not consider '[Unrestricted_]Access of
362 -- entries, operators, and subprograms. As a result, the scenarios
363 -- are not recorder or processed.
365 -- -gnatd.v enforce SPARK elaboration rules in SPARK code
367 -- The ABE mechanism applies some of the SPARK elaboration rules
368 -- defined in the SPARK reference manual, chapter 7.7. Note that
369 -- certain rules are always enforced, regardless of whether the
372 -- -gnatd.y disable implicit pragma Elaborate_All on task bodies
374 -- The ABE mechanism does not generate implicit Elaborate_All when
375 -- the need for the pragma came from a task body.
377 -- -gnatE dynamic elaboration checking mode enabled
379 -- The ABE mechanism assumes that any scenario is elaborated or
380 -- invoked by elaboration code. The ABE mechanism performs very
381 -- little diagnostics and generates condintional ABE checks to
382 -- detect ABE issues at run-time.
384 -- -gnatel turn on info messages on generated Elaborate[_All] pragmas
386 -- The ABE mechanism produces information messages on generated
387 -- implicit Elabote[_All] pragmas along with traceback showing
388 -- why the pragma was generated. In addition, the ABE mechanism
389 -- produces information messages for each scenario elaborated or
390 -- invoked by elaboration code.
392 -- -gnateL turn off info messages on generated Elaborate[_All] pragmas
394 -- The complimentary switch for -gnatel.
396 -- -gnatwl turn on warnings for elaboration problems
398 -- The ABE mechanism produces warnings on detected ABEs along with
399 -- traceback showing the graph of the ABE.
401 -- -gnatwL turn off warnings for elaboration problems
403 -- The complimentary switch for -gnatwl.
405 -- -gnatw.f turn on warnings for suspicious Subp'Access
407 -- The ABE mechanism treats '[Unrestricted_]Access of an entry,
408 -- operator, or subprogram as a pseudo invocation of the target.
409 -- As a result, it performs ABE diagnostics on the pseudo call.
411 -- -gnatw.F turn off warnings for suspicious Subp'Access
413 -- The complimentary switch for -gnatw.f.
415 ---------------------------
416 -- Adding a new scenario --
417 ---------------------------
419 -- The following steps describe how to add a new elaboration scenario and
420 -- preserve the existing architecture.
422 -- 1) If necessary, update predicates Is_Check_Emitting_Scenario and
425 -- 2) Add predicate Is_Suitable_xxx. Include a call to it in predicate
426 -- Is_Suitable_Scenario.
428 -- 3) Update routine Record_Elaboration_Scenario
430 -- 4) Add routine Process_xxx. Include a call to it in Process_Scenario.
432 -- 5) Add routine Info_xxx. Include a call to it in Process_xxx.
434 -- 6) Add routine Output_xxx. Include a call to it in routine
435 -- Output_Active_Scenarios.
437 -- 7) If necessary, add a new Extract_xxx_Attributes routine
439 -- 8) If necessary, update routine Is_Potential_Scenario
441 -------------------------
442 -- Adding a new target --
443 -------------------------
445 -- The following steps describe how to add a new elaboration target and
446 -- preserve the existing architecture.
448 -- 1) Add predicate Is_xxx.
450 -- 2) Update predicates Is_Ada_Semantic_Target, Is_Bridge_Target, or
451 -- Is_SPARK_Semantic_Target. If necessary, create a new category.
453 -- 3) Update the appropriate Info_xxx routine.
455 -- 4) Update the appropriate Output_xxx routine.
457 -- 5) Update routine Extract_Target_Attributes. If necessary, create a
458 -- new Extract_xxx routine.
460 --------------------------
461 -- Debugging ABE issues --
462 --------------------------
464 -- * If the issue involves a call, ensure that the call is eligible for ABE
465 -- processing and receives a corresponding call marker. The routines of
469 -- Record_Elaboration_Scenario
471 -- * If the issue involves an arbitrary scenario, ensure that the scenario
472 -- is either recorded, or is successfully recognized while traversing a
473 -- body. The routines of interest are
475 -- Record_Elaboration_Scenario
479 -- * If the issue involves a circularity in the elaboration order, examine
480 -- the ALI files and look for the following encodings next to units:
482 -- E indicates a source Elaborate
484 -- EA indicates a source Elaborate_All
486 -- AD indicates an implicit Elaborate_All
488 -- ED indicates an implicit Elaborate
490 -- If possible, compare these encodings with those generated by the old
491 -- ABE mechanism. The routines of interest are
493 -- Ensure_Prior_Elaboration
499 -- The following type captures relevant attributes which pertain to a call
501 type Call_Attributes is record
502 Elab_Checks_OK : Boolean;
503 -- This flag is set when the call has elaboration checks enabled
505 From_Source : Boolean;
506 -- This flag is set when the call comes from source
508 Ghost_Mode_Ignore : Boolean;
509 -- This flag is set when the call appears in a region subject to pragma
510 -- Ghost with policy Ignore.
512 In_Declarations : Boolean;
513 -- This flag is set when the call appears at the declaration level
515 Is_Dispatching : Boolean;
516 -- This flag is set when the call is dispatching
518 SPARK_Mode_On : Boolean;
519 -- This flag is set when the call appears in a region subject to pragma
520 -- SPARK_Mode with value On.
523 -- The following type captures relevant attributes which pertain to the
524 -- prior elaboration of a unit. This type is coupled together with a unit
525 -- to form a key -> value relationship.
527 type Elaboration_Attributes is record
528 Source_Pragma : Node_Id;
529 -- This attribute denotes a source Elaborate or Elaborate_All pragma
530 -- which guarantees the prior elaboration of some unit with respect
531 -- to the main unit. The pragma may come from the following contexts:
534 -- * The spec of the main unit (if applicable)
535 -- * Any parent spec of the main unit (if applicable)
536 -- * Any parent subunit of the main unit (if applicable)
538 -- The attribute remains Empty if no such pragma is available. Source
539 -- pragmas play a role in satisfying SPARK elaboration requirements.
541 With_Clause : Node_Id;
542 -- This attribute denotes an internally generated or source with clause
543 -- for some unit withed by the main unit. With clauses carry flags which
544 -- represent implicit Elaborate or Elaborate_All pragmas. These clauses
545 -- play a role in supplying the elaboration dependencies to binde.
548 No_Elaboration_Attributes : constant Elaboration_Attributes :=
549 (Source_Pragma => Empty,
550 With_Clause => Empty);
552 -- The following type captures relevant attributes which pertain to an
555 type Instantiation_Attributes is record
556 Elab_Checks_OK : Boolean;
557 -- This flag is set when the instantiation has elaboration checks
560 Ghost_Mode_Ignore : Boolean;
561 -- This flag is set when the instantiation appears in a region subject
562 -- to pragma Ghost with policy ignore, or starts one such region.
564 In_Declarations : Boolean;
565 -- This flag is set when the instantiation appears at the declaration
568 SPARK_Mode_On : Boolean;
569 -- This flag is set when the instantiation appears in a region subject
570 -- to pragma SPARK_Mode with value On, or starts one such region.
573 -- The following type captures relevant attributes which pertain to a
576 type Target_Attributes is record
577 Elab_Checks_OK : Boolean;
578 -- This flag is set when the target has elaboration checks enabled
580 From_Source : Boolean;
581 -- This flag is set when the target comes from source
583 Ghost_Mode_Ignore : Boolean;
584 -- This flag is set when the target appears in a region subject to
585 -- pragma Ghost with policy ignore, or starts one such region.
587 SPARK_Mode_On : Boolean;
588 -- This flag is set when the target appears in a region subject to
589 -- pragma SPARK_Mode with value On, or starts one such region.
592 -- This attribute denotes the declaration of Spec_Id
595 -- This attribute denotes the top unit where Spec_Id resides
597 -- The semantics of the following attributes depend on the target
603 -- The target is a generic package or a subprogram
605 -- * Body_Barf - Empty
607 -- * Body_Decl - This attribute denotes the generic or subprogram
610 -- * Spec_Id - This attribute denotes the entity of the generic
611 -- package or subprogram.
613 -- The target is a protected entry
615 -- * Body_Barf - This attribute denotes the body of the barrier
616 -- function if expansion took place, otherwise it is Empty.
618 -- * Body_Decl - This attribute denotes the body of the procedure
619 -- which emulates the entry if expansion took place, otherwise it
620 -- denotes the body of the protected entry.
622 -- * Spec_Id - This attribute denotes the entity of the procedure
623 -- which emulates the entry if expansion took place, otherwise it
624 -- denotes the protected entry.
626 -- The target is a protected subprogram
628 -- * Body_Barf - Empty
630 -- * Body_Decl - This attribute denotes the body of the protected or
631 -- unprotected version of the protected subprogram if expansion took
632 -- place, otherwise it denotes the body of the protected subprogram.
634 -- * Spec_Id - This attribute denotes the entity of the protected or
635 -- unprotected version of the protected subprogram if expansion took
636 -- place, otherwise it is the entity of the protected subprogram.
638 -- The target is a task entry
640 -- * Body_Barf - Empty
642 -- * Body_Decl - This attribute denotes the body of the procedure
643 -- which emulates the task body if expansion took place, otherwise
644 -- it denotes the body of the task type.
646 -- * Spec_Id - This attribute denotes the entity of the procedure
647 -- which emulates the task body if expansion took place, otherwise
648 -- it denotes the entity of the task type.
651 -- The following type captures relevant attributes which pertain to a task
654 type Task_Attributes is record
656 -- This attribute denotes the declaration of the procedure body which
657 -- emulates the behaviour of the task body.
659 Elab_Checks_OK : Boolean;
660 -- This flag is set when the task type has elaboration checks enabled
662 Ghost_Mode_Ignore : Boolean;
663 -- This flag is set when the task type appears in a region subject to
664 -- pragma Ghost with policy ignore, or starts one such region.
666 SPARK_Mode_On : Boolean;
667 -- This flag is set when the task type appears in a region subject to
668 -- pragma SPARK_Mode with value On, or starts one such region.
671 -- This attribute denotes the entity of the initial declaration of the
672 -- procedure body which emulates the behaviour of the task body.
675 -- This attribute denotes the declaration of the task type
678 -- This attribute denotes the entity of the compilation unit where the
679 -- task type resides.
682 -- The following type captures relevant attributes which pertain to a
685 type Variable_Attributes is record
686 SPARK_Mode_On : Boolean;
687 -- This flag is set when the variable appears in a region subject to
688 -- pragma SPARK_Mode with value On, or starts one such region.
691 -- This attribute denotes the entity of the compilation unit where the
695 ---------------------
696 -- Data structures --
697 ---------------------
699 -- The following table stores the elaboration status of all units withed by
702 Elaboration_Context_Max : constant := 1009;
704 type Elaboration_Context_Index is range 0 .. Elaboration_Context_Max - 1;
706 function Elaboration_Context_Hash
707 (Key : Entity_Id) return Elaboration_Context_Index;
708 -- Obtain the hash value of entity Key
710 package Elaboration_Context is new Simple_HTable
711 (Header_Num => Elaboration_Context_Index,
712 Element => Elaboration_Attributes,
713 No_Element => No_Elaboration_Attributes,
715 Hash => Elaboration_Context_Hash,
718 -- The following table stores all active scenarios in a recursive traversal
719 -- starting from a top level scenario. This table must be maintained in a
722 package Scenario_Stack is new Table.Table
723 (Table_Component_Type => Node_Id,
724 Table_Index_Type => Int,
725 Table_Low_Bound => 1,
727 Table_Increment => 100,
728 Table_Name => "Scenario_Stack");
730 -- The following table stores all top level scenario saved during the
731 -- Recording phase. The contents of this table act as traversal roots
732 -- later in the Processing phase. This table must be maintained in a
735 package Top_Level_Scenarios is new Table.Table
736 (Table_Component_Type => Node_Id,
737 Table_Index_Type => Int,
738 Table_Low_Bound => 1,
739 Table_Initial => 1000,
740 Table_Increment => 100,
741 Table_Name => "Top_Level_Scenarios");
743 -- The following table stores the bodies of all eligible scenarios visited
744 -- during a traversal starting from a top level scenario. The contents of
745 -- this table must be reset upon each new traversal.
747 Visited_Bodies_Max : constant := 511;
749 type Visited_Bodies_Index is range 0 .. Visited_Bodies_Max - 1;
751 function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index;
752 -- Obtain the hash value of node Key
754 package Visited_Bodies is new Simple_HTable
755 (Header_Num => Visited_Bodies_Index,
759 Hash => Visited_Bodies_Hash,
762 -----------------------
763 -- Local subprograms --
764 -----------------------
766 procedure Check_Preelaborated_Call (Call : Node_Id);
767 -- Determine whether entry, operator, or subprogram call Call appears at
768 -- the library level of a preelaborated unit. Emit an error if this is the
771 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id;
772 pragma Inline (Compilation_Unit);
773 -- Return the N_Compilation_Unit node of unit Unit_Id
775 procedure Elab_Msg_NE
781 pragma Inline (Elab_Msg_NE);
782 -- Wrapper around Error_Msg_NE. Emit message Msg concerning arbitrary node
783 -- N and entity. If flag Info_Msg is set, the routine emits an information
784 -- message, otherwise it emits an error. If flag In_SPARK is set, then
785 -- string " in SPARK" is added to the end of the message.
787 procedure Ensure_Prior_Elaboration
790 In_Task_Body : Boolean);
791 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit.
792 -- N denotes the related scenario. Flag In_Task_Body should be set when the
793 -- need for elaboration is initiated from a task body.
795 procedure Ensure_Prior_Elaboration_Dynamic
799 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
800 -- by suggesting the use of Elaborate[_All] with name Prag_Nam. N denotes
801 -- the related scenario.
803 procedure Ensure_Prior_Elaboration_Static
807 -- Guarantee the elaboration of unit Unit_Id with respect to the main unit
808 -- by installing an implicit Elaborate[_All] pragma with name Prag_Nam. N
809 -- denotes the related scenario.
811 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id;
812 pragma Inline (Extract_Assignment_Name);
813 -- Obtain the Name attribute of assignment statement Asmt
815 procedure Extract_Call_Attributes
817 Target_Id : out Entity_Id;
818 Attrs : out Call_Attributes);
819 pragma Inline (Extract_Call_Attributes);
820 -- Obtain attributes Attrs associated with call Call. Target_Id is the
821 -- entity of the call target.
823 function Extract_Call_Name (Call : Node_Id) return Node_Id;
824 pragma Inline (Extract_Call_Name);
825 -- Obtain the Name attribute of entry or subprogram call Call
827 procedure Extract_Instance_Attributes
829 Inst_Body : out Node_Id;
830 Inst_Decl : out Node_Id);
831 pragma Inline (Extract_Instance_Attributes);
832 -- Obtain body Inst_Body and spec Inst_Decl of expanded instance Exp_Inst
834 procedure Extract_Instantiation_Attributes
837 Inst_Id : out Entity_Id;
838 Gen_Id : out Entity_Id;
839 Attrs : out Instantiation_Attributes);
840 pragma Inline (Extract_Instantiation_Attributes);
841 -- Obtain attributes Attrs associated with expanded instantiation Exp_Inst.
842 -- Inst is the instantiation. Inst_Id is the entity of the instance. Gen_Id
843 -- is the entity of the generic unit being instantiated.
845 procedure Extract_Target_Attributes
846 (Target_Id : Entity_Id;
847 Attrs : out Target_Attributes);
848 -- Obtain attributes Attrs associated with an entry, package, or subprogram
849 -- denoted by Target_Id.
851 procedure Extract_Task_Attributes
853 Attrs : out Task_Attributes);
854 pragma Inline (Extract_Task_Attributes);
855 -- Obtain attributes Attrs associated with task type Typ
857 procedure Extract_Variable_Reference_Attributes
859 Var_Id : out Entity_Id;
860 Attrs : out Variable_Attributes);
861 pragma Inline (Extract_Variable_Reference_Attributes);
862 -- Obtain attributes Attrs associated with reference Ref that mentions
865 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id;
866 pragma Inline (Find_Code_Unit);
867 -- Return the code unit which contains arbitrary node or entity N. This
868 -- is the unit of the file which physically contains the related construct
869 -- denoted by N except when N is within an instantiation. In that case the
870 -- unit is that of the top level instantiation.
872 procedure Find_Elaborated_Units;
873 -- Populate table Elaboration_Context with all units which have prior
874 -- elaboration with respect to the main unit.
876 function Find_Enclosing_Instance (N : Node_Id) return Node_Id;
877 pragma Inline (Find_Enclosing_Instance);
878 -- Find the declaration or body of the nearest expanded instance which
879 -- encloses arbitrary node N. Return Empty if no such instance exists.
881 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id;
882 pragma Inline (Find_Top_Unit);
883 -- Return the top unit which contains arbitrary node or entity N. The unit
884 -- is obtained by logically unwinding instantiations and subunits when N
885 -- resides within one.
887 function Find_Unit_Entity (N : Node_Id) return Entity_Id;
888 pragma Inline (Find_Unit_Entity);
889 -- Return the entity of unit N
891 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id;
892 pragma Inline (First_Formal_Type);
893 -- Return the type of subprogram Subp_Id's first formal parameter. If the
894 -- subprogram lacks formal parameters, return Empty.
896 function Has_Body (Pack_Decl : Node_Id) return Boolean;
897 -- Determine whether package declaration Pack_Decl has a corresponding body
898 -- or would eventually have one.
900 function Has_Prior_Elaboration
901 (Unit_Id : Entity_Id;
902 Context_OK : Boolean := False;
903 Elab_Body_OK : Boolean := False;
904 Same_Unit_OK : Boolean := False) return Boolean;
905 pragma Inline (Has_Prior_Elaboration);
906 -- Determine whether unit Unit_Id is elaborated prior to the main unit.
907 -- If flag Context_OK is set, the routine considers the following case
908 -- as valid prior elaboration:
910 -- * Unit_Id is in the elaboration context of the main unit
912 -- If flag Elab_Body_OK is set, the routine considers the following case
913 -- as valid prior elaboration:
915 -- * Unit_Id has pragma Elaborate_Body and is not the main unit
917 -- If flag Same_Unit_OK is set, the routine considers the following cases
918 -- as valid prior elaboration:
920 -- * Unit_Id is the main unit
922 -- * Unit_Id denotes the spec of the main unit body
924 function In_External_Instance
926 Target_Decl : Node_Id) return Boolean;
927 pragma Inline (In_External_Instance);
928 -- Determine whether a target desctibed by its declaration Target_Decl
929 -- resides in a package instance which is external to scenario N.
931 function In_Main_Context (N : Node_Id) return Boolean;
932 pragma Inline (In_Main_Context);
933 -- Determine whether arbitrary node N appears within the main compilation
936 function In_Same_Context
939 Nested_OK : Boolean := False) return Boolean;
940 -- Determine whether two arbitrary nodes N1 and N2 appear within the same
941 -- context ignoring enclosing library levels. Nested_OK should be set when
942 -- the context of N1 can enclose that of N2.
946 Target_Id : Entity_Id;
949 -- Output information concerning call Call which invokes target Target_Id.
950 -- If flag Info_Msg is set, the routine emits an information message,
951 -- otherwise it emits an error. If flag In_SPARK is set, then the string
952 -- " in SPARK" is added to the end of the message.
954 procedure Info_Instantiation
959 pragma Inline (Info_Instantiation);
960 -- Output information concerning instantiation Inst which instantiates
961 -- generic unit Gen_Id. If flag Info_Msg is set, the routine emits an
962 -- information message, otherwise it emits an error. If flag In_SPARK
963 -- is set, then string " in SPARK" is added to the end of the message.
965 procedure Info_Variable_Read
970 pragma Inline (Info_Variable_Read);
971 -- Output information concerning reference Ref which reads variable Var_Id.
972 -- If flag Info_Msg is set, the routine emits an information message,
973 -- otherwise it emits an error. If flag In_SPARK is set, then string " in
974 -- SPARK" is added to the end of the message.
976 function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id;
977 pragma Inline (Insertion_Node);
978 -- Obtain the proper insertion node of an ABE check or failure for scenario
979 -- N and candidate insertion node Ins_Nod.
981 procedure Install_ABE_Check
985 -- Insert a run-time ABE check for elaboration scenario N which verifies
986 -- whether arbitrary entity Id is elaborated. The check in inserted prior
989 procedure Install_ABE_Check
991 Target_Id : Entity_Id;
992 Target_Decl : Node_Id;
993 Target_Body : Node_Id;
995 -- Insert a run-time ABE check for elaboration scenario N which verifies
996 -- whether target Target_Id with initial declaration Target_Decl and body
997 -- Target_Body is elaborated. The check is inserted prior to node Ins_Nod.
999 procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id);
1000 -- Insert a Program_Error concerning a guaranteed ABE for elaboration
1001 -- scenario N. The failure is inserted prior to node Node_Id.
1003 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean;
1004 pragma Inline (Is_Accept_Alternative_Proc);
1005 -- Determine whether arbitrary entity Id denotes an internally generated
1006 -- procedure which encapsulates the statements of an accept alternative.
1008 function Is_Activation_Proc (Id : Entity_Id) return Boolean;
1009 pragma Inline (Is_Activation_Proc);
1010 -- Determine whether arbitrary entity Id denotes a runtime procedure in
1011 -- charge with activating tasks.
1013 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean;
1014 pragma Inline (Is_Ada_Semantic_Target);
1015 -- Determine whether arbitrary entity Id nodes a source or internally
1016 -- generated subprogram which emulates Ada semantics.
1018 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean;
1019 pragma Inline (Is_Bodiless_Subprogram);
1020 -- Determine whether subprogram Subp_Id will never have a body
1022 function Is_Check_Emitting_Scenario (N : Node_Id) return Boolean;
1023 pragma Inline (Is_Check_Emitting_Scenario);
1024 -- Determine whether arbitrary node N denotes a scenario which may emit a
1025 -- conditional ABE check.
1027 function Is_Controlled_Proc
1028 (Subp_Id : Entity_Id;
1029 Subp_Nam : Name_Id) return Boolean;
1030 pragma Inline (Is_Controlled_Proc);
1031 -- Determine whether subprogram Subp_Id denotes controlled type primitives
1032 -- Adjust, Finalize, or Initialize as denoted by name Subp_Nam.
1034 function Is_Default_Initial_Condition_Proc (Id : Entity_Id) return Boolean;
1035 pragma Inline (Is_Default_Initial_Condition_Proc);
1036 -- Determine whether arbitrary entity Id denotes internally generated
1037 -- routine Default_Initial_Condition.
1039 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean;
1040 pragma Inline (Is_Finalizer_Proc);
1041 -- Determine whether arbitrary entity Id denotes internally generated
1042 -- routine _Finalizer.
1044 function Is_Guaranteed_ABE
1046 Target_Decl : Node_Id;
1047 Target_Body : Node_Id) return Boolean;
1048 pragma Inline (Is_Guaranteed_ABE);
1049 -- Determine whether scenario N with a target described by its initial
1050 -- declaration Target_Decl and body Target_Decl results in a guaranteed
1053 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean;
1054 pragma Inline (Is_Initial_Condition_Proc);
1055 -- Determine whether arbitrary entity Id denotes internally generated
1056 -- routine Initial_Condition.
1058 function Is_Initialized (Obj_Decl : Node_Id) return Boolean;
1059 pragma Inline (Is_Initialized);
1060 -- Determine whether object declaration Obj_Decl is initialized
1062 function Is_Invariant_Proc (Id : Entity_Id) return Boolean;
1063 pragma Inline (Is_Invariant_Proc);
1064 -- Determine whether arbitrary entity Id denotes an invariant procedure
1066 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean;
1067 pragma Inline (Is_Non_Library_Level_Encapsulator);
1068 -- Determine whether arbitrary node N is a non-library encapsulator
1070 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean;
1071 pragma Inline (Is_Partial_Invariant_Proc);
1072 -- Determine whether arbitrary entity Id denotes a partial invariant
1075 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean;
1076 pragma Inline (Is_Postconditions_Proc);
1077 -- Determine whether arbitrary entity Id denotes internally generated
1078 -- routine _Postconditions.
1080 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean;
1081 pragma Inline (Is_Preelaborated_Unit);
1082 -- Determine whether arbitrary entity Id denotes a unit which is subject to
1083 -- one of the following pragmas:
1087 -- * Remote_Call_Interface
1091 function Is_Protected_Entry (Id : Entity_Id) return Boolean;
1092 pragma Inline (Is_Protected_Entry);
1093 -- Determine whether arbitrary entity Id denotes a protected entry
1095 function Is_Protected_Subp (Id : Entity_Id) return Boolean;
1096 pragma Inline (Is_Protected_Subp);
1097 -- Determine whether entity Id denotes a protected subprogram
1099 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean;
1100 pragma Inline (Is_Protected_Body_Subp);
1101 -- Determine whether entity Id denotes the protected or unprotected version
1102 -- of a protected subprogram.
1104 function Is_Safe_Activation
1106 Task_Decl : Node_Id) return Boolean;
1107 pragma Inline (Is_Safe_Activation);
1108 -- Determine whether call Call which activates a task object described by
1109 -- declaration Task_Decl is always ABE-safe.
1111 function Is_Safe_Call
1113 Target_Attrs : Target_Attributes) return Boolean;
1114 pragma Inline (Is_Safe_Call);
1115 -- Determine whether call Call which invokes a target described by
1116 -- attributes Target_Attrs is always ABE-safe.
1118 function Is_Safe_Instantiation
1120 Gen_Attrs : Target_Attributes) return Boolean;
1121 pragma Inline (Is_Safe_Instantiation);
1122 -- Determine whether instance Inst which instantiates a generic unit
1123 -- described by attributes Gen_Attrs is always ABE-safe.
1125 function Is_Same_Unit
1126 (Unit_1 : Entity_Id;
1127 Unit_2 : Entity_Id) return Boolean;
1128 pragma Inline (Is_Same_Unit);
1129 -- Determine whether entities Unit_1 and Unit_2 denote the same unit
1131 function Is_Scenario (N : Node_Id) return Boolean;
1132 pragma Inline (Is_Scenario);
1133 -- Determine whether attribute node N denotes a scenario. The scenario may
1134 -- not necessarily be eligible for ABE processing.
1136 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean;
1137 pragma Inline (Is_SPARK_Semantic_Target);
1138 -- Determine whether arbitrary entity Id nodes a source or internally
1139 -- generated subprogram which emulates SPARK semantics.
1141 function Is_Suitable_Access (N : Node_Id) return Boolean;
1142 pragma Inline (Is_Suitable_Access);
1143 -- Determine whether arbitrary node N denotes a suitable attribute for ABE
1146 function Is_Suitable_Call (N : Node_Id) return Boolean;
1147 pragma Inline (Is_Suitable_Call);
1148 -- Determine whether arbitrary node N denotes a suitable call for ABE
1151 function Is_Suitable_Instantiation (N : Node_Id) return Boolean;
1152 pragma Inline (Is_Suitable_Instantiation);
1153 -- Determine whether arbitrary node N is a suitable instantiation for ABE
1156 function Is_Suitable_Scenario (N : Node_Id) return Boolean;
1157 pragma Inline (Is_Suitable_Scenario);
1158 -- Determine whether arbitrary node N is a suitable scenario for ABE
1161 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean;
1162 pragma Inline (Is_Suitable_Variable_Assignment);
1163 -- Determine whether arbitrary node N denotes a suitable assignment for ABE
1166 function Is_Suitable_Variable_Read (N : Node_Id) return Boolean;
1167 pragma Inline (Is_Suitable_Variable_Read);
1168 -- Determine whether arbitrary node N is a suitable variable read for ABE
1171 function Is_Task_Entry (Id : Entity_Id) return Boolean;
1172 pragma Inline (Is_Task_Entry);
1173 -- Determine whether arbitrary entity Id denotes a task entry
1175 function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean;
1176 pragma Inline (Is_Up_Level_Target);
1177 -- Determine whether the current root resides at the declaration level. If
1178 -- this is the case, determine whether a target described by declaration
1179 -- Target_Decl is within a context which encloses the current root or is in
1180 -- a different unit.
1182 procedure Meet_Elaboration_Requirement
1184 Target_Id : Entity_Id;
1186 -- Determine whether elaboration requirement Req_Nam for scenario N with
1187 -- target Target_Id is met by the context of the main unit using the SPARK
1188 -- rules. Req_Nam must denote either Elaborate or Elaborate_All. Emit an
1189 -- error if this is not the case.
1191 function Non_Private_View (Typ : Entity_Id) return Entity_Id;
1192 pragma Inline (Non_Private_View);
1193 -- Return the full view of private type Typ if available, otherwise return
1196 procedure Output_Active_Scenarios (Error_Nod : Node_Id);
1197 -- Output the contents of the active scenario stack from earliest to latest
1198 -- to supplement an earlier error emitted for node Error_Nod.
1200 procedure Pop_Active_Scenario (N : Node_Id);
1201 pragma Inline (Pop_Active_Scenario);
1202 -- Pop the top of the scenario stack. A check is made to ensure that the
1203 -- scenario being removed is the same as N.
1205 procedure Process_Access (Attr : Node_Id; In_Task_Body : Boolean);
1206 -- Perform ABE checks and diagnostics for 'Access to entry, operator, or
1207 -- subprogram denoted by Attr. Flag In_Task_Body should be set when the
1208 -- processing is initiated from a task body.
1211 with procedure Process_Single_Activation
1213 Call_Attrs : Call_Attributes;
1215 Task_Attrs : Task_Attributes;
1216 In_Task_Body : Boolean);
1217 -- Perform ABE checks and diagnostics for task activation call Call
1218 -- which activates task Obj_Id. Call_Attrs are the attributes of the
1219 -- activation call. Task_Attrs are the attributes of the task type.
1220 -- Flag In_Task_Body should be set when the processing is initiated
1221 -- from a task body.
1223 procedure Process_Activation_Call
1225 Call_Attrs : Call_Attributes;
1226 In_Task_Body : Boolean);
1227 -- Perform ABE checks and diagnostics for activation call Call by invoking
1228 -- routine Process_Single_Activation on each task object being activated.
1229 -- Call_Attrs are the attributes of the activation call. Flag In_Task_Body
1230 -- should be set when the processing is initiated from a task body.
1232 procedure Process_Activation_Conditional_ABE_Impl
1234 Call_Attrs : Call_Attributes;
1236 Task_Attrs : Task_Attributes;
1237 In_Task_Body : Boolean);
1238 -- Perform common conditional ABE checks and diagnostics for call Call
1239 -- which activates task Obj_Id ignoring the Ada or SPARK rules. CAll_Attrs
1240 -- are the attributes of the activation call. Task_Attrs are the attributes
1241 -- of the task type. Flag In_Task_Body should be set when the processing is
1242 -- initiated from a task body.
1244 procedure Process_Activation_Guaranteed_ABE_Impl
1246 Call_Attrs : Call_Attributes;
1248 Task_Attrs : Task_Attributes;
1249 In_Task_Body : Boolean);
1250 -- Perform common guaranteed ABE checks and diagnostics for call Call
1251 -- which activates task Obj_Id ignoring the Ada or SPARK rules. CAll_Attrs
1252 -- are the attributes of the activation call. Task_Attrs are the attributes
1253 -- of the task type. Flag In_Task_Body should be set when the processing is
1254 -- initiated from a task body.
1256 procedure Process_Call
1258 Call_Attrs : Call_Attributes;
1259 Target_Id : Entity_Id;
1260 In_Task_Body : Boolean);
1261 -- Top-level dispatcher for processing of calls. Perform ABE checks and
1262 -- diagnostics for call Call which invokes target Target_Id. Call_Attrs
1263 -- are the attributes of the call. Flag In_Task_Body should be set when
1264 -- the processing is initiated from a task body.
1266 procedure Process_Call_Ada
1268 Call_Attrs : Call_Attributes;
1269 Target_Id : Entity_Id;
1270 Target_Attrs : Target_Attributes;
1271 In_Task_Body : Boolean);
1272 -- Perform ABE checks and diagnostics for call Call which invokes target
1273 -- Target_Id using the Ada rules. Call_Attrs are the attributes of the
1274 -- call. Target_Attrs are attributes of the target. Flag In_Task_Body
1275 -- should be set when the processing is initiated from a task body.
1277 procedure Process_Call_Conditional_ABE
1279 Call_Attrs : Call_Attributes;
1280 Target_Id : Entity_Id;
1281 Target_Attrs : Target_Attributes);
1282 -- Perform common conditional ABE checks and diagnostics for call Call that
1283 -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are
1284 -- the attributes of the call. Target_Attrs are attributes of the target.
1286 procedure Process_Call_Guaranteed_ABE
1288 Call_Attrs : Call_Attributes;
1289 Target_Id : Entity_Id);
1290 -- Perform common guaranteed ABE checks and diagnostics for call Call which
1291 -- invokes target Target_Id ignoring the Ada or SPARK rules. Call_Attrs are
1292 -- the attributes of the call.
1294 procedure Process_Call_SPARK
1296 Call_Attrs : Call_Attributes;
1297 Target_Id : Entity_Id;
1298 Target_Attrs : Target_Attributes);
1299 -- Perform ABE checks and diagnostics for call Call which invokes target
1300 -- Target_Id using the SPARK rules. Call_Attrs are the attributes of the
1301 -- call. Target_Attrs are attributes of the target.
1303 procedure Process_Guaranteed_ABE (N : Node_Id);
1304 -- Top level dispatcher for processing of scenarios which result in a
1307 procedure Process_Instantiation
1308 (Exp_Inst : Node_Id;
1309 In_Task_Body : Boolean);
1310 -- Top level dispatcher for processing of instantiations. Perform ABE
1311 -- checks and diagnostics for expanded instantiation Exp_Inst. Flag
1312 -- In_Task_Body should be set when the processing is initiated from a
1315 procedure Process_Instantiation_Ada
1316 (Exp_Inst : Node_Id;
1318 Inst_Attrs : Instantiation_Attributes;
1320 Gen_Attrs : Target_Attributes;
1321 In_Task_Body : Boolean);
1322 -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst
1323 -- of generic Gen_Id using the Ada rules. Inst is the instantiation node.
1324 -- Inst_Attrs are the attributes of the instance. Gen_Attrs are the
1325 -- attributes of the generic. Flag In_Task_Body should be set when the
1326 -- processing is initiated from a task body.
1328 procedure Process_Instantiation_Conditional_ABE
1329 (Exp_Inst : Node_Id;
1331 Inst_Attrs : Instantiation_Attributes;
1333 Gen_Attrs : Target_Attributes);
1334 -- Perform common conditional ABE checks and diagnostics for expanded
1335 -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK
1336 -- rules. Inst is the instantiation node. Inst_Attrs are the attributes
1337 -- of the instance. Gen_Attrs are the attributes of the generic.
1339 procedure Process_Instantiation_Guaranteed_ABE (Exp_Inst : Node_Id);
1340 -- Perform common guaranteed ABE checks and diagnostics for expanded
1341 -- instantiation Exp_Inst of generic Gen_Id ignoring the Ada or SPARK
1344 procedure Process_Instantiation_SPARK
1345 (Exp_Inst : Node_Id;
1347 Inst_Attrs : Instantiation_Attributes;
1349 Gen_Attrs : Target_Attributes);
1350 -- Perform ABE checks and diagnostics for expanded instantiation Exp_Inst
1351 -- of generic Gen_Id using the SPARK rules. Inst is the instantiation node.
1352 -- Inst_Attrs are the attributes of the instance. Gen_Attrs are the
1353 -- attributes of the generic.
1355 procedure Process_Scenario (N : Node_Id; In_Task_Body : Boolean := False);
1356 -- Top level dispatcher for processing of various elaboration scenarios.
1357 -- Perform ABE checks and diagnostics for scenario N. Flag In_Task_Body
1358 -- should be set when the processing is initiated from a task body.
1360 procedure Process_Variable_Assignment (Asmt : Node_Id);
1361 -- Top level dispatcher for processing of variable assignments. Perform ABE
1362 -- checks and diagnostics for assignment statement Asmt.
1364 procedure Process_Variable_Assignment_Ada
1366 Var_Id : Entity_Id);
1367 -- Perform ABE checks and diagnostics for assignment statement Asmt that
1368 -- updates the value of variable Var_Id using the Ada rules.
1370 procedure Process_Variable_Assignment_SPARK
1372 Var_Id : Entity_Id);
1373 -- Perform ABE checks and diagnostics for assignment statement Asmt that
1374 -- updates the value of variable Var_Id using the SPARK rules.
1376 procedure Process_Variable_Read (Ref : Node_Id);
1377 -- Perform ABE checks and diagnostics for reference Ref that reads a
1380 procedure Push_Active_Scenario (N : Node_Id);
1381 pragma Inline (Push_Active_Scenario);
1382 -- Push scenario N on top of the scenario stack
1384 function Root_Scenario return Node_Id;
1385 pragma Inline (Root_Scenario);
1386 -- Return the top level scenario which started a recursive search for other
1387 -- scenarios. It is assumed that there is a valid top level scenario on the
1388 -- active scenario stack.
1390 function Static_Elaboration_Checks return Boolean;
1391 pragma Inline (Static_Elaboration_Checks);
1392 -- Determine whether the static model is in effect
1394 procedure Traverse_Body (N : Node_Id; In_Task_Body : Boolean);
1395 -- Inspect the declarations and statements of subprogram body N for
1396 -- suitable elaboration scenarios and process them. Flag In_Task_Body
1397 -- should be set when the traversal is initiated from a task body.
1399 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id);
1400 pragma Inline (Update_Elaboration_Scenario);
1401 -- Update all relevant internal data structures when scenario Old_N is
1402 -- transformed into scenario New_N by Atree.Rewrite.
1404 -----------------------
1405 -- Build_Call_Marker --
1406 -----------------------
1408 procedure Build_Call_Marker (N : Node_Id) is
1409 function In_External_Context
1411 Target_Id : Entity_Id) return Boolean;
1412 pragma Inline (In_External_Context);
1413 -- Determine whether target Target_Id is external to call N which must
1414 -- reside within an instance.
1416 function In_Premature_Context (Call : Node_Id) return Boolean;
1417 -- Determine whether call Call appears within a premature context
1419 function Is_Bridge_Target (Id : Entity_Id) return Boolean;
1420 pragma Inline (Is_Bridge_Target);
1421 -- Determine whether arbitrary entity Id denotes a bridge target
1423 function Is_Default_Expression (Call : Node_Id) return Boolean;
1424 pragma Inline (Is_Default_Expression);
1425 -- Determine whether call Call acts as the expression of a defaulted
1426 -- parameter within a source call.
1428 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean;
1429 pragma Inline (Is_Generic_Formal_Subp);
1430 -- Determine whether subprogram Subp_Id denotes a generic formal
1431 -- subprogram which appears in the "prologue" of an instantiation.
1433 -------------------------
1434 -- In_External_Context --
1435 -------------------------
1437 function In_External_Context
1439 Target_Id : Entity_Id) return Boolean
1441 Target_Decl : constant Node_Id := Unit_Declaration_Node (Target_Id);
1444 Inst_Body : Node_Id;
1445 Inst_Decl : Node_Id;
1448 -- Performance note: parent traversal
1450 Inst := Find_Enclosing_Instance (Call);
1452 -- The call appears within an instance
1454 if Present (Inst) then
1456 -- The call comes from the main unit and the target does not
1458 if In_Extended_Main_Code_Unit (Call)
1459 and then not In_Extended_Main_Code_Unit (Target_Decl)
1463 -- Otherwise the target declaration must not appear within the
1464 -- instance spec or body.
1467 Extract_Instance_Attributes
1469 Inst_Decl => Inst_Decl,
1470 Inst_Body => Inst_Body);
1472 -- Performance note: parent traversal
1474 return not In_Subtree
1477 Root2 => Inst_Body);
1482 end In_External_Context;
1484 --------------------------
1485 -- In_Premature_Context --
1486 --------------------------
1488 function In_Premature_Context (Call : Node_Id) return Boolean is
1492 -- Climb the parent chain looking for premature contexts
1494 Par := Parent (Call);
1495 while Present (Par) loop
1497 -- Aspect specifications and generic associations are premature
1498 -- contexts because nested calls has not been relocated to their
1501 if Nkind_In (Par, N_Aspect_Specification,
1502 N_Generic_Association)
1506 -- Prevent the search from going too far
1508 elsif Is_Body_Or_Package_Declaration (Par) then
1512 Par := Parent (Par);
1516 end In_Premature_Context;
1518 ----------------------
1519 -- Is_Bridge_Target --
1520 ----------------------
1522 function Is_Bridge_Target (Id : Entity_Id) return Boolean is
1525 Is_Accept_Alternative_Proc (Id)
1526 or else Is_Finalizer_Proc (Id)
1527 or else Is_Partial_Invariant_Proc (Id)
1528 or else Is_Postconditions_Proc (Id)
1529 or else Is_TSS (Id, TSS_Deep_Adjust)
1530 or else Is_TSS (Id, TSS_Deep_Finalize)
1531 or else Is_TSS (Id, TSS_Deep_Initialize);
1532 end Is_Bridge_Target;
1534 ---------------------------
1535 -- Is_Default_Expression --
1536 ---------------------------
1538 function Is_Default_Expression (Call : Node_Id) return Boolean is
1539 Outer_Call : constant Node_Id := Parent (Call);
1540 Outer_Nam : Node_Id;
1543 -- To qualify, the node must appear immediately within a source call
1544 -- which invokes a source target.
1546 if Nkind_In (Outer_Call, N_Entry_Call_Statement,
1548 N_Procedure_Call_Statement)
1549 and then Comes_From_Source (Outer_Call)
1551 Outer_Nam := Extract_Call_Name (Outer_Call);
1554 Is_Entity_Name (Outer_Nam)
1555 and then Present (Entity (Outer_Nam))
1556 and then Is_Subprogram_Or_Entry (Entity (Outer_Nam))
1557 and then Comes_From_Source (Entity (Outer_Nam));
1561 end Is_Default_Expression;
1563 ----------------------------
1564 -- Is_Generic_Formal_Subp --
1565 ----------------------------
1567 function Is_Generic_Formal_Subp (Subp_Id : Entity_Id) return Boolean is
1568 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id);
1569 Context : constant Node_Id := Parent (Subp_Decl);
1572 -- To qualify, the subprogram must rename a generic actual subprogram
1573 -- where the enclosing context is an instantiation.
1576 Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
1577 and then not Comes_From_Source (Subp_Decl)
1578 and then Nkind_In (Context, N_Function_Specification,
1579 N_Package_Specification,
1580 N_Procedure_Specification)
1581 and then Present (Generic_Parent (Context));
1582 end Is_Generic_Formal_Subp;
1586 Call_Attrs : Call_Attributes;
1589 Target_Id : Entity_Id;
1591 -- Start of processing for Build_Call_Marker
1594 -- Nothing to do for ASIS. As a result, ABE checks and diagnostics are
1595 -- not performed in this mode.
1600 -- Nothing to do when the input does not denote a call or a requeue
1602 elsif not Nkind_In (N, N_Entry_Call_Statement,
1604 N_Procedure_Call_Statement,
1605 N_Requeue_Statement)
1609 -- Nothing to do when the call is being preanalyzed as the marker will
1610 -- be inserted in the wrong place.
1612 elsif Preanalysis_Active then
1615 -- Nothing to do when the call is analyzed/resolved too early within an
1616 -- intermediate context.
1618 -- Performance note: parent traversal
1620 elsif In_Premature_Context (N) then
1624 Call_Nam := Extract_Call_Name (N);
1626 -- Nothing to do when the call is erroneous or left in a bad state
1628 if not (Is_Entity_Name (Call_Nam)
1629 and then Present (Entity (Call_Nam))
1630 and then Is_Subprogram_Or_Entry (Entity (Call_Nam)))
1634 -- Nothing to do when the call invokes a generic formal subprogram and
1635 -- switch -gnatd.G (ignore calls through generic formal parameters for
1636 -- elaboration) is in effect. This check must be performed with the
1637 -- direct target of the call to avoid the side effects of mapping
1638 -- actuals to formals using renamings.
1640 elsif Debug_Flag_Dot_GG
1641 and then Is_Generic_Formal_Subp (Entity (Call_Nam))
1646 Extract_Call_Attributes
1648 Target_Id => Target_Id,
1649 Attrs => Call_Attrs);
1651 -- Nothing to do when the call appears within the expanded spec or
1652 -- body of an instantiated generic, the call does not invoke a generic
1653 -- formal subprogram, the target is external to the instance, and switch
1654 -- -gnatdL (ignore external calls from instances for elaboration) is in
1655 -- effect. This behaviour approximates that of the old ABE mechanism.
1658 and then not Is_Generic_Formal_Subp (Entity (Call_Nam))
1660 -- Performance note: parent traversal
1662 and then In_External_Context
1664 Target_Id => Target_Id)
1668 -- Source calls to source targets are always considered because they
1669 -- reflect the original call graph.
1671 elsif Comes_From_Source (Target_Id) and then Call_Attrs.From_Source then
1674 -- A call to a source function which acts as the default expression in
1675 -- another call requires special detection.
1677 elsif Comes_From_Source (Target_Id)
1678 and then Nkind (N) = N_Function_Call
1679 and then Is_Default_Expression (N)
1683 -- The target emulates Ada semantics
1685 elsif Is_Ada_Semantic_Target (Target_Id) then
1688 -- The target acts as a link between scenarios
1690 elsif Is_Bridge_Target (Target_Id) then
1693 -- The target emulates SPARK semantics
1695 elsif Is_SPARK_Semantic_Target (Target_Id) then
1698 -- Otherwise the call is not suitable for ABE processing. This prevents
1699 -- the generation of call markers which will never play a role in ABE
1706 -- At this point it is known that the call will play some role in ABE
1707 -- checks and diagnostics. Create a corresponding call marker in case
1708 -- the original call is heavily transformed by expansion later on.
1710 Marker := Make_Call_Marker (Sloc (N));
1712 -- Inherit the attributes of the original call
1714 Set_Target (Marker, Target_Id);
1715 Set_Is_Elaboration_Checks_OK_Node (Marker, Call_Attrs.Elab_Checks_OK);
1716 Set_Is_Declaration_Level_Node (Marker, Call_Attrs.In_Declarations);
1717 Set_Is_Dispatching_Call (Marker, Call_Attrs.Is_Dispatching);
1718 Set_Is_Ignored_Ghost_Node (Marker, Call_Attrs.Ghost_Mode_Ignore);
1719 Set_Is_Source_Call (Marker, Call_Attrs.From_Source);
1720 Set_Is_SPARK_Mode_On_Node (Marker, Call_Attrs.SPARK_Mode_On);
1722 -- The marker is inserted prior to the original call. This placement has
1723 -- several desirable effects:
1725 -- 1) The marker appears in the same context, in close proximity to
1731 -- 2) Inserting the marker prior to the call ensures that an ABE check
1732 -- will take effect prior to the call.
1738 -- 3) The above two properties are preserved even when the call is a
1739 -- function which is subsequently relocated in order to capture its
1740 -- result. Note that if the call is relocated to a new context, the
1741 -- relocated call will receive a marker of its own.
1745 -- Temp : ... := Func_Call ...;
1748 -- The insertion must take place even when the call does not occur in
1749 -- the main unit to keep the tree symmetric. This ensures that internal
1750 -- name serialization is consistent in case the call marker causes the
1751 -- tree to transform in some way.
1753 Insert_Action (N, Marker);
1755 -- The marker becomes the "corresponding" scenario for the call. Save
1756 -- the marker for later processing by the ABE phase.
1758 Record_Elaboration_Scenario (Marker);
1759 end Build_Call_Marker;
1761 ---------------------------------
1762 -- Check_Elaboration_Scenarios --
1763 ---------------------------------
1765 procedure Check_Elaboration_Scenarios is
1767 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics
1768 -- are performed in this mode.
1774 -- Examine the context of the main unit and record all units with prior
1775 -- elaboration with respect to it.
1777 Find_Elaborated_Units;
1779 -- Examine each top level scenario saved during the Recording phase and
1780 -- perform various actions depending on the elaboration model in effect.
1782 for Index in Top_Level_Scenarios.First .. Top_Level_Scenarios.Last loop
1784 -- Clear the table of visited scenario bodies for each new top level
1787 Visited_Bodies.Reset;
1789 Process_Scenario (Top_Level_Scenarios.Table (Index));
1791 end Check_Elaboration_Scenarios;
1793 ------------------------------
1794 -- Check_Preelaborated_Call --
1795 ------------------------------
1797 procedure Check_Preelaborated_Call (Call : Node_Id) is
1798 function In_Preelaborated_Context (N : Node_Id) return Boolean;
1799 -- Determine whether arbitrary node appears in a preelaborated context
1801 ------------------------------
1802 -- In_Preelaborated_Context --
1803 ------------------------------
1805 function In_Preelaborated_Context (N : Node_Id) return Boolean is
1806 Body_Id : constant Entity_Id := Find_Code_Unit (N);
1807 Spec_Id : constant Entity_Id := Unique_Entity (Body_Id);
1810 -- The node appears within a package body whose corresponding spec is
1811 -- subject to pragma Remote_Call_Interface or Remote_Types. This does
1812 -- not result in a preelaborated context because the package body may
1813 -- be on another machine.
1815 if Ekind (Body_Id) = E_Package_Body
1816 and then Ekind_In (Spec_Id, E_Generic_Package, E_Package)
1817 and then (Is_Remote_Call_Interface (Spec_Id)
1818 or else Is_Remote_Types (Spec_Id))
1822 -- Otherwise the node appears within a preelaborated context when the
1823 -- associated unit is preelaborated.
1826 return Is_Preelaborated_Unit (Spec_Id);
1828 end In_Preelaborated_Context;
1832 Call_Attrs : Call_Attributes;
1833 Level : Enclosing_Level_Kind;
1834 Target_Id : Entity_Id;
1836 -- Start of processing for Check_Preelaborated_Call
1839 Extract_Call_Attributes
1841 Target_Id => Target_Id,
1842 Attrs => Call_Attrs);
1844 -- Nothing to do when the call is internally generated because it is
1845 -- assumed that it will never violate preelaboration.
1847 if not Call_Attrs.From_Source then
1851 -- Performance note: parent traversal
1853 Level := Find_Enclosing_Level (Call);
1855 -- Library level calls are always considered because they are part of
1856 -- the associated unit's elaboration actions.
1858 if Level in Library_Level then
1861 -- Calls at the library level of a generic package body must be checked
1862 -- because they would render an instantiation illegal if the template is
1863 -- marked as preelaborated. Note that this does not apply to calls at
1864 -- the library level of a generic package spec.
1866 elsif Level = Generic_Package_Body then
1869 -- Otherwise the call does not appear at the proper level and must not
1870 -- be considered for this check.
1876 -- The call appears within a preelaborated unit. Emit a warning only for
1877 -- internal uses, otherwise this is an error.
1879 if In_Preelaborated_Context (Call) then
1880 Error_Msg_Warn := GNAT_Mode;
1882 ("<<non-static call not allowed in preelaborated unit", Call);
1884 end Check_Preelaborated_Call;
1886 ----------------------
1887 -- Compilation_Unit --
1888 ----------------------
1890 function Compilation_Unit (Unit_Id : Entity_Id) return Node_Id is
1891 Comp_Unit : Node_Id;
1894 Comp_Unit := Parent (Unit_Id);
1896 -- Handle the case where a concurrent subunit is rewritten as a null
1897 -- statement due to expansion activities.
1899 if Nkind (Comp_Unit) = N_Null_Statement
1900 and then Nkind_In (Original_Node (Comp_Unit), N_Protected_Body,
1903 Comp_Unit := Parent (Comp_Unit);
1904 pragma Assert (Nkind (Comp_Unit) = N_Subunit);
1906 -- Otherwise use the declaration node of the unit
1909 Comp_Unit := Parent (Unit_Declaration_Node (Unit_Id));
1912 -- Handle the case where a subprogram instantiation which acts as a
1913 -- compilation unit is expanded into an anonymous package that wraps
1914 -- the instantiated subprogram.
1916 if Nkind (Comp_Unit) = N_Package_Specification
1917 and then Nkind_In (Original_Node (Parent (Comp_Unit)),
1918 N_Function_Instantiation,
1919 N_Procedure_Instantiation)
1921 Comp_Unit := Parent (Parent (Comp_Unit));
1923 -- Handle the case where the compilation unit is a subunit
1925 elsif Nkind (Comp_Unit) = N_Subunit then
1926 Comp_Unit := Parent (Comp_Unit);
1929 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
1932 end Compilation_Unit;
1938 procedure Elab_Msg_NE
1945 function Prefix return String;
1946 -- Obtain the prefix of the message
1948 function Suffix return String;
1949 -- Obtain the suffix of the message
1955 function Prefix return String is
1968 function Suffix return String is
1977 -- Start of processing for Elab_Msg_NE
1980 Error_Msg_NE (Prefix & Msg & Suffix, N, Id);
1983 ------------------------------
1984 -- Elaboration_Context_Hash --
1985 ------------------------------
1987 function Elaboration_Context_Hash
1988 (Key : Entity_Id) return Elaboration_Context_Index
1991 return Elaboration_Context_Index (Key mod Elaboration_Context_Max);
1992 end Elaboration_Context_Hash;
1994 ------------------------------
1995 -- Ensure_Prior_Elaboration --
1996 ------------------------------
1998 procedure Ensure_Prior_Elaboration
2000 Unit_Id : Entity_Id;
2001 In_Task_Body : Boolean)
2006 -- Instantiating an external generic unit requires an implicit Elaborate
2007 -- because Elaborate_All is too strong and could introduce non-existent
2008 -- elaboration cycles.
2010 -- package External is
2011 -- function Func ...;
2017 -- X : ... := External.Func;
2020 -- [with External;] -- implicit with for External
2021 -- [pragma Elaborate_All (External);] -- Elaborate_All for External
2023 -- [pragma Elaborate (Gen);] -- Elaborate for generic
2024 -- procedure Main is
2025 -- package Inst is new Gen; -- calls External.Func
2029 if Nkind (N) in N_Generic_Instantiation then
2030 Prag_Nam := Name_Elaborate;
2032 -- Otherwise generate an implicit Elaborate_All
2035 Prag_Nam := Name_Elaborate_All;
2038 -- Nothing to do when the need for prior elaboration came from a task
2039 -- body and switch -gnatd.y (disable implicit pragma Elaborate_All on
2040 -- task bodies) is in effect.
2042 if Debug_Flag_Dot_Y and then In_Task_Body then
2045 -- Nothing to do when the unit is elaborated prior to the main unit.
2046 -- This check must also consider the following cases:
2048 -- * No check is made against the context of the main unit because this
2049 -- is specific to the elaboration model in effect and requires custom
2050 -- handling (see Ensure_xxx_Prior_Elaboration).
2052 -- * Unit_Id is subject to pragma Elaborate_Body. An implicit pragma
2053 -- Elaborate[_All] MUST be generated even though Unit_Id is always
2054 -- elaborated prior to the main unit. This is a conservative strategy
2055 -- which ensures that other units withed by Unit_Id will not lead to
2058 -- package A is package body A is
2059 -- procedure ABE; procedure ABE is ... end ABE;
2063 -- package B is package body B is
2064 -- pragma Elaborate_Body; procedure Proc is
2066 -- procedure Proc; A.ABE;
2067 -- package B; end Proc;
2071 -- package C is package body C is
2077 -- In the example above, the elaboration of C invokes B.Proc. B is
2078 -- subject to pragma Elaborate_Body. If no pragma Elaborate[_All] is
2079 -- generated for B in C, then the following elaboratio order will lead
2082 -- spec of A elaborated
2083 -- spec of B elaborated
2084 -- body of B elaborated
2085 -- spec of C elaborated
2086 -- body of C elaborated <-- calls B.Proc which calls A.ABE
2087 -- body of A elaborated <-- problem
2089 -- The generation of an implicit pragma Elaborate_All (B) ensures that
2090 -- the elaboration order mechanism will not pick the above order.
2092 -- An implicit Elaborate is NOT generated when the unit is subject to
2093 -- Elaborate_Body because both pragmas have the exact same effect.
2095 -- * Unit_Id is the main unit. An implicit pragma Elaborate[_All] MUST
2096 -- NOT be generated in this case because a unit cannot depend on its
2097 -- own elaboration. This case is therefore treated as valid prior
2100 elsif Has_Prior_Elaboration
2101 (Unit_Id => Unit_Id,
2102 Same_Unit_OK => True,
2103 Elab_Body_OK => Prag_Nam = Name_Elaborate)
2107 -- Suggest the use of pragma Prag_Nam when the dynamic model is in
2110 elsif Dynamic_Elaboration_Checks then
2111 Ensure_Prior_Elaboration_Dynamic
2114 Prag_Nam => Prag_Nam);
2116 -- Install an implicit pragma Prag_Nam when the static model is in
2120 pragma Assert (Static_Elaboration_Checks);
2122 Ensure_Prior_Elaboration_Static
2125 Prag_Nam => Prag_Nam);
2127 end Ensure_Prior_Elaboration;
2129 --------------------------------------
2130 -- Ensure_Prior_Elaboration_Dynamic --
2131 --------------------------------------
2133 procedure Ensure_Prior_Elaboration_Dynamic
2135 Unit_Id : Entity_Id;
2138 procedure Info_Missing_Pragma;
2139 pragma Inline (Info_Missing_Pragma);
2140 -- Output information concerning missing Elaborate or Elaborate_All
2141 -- pragma with name Prag_Nam for scenario N, which would ensure the
2142 -- prior elaboration of Unit_Id.
2144 -------------------------
2145 -- Info_Missing_Pragma --
2146 -------------------------
2148 procedure Info_Missing_Pragma is
2150 -- Internal units are ignored as they cause unnecessary noise
2152 if not In_Internal_Unit (Unit_Id) then
2154 -- The name of the unit subjected to the elaboration pragma is
2155 -- fully qualified to improve the clarity of the info message.
2157 Error_Msg_Name_1 := Prag_Nam;
2158 Error_Msg_Qual_Level := Nat'Last;
2160 Error_Msg_NE ("info: missing pragma % for unit &", N, Unit_Id);
2161 Error_Msg_Qual_Level := 0;
2163 end Info_Missing_Pragma;
2167 Elab_Attrs : Elaboration_Attributes;
2168 Level : Enclosing_Level_Kind;
2170 -- Start of processing for Ensure_Prior_Elaboration_Dynamic
2173 Elab_Attrs := Elaboration_Context.Get (Unit_Id);
2175 -- Nothing to do when the unit is guaranteed prior elaboration by means
2176 -- of a source Elaborate[_All] pragma.
2178 if Present (Elab_Attrs.Source_Pragma) then
2182 -- Output extra information on a missing Elaborate[_All] pragma when
2183 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas
2186 if Elab_Info_Messages then
2188 -- Performance note: parent traversal
2190 Level := Find_Enclosing_Level (N);
2192 -- Declaration-level scenario
2194 if (Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N))
2195 and then Level = Declaration_Level
2199 -- Library-level scenario
2201 elsif Level in Library_Level then
2204 -- Instantiation library-level scenario
2206 elsif Level = Instantiation then
2209 -- Otherwise the scenario does not appear at the proper level and
2210 -- cannot possibly act as a top-level scenario.
2216 Info_Missing_Pragma;
2218 end Ensure_Prior_Elaboration_Dynamic;
2220 -------------------------------------
2221 -- Ensure_Prior_Elaboration_Static --
2222 -------------------------------------
2224 procedure Ensure_Prior_Elaboration_Static
2226 Unit_Id : Entity_Id;
2229 function Find_With_Clause
2231 Withed_Id : Entity_Id) return Node_Id;
2232 pragma Inline (Find_With_Clause);
2233 -- Find a nonlimited with clause in the list of context items Items
2234 -- that withs unit Withed_Id. Return Empty if no such clause is found.
2236 procedure Info_Implicit_Pragma;
2237 pragma Inline (Info_Implicit_Pragma);
2238 -- Output information concerning an implicitly generated Elaborate or
2239 -- Elaborate_All pragma with name Prag_Nam for scenario N which ensures
2240 -- the prior elaboration of unit Unit_Id.
2242 ----------------------
2243 -- Find_With_Clause --
2244 ----------------------
2246 function Find_With_Clause
2248 Withed_Id : Entity_Id) return Node_Id
2253 -- Examine the context clauses looking for a suitable with. Note that
2254 -- limited clauses do not affect the elaboration order.
2256 Item := First (Items);
2257 while Present (Item) loop
2258 if Nkind (Item) = N_With_Clause
2259 and then not Error_Posted (Item)
2260 and then not Limited_Present (Item)
2261 and then Entity (Name (Item)) = Withed_Id
2270 end Find_With_Clause;
2272 --------------------------
2273 -- Info_Implicit_Pragma --
2274 --------------------------
2276 procedure Info_Implicit_Pragma is
2278 -- Internal units are ignored as they cause unnecessary noise
2280 if not In_Internal_Unit (Unit_Id) then
2282 -- The name of the unit subjected to the elaboration pragma is
2283 -- fully qualified to improve the clarity of the info message.
2285 Error_Msg_Name_1 := Prag_Nam;
2286 Error_Msg_Qual_Level := Nat'Last;
2289 ("info: implicit pragma % generated for unit &", N, Unit_Id);
2291 Error_Msg_Qual_Level := 0;
2292 Output_Active_Scenarios (N);
2294 end Info_Implicit_Pragma;
2298 Main_Cunit : constant Node_Id := Cunit (Main_Unit);
2299 Loc : constant Source_Ptr := Sloc (Main_Cunit);
2300 Unit_Cunit : constant Node_Id := Compilation_Unit (Unit_Id);
2302 Is_Instantiation : constant Boolean :=
2303 Nkind (N) in N_Generic_Instantiation;
2306 Elab_Attrs : Elaboration_Attributes;
2309 -- Start of processing for Ensure_Prior_Elaboration_Static
2312 Elab_Attrs := Elaboration_Context.Get (Unit_Id);
2314 -- Nothing to do when the unit is guaranteed prior elaboration by means
2315 -- of a source Elaborate[_All] pragma.
2317 if Present (Elab_Attrs.Source_Pragma) then
2320 -- Nothing to do when the unit has an existing implicit Elaborate[_All]
2321 -- pragma installed by a previous scenario.
2323 elsif Present (Elab_Attrs.With_Clause) then
2325 -- The unit is already guaranteed prior elaboration by means of an
2326 -- implicit Elaborate pragma, however the current scenario imposes
2327 -- a stronger requirement of Elaborate_All. "Upgrade" the existing
2328 -- pragma to match this new requirement.
2330 if Elaborate_Desirable (Elab_Attrs.With_Clause)
2331 and then Prag_Nam = Name_Elaborate_All
2333 Set_Elaborate_All_Desirable (Elab_Attrs.With_Clause);
2334 Set_Elaborate_Desirable (Elab_Attrs.With_Clause, False);
2340 -- At this point it is known that the unit has no prior elaboration
2341 -- according to pragmas and hierarchical relationships.
2343 Items := Context_Items (Main_Cunit);
2347 Set_Context_Items (Main_Cunit, Items);
2350 -- Locate the with clause for the unit. Note that there may not be a
2351 -- clause if the unit is visible through a subunit-body, body-spec, or
2352 -- spec-parent relationship.
2357 Withed_Id => Unit_Id);
2362 -- Note that adding implicit with clauses is safe because analysis,
2363 -- resolution, and expansion have already taken place and it is not
2364 -- possible to interfere with visibility.
2368 Make_With_Clause (Loc,
2369 Name => New_Occurrence_Of (Unit_Id, Loc));
2371 Set_Implicit_With (Clause);
2372 Set_Library_Unit (Clause, Unit_Cunit);
2374 Append_To (Items, Clause);
2377 -- Instantiations require an implicit Elaborate because Elaborate_All is
2378 -- too conservative and may introduce non-existent elaboration cycles.
2380 if Is_Instantiation then
2381 Set_Elaborate_Desirable (Clause);
2383 -- Otherwise generate an implicit Elaborate_All
2386 Set_Elaborate_All_Desirable (Clause);
2389 -- The implicit Elaborate[_All] ensures the prior elaboration of the
2390 -- unit. Include the unit in the elaboration context of the main unit.
2392 Elaboration_Context.Set (Unit_Id,
2393 Elaboration_Attributes'(Source_Pragma => Empty,
2394 With_Clause => Clause));
2396 -- Output extra information on an implicit Elaborate[_All] pragma when
2397 -- switch -gnatel (info messages on implicit Elaborate[_All] pragmas is
2400 if Elab_Info_Messages then
2401 Info_Implicit_Pragma;
2403 end Ensure_Prior_Elaboration_Static;
2405 -----------------------------
2406 -- Extract_Assignment_Name --
2407 -----------------------------
2409 function Extract_Assignment_Name (Asmt : Node_Id) return Node_Id is
2415 -- When the name denotes an array or record component, find the whole
2418 while Nkind_In (Nam, N_Explicit_Dereference,
2419 N_Indexed_Component,
2420 N_Selected_Component,
2423 Nam := Prefix (Nam);
2427 end Extract_Assignment_Name;
2429 -----------------------------
2430 -- Extract_Call_Attributes --
2431 -----------------------------
2433 procedure Extract_Call_Attributes
2435 Target_Id : out Entity_Id;
2436 Attrs : out Call_Attributes)
2438 From_Source : Boolean;
2439 In_Declarations : Boolean;
2440 Is_Dispatching : Boolean;
2443 -- Extraction for call markers
2445 if Nkind (Call) = N_Call_Marker then
2446 Target_Id := Target (Call);
2447 From_Source := Is_Source_Call (Call);
2448 In_Declarations := Is_Declaration_Level_Node (Call);
2449 Is_Dispatching := Is_Dispatching_Call (Call);
2451 -- Extraction for entry calls, requeue, and subprogram calls
2454 pragma Assert (Nkind_In (Call, N_Entry_Call_Statement,
2456 N_Procedure_Call_Statement,
2457 N_Requeue_Statement));
2459 Target_Id := Entity (Extract_Call_Name (Call));
2460 From_Source := Comes_From_Source (Call);
2462 -- Performance note: parent traversal
2464 In_Declarations := Find_Enclosing_Level (Call) = Declaration_Level;
2466 Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
2467 and then Present (Controlling_Argument (Call));
2470 -- Obtain the original entry or subprogram which the target may rename
2471 -- except when the target is an instantiation. In this case the alias
2472 -- is the internally generated subprogram which appears within the the
2473 -- anonymous package created for the instantiation. Such an alias is not
2474 -- a suitable target.
2476 if not (Is_Subprogram (Target_Id)
2477 and then Is_Generic_Instance (Target_Id))
2479 Target_Id := Get_Renamed_Entity (Target_Id);
2482 -- Set all attributes
2484 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Call);
2485 Attrs.From_Source := From_Source;
2486 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Call);
2487 Attrs.In_Declarations := In_Declarations;
2488 Attrs.Is_Dispatching := Is_Dispatching;
2489 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Call);
2490 end Extract_Call_Attributes;
2492 -----------------------
2493 -- Extract_Call_Name --
2494 -----------------------
2496 function Extract_Call_Name (Call : Node_Id) return Node_Id is
2502 -- When the call invokes an entry family, the name appears as an indexed
2505 if Nkind (Nam) = N_Indexed_Component then
2506 Nam := Prefix (Nam);
2509 -- When the call employs the object.operation form, the name appears as
2510 -- a selected component.
2512 if Nkind (Nam) = N_Selected_Component then
2513 Nam := Selector_Name (Nam);
2517 end Extract_Call_Name;
2519 ---------------------------------
2520 -- Extract_Instance_Attributes --
2521 ---------------------------------
2523 procedure Extract_Instance_Attributes
2524 (Exp_Inst : Node_Id;
2525 Inst_Body : out Node_Id;
2526 Inst_Decl : out Node_Id)
2528 Body_Id : Entity_Id;
2531 -- Assume that the attributes are unavailable
2536 -- Generic package or subprogram spec
2538 if Nkind_In (Exp_Inst, N_Package_Declaration,
2539 N_Subprogram_Declaration)
2541 Inst_Decl := Exp_Inst;
2542 Body_Id := Corresponding_Body (Inst_Decl);
2544 if Present (Body_Id) then
2545 Inst_Body := Unit_Declaration_Node (Body_Id);
2548 -- Generic package or subprogram body
2552 (Nkind_In (Exp_Inst, N_Package_Body, N_Subprogram_Body));
2554 Inst_Body := Exp_Inst;
2555 Inst_Decl := Unit_Declaration_Node (Corresponding_Spec (Inst_Body));
2557 end Extract_Instance_Attributes;
2559 --------------------------------------
2560 -- Extract_Instantiation_Attributes --
2561 --------------------------------------
2563 procedure Extract_Instantiation_Attributes
2564 (Exp_Inst : Node_Id;
2566 Inst_Id : out Entity_Id;
2567 Gen_Id : out Entity_Id;
2568 Attrs : out Instantiation_Attributes)
2571 Inst := Original_Node (Exp_Inst);
2572 Inst_Id := Defining_Entity (Inst);
2574 -- Traverse a possible chain of renamings to obtain the original generic
2575 -- being instantiatied.
2577 Gen_Id := Get_Renamed_Entity (Entity (Name (Inst)));
2579 -- Set all attributes
2581 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Node (Inst);
2582 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Node (Inst);
2583 Attrs.In_Declarations := Is_Declaration_Level_Node (Inst);
2584 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Inst);
2585 end Extract_Instantiation_Attributes;
2587 -------------------------------
2588 -- Extract_Target_Attributes --
2589 -------------------------------
2591 procedure Extract_Target_Attributes
2592 (Target_Id : Entity_Id;
2593 Attrs : out Target_Attributes)
2595 procedure Extract_Package_Or_Subprogram_Attributes
2596 (Spec_Id : out Entity_Id;
2597 Body_Decl : out Node_Id);
2598 -- Obtain the attributes associated with a package or a subprogram.
2599 -- Spec_Id is the package or subprogram. Body_Decl is the declaration
2600 -- of the corresponding package or subprogram body.
2602 procedure Extract_Protected_Entry_Attributes
2603 (Spec_Id : out Entity_Id;
2604 Body_Decl : out Node_Id;
2605 Body_Barf : out Node_Id);
2606 -- Obtain the attributes associated with a protected entry [family].
2607 -- Spec_Id is the entity of the protected body subprogram. Body_Decl
2608 -- is the declaration of Spec_Id's corresponding body. Body_Barf is
2609 -- the declaration of the barrier function body.
2611 procedure Extract_Protected_Subprogram_Attributes
2612 (Spec_Id : out Entity_Id;
2613 Body_Decl : out Node_Id);
2614 -- Obtain the attributes associated with a protected subprogram. Formal
2615 -- Spec_Id is the entity of the protected body subprogram. Body_Decl is
2616 -- the declaration of Spec_Id's corresponding body.
2618 procedure Extract_Task_Entry_Attributes
2619 (Spec_Id : out Entity_Id;
2620 Body_Decl : out Node_Id);
2621 -- Obtain the attributes associated with a task entry [family]. Formal
2622 -- Spec_Id is the entity of the task body procedure. Body_Decl is the
2623 -- declaration of Spec_Id's corresponding body.
2625 ----------------------------------------------
2626 -- Extract_Package_Or_Subprogram_Attributes --
2627 ----------------------------------------------
2629 procedure Extract_Package_Or_Subprogram_Attributes
2630 (Spec_Id : out Entity_Id;
2631 Body_Decl : out Node_Id)
2633 Body_Id : Entity_Id;
2634 Init_Id : Entity_Id;
2635 Spec_Decl : Node_Id;
2638 -- Assume that the body is not available
2641 Spec_Id := Target_Id;
2643 -- For body retrieval purposes, the entity of the initial declaration
2644 -- is that of the spec.
2648 -- The only exception to the above is a function which returns a
2649 -- constrained array type in a SPARK-to-C compilation. In this case
2650 -- the function receives a corresponding procedure which has an out
2651 -- parameter. The proper body for ABE checks and diagnostics is that
2652 -- of the procedure.
2654 if Ekind (Init_Id) = E_Function
2655 and then Rewritten_For_C (Init_Id)
2657 Init_Id := Corresponding_Procedure (Init_Id);
2660 -- Extract the attributes of the body
2662 Spec_Decl := Unit_Declaration_Node (Init_Id);
2664 -- The initial declaration is a stand alone subprogram body
2666 if Nkind (Spec_Decl) = N_Subprogram_Body then
2667 Body_Decl := Spec_Decl;
2669 -- Otherwise the package or subprogram has a spec and a completing
2672 elsif Nkind_In (Spec_Decl, N_Generic_Package_Declaration,
2673 N_Generic_Subprogram_Declaration,
2674 N_Package_Declaration,
2675 N_Subprogram_Body_Stub,
2676 N_Subprogram_Declaration)
2678 Body_Id := Corresponding_Body (Spec_Decl);
2680 if Present (Body_Id) then
2681 Body_Decl := Unit_Declaration_Node (Body_Id);
2684 end Extract_Package_Or_Subprogram_Attributes;
2686 ----------------------------------------
2687 -- Extract_Protected_Entry_Attributes --
2688 ----------------------------------------
2690 procedure Extract_Protected_Entry_Attributes
2691 (Spec_Id : out Entity_Id;
2692 Body_Decl : out Node_Id;
2693 Body_Barf : out Node_Id)
2695 Barf_Id : Entity_Id;
2696 Body_Id : Entity_Id;
2699 -- Assume that the bodies are not available
2704 -- When the entry [family] has already been expanded, it carries both
2705 -- the procedure which emulates the behavior of the entry [family] as
2706 -- well as the barrier function.
2708 if Present (Protected_Body_Subprogram (Target_Id)) then
2709 Spec_Id := Protected_Body_Subprogram (Target_Id);
2711 -- Extract the attributes of the barrier function
2715 (Unit_Declaration_Node (Barrier_Function (Target_Id)));
2717 if Present (Barf_Id) then
2718 Body_Barf := Unit_Declaration_Node (Barf_Id);
2721 -- Otherwise no expansion took place
2724 Spec_Id := Target_Id;
2727 -- Extract the attributes of the entry body
2729 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
2731 if Present (Body_Id) then
2732 Body_Decl := Unit_Declaration_Node (Body_Id);
2734 end Extract_Protected_Entry_Attributes;
2736 ---------------------------------------------
2737 -- Extract_Protected_Subprogram_Attributes --
2738 ---------------------------------------------
2740 procedure Extract_Protected_Subprogram_Attributes
2741 (Spec_Id : out Entity_Id;
2742 Body_Decl : out Node_Id)
2744 Body_Id : Entity_Id;
2747 -- Assume that the body is not available
2751 -- When the protected subprogram has already been expanded, it
2752 -- carries the subprogram which seizes the lock and invokes the
2753 -- original statements.
2755 if Present (Protected_Subprogram (Target_Id)) then
2757 Protected_Body_Subprogram (Protected_Subprogram (Target_Id));
2759 -- Otherwise no expansion took place
2762 Spec_Id := Target_Id;
2765 -- Extract the attributes of the body
2767 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
2769 if Present (Body_Id) then
2770 Body_Decl := Unit_Declaration_Node (Body_Id);
2772 end Extract_Protected_Subprogram_Attributes;
2774 -----------------------------------
2775 -- Extract_Task_Entry_Attributes --
2776 -----------------------------------
2778 procedure Extract_Task_Entry_Attributes
2779 (Spec_Id : out Entity_Id;
2780 Body_Decl : out Node_Id)
2782 Task_Typ : constant Entity_Id := Non_Private_View (Scope (Target_Id));
2783 Body_Id : Entity_Id;
2786 -- Assume that the body is not available
2790 -- The the task type has already been expanded, it carries the
2791 -- procedure which emulates the behavior of the task body.
2793 if Present (Task_Body_Procedure (Task_Typ)) then
2794 Spec_Id := Task_Body_Procedure (Task_Typ);
2796 -- Otherwise no expansion took place
2799 Spec_Id := Task_Typ;
2802 -- Extract the attributes of the body
2804 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
2806 if Present (Body_Id) then
2807 Body_Decl := Unit_Declaration_Node (Body_Id);
2809 end Extract_Task_Entry_Attributes;
2813 Prag : constant Node_Id := SPARK_Pragma (Target_Id);
2814 Body_Barf : Node_Id;
2815 Body_Decl : Node_Id;
2816 Spec_Id : Entity_Id;
2818 -- Start of processing for Extract_Target_Attributes
2821 -- Assume that the body of the barrier function is not available
2825 -- The target is a protected entry [family]
2827 if Is_Protected_Entry (Target_Id) then
2828 Extract_Protected_Entry_Attributes
2829 (Spec_Id => Spec_Id,
2830 Body_Decl => Body_Decl,
2831 Body_Barf => Body_Barf);
2833 -- The target is a protected subprogram
2835 elsif Is_Protected_Subp (Target_Id)
2836 or else Is_Protected_Body_Subp (Target_Id)
2838 Extract_Protected_Subprogram_Attributes
2839 (Spec_Id => Spec_Id,
2840 Body_Decl => Body_Decl);
2842 -- The target is a task entry [family]
2844 elsif Is_Task_Entry (Target_Id) then
2845 Extract_Task_Entry_Attributes
2846 (Spec_Id => Spec_Id,
2847 Body_Decl => Body_Decl);
2849 -- Otherwise the target is a package or a subprogram
2852 Extract_Package_Or_Subprogram_Attributes
2853 (Spec_Id => Spec_Id,
2854 Body_Decl => Body_Decl);
2857 -- Set all attributes
2859 Attrs.Body_Barf := Body_Barf;
2860 Attrs.Body_Decl := Body_Decl;
2861 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Target_Id);
2862 Attrs.From_Source := Comes_From_Source (Target_Id);
2863 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Target_Id);
2864 Attrs.SPARK_Mode_On :=
2865 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
2866 Attrs.Spec_Decl := Unit_Declaration_Node (Spec_Id);
2867 Attrs.Spec_Id := Spec_Id;
2868 Attrs.Unit_Id := Find_Top_Unit (Target_Id);
2870 -- At this point certain attributes should always be available
2872 pragma Assert (Present (Attrs.Spec_Decl));
2873 pragma Assert (Present (Attrs.Spec_Id));
2874 pragma Assert (Present (Attrs.Unit_Id));
2875 end Extract_Target_Attributes;
2877 -----------------------------
2878 -- Extract_Task_Attributes --
2879 -----------------------------
2881 procedure Extract_Task_Attributes
2883 Attrs : out Task_Attributes)
2885 Task_Typ : constant Entity_Id := Non_Private_View (Typ);
2887 Body_Decl : Node_Id;
2888 Body_Id : Entity_Id;
2890 Spec_Id : Entity_Id;
2893 -- Assume that the body of the task procedure is not available
2897 -- The initial declaration is that of the task body procedure
2899 Spec_Id := Get_Task_Body_Procedure (Task_Typ);
2900 Body_Id := Corresponding_Body (Unit_Declaration_Node (Spec_Id));
2902 if Present (Body_Id) then
2903 Body_Decl := Unit_Declaration_Node (Body_Id);
2906 Prag := SPARK_Pragma (Task_Typ);
2908 -- Set all attributes
2910 Attrs.Body_Decl := Body_Decl;
2911 Attrs.Elab_Checks_OK := Is_Elaboration_Checks_OK_Id (Task_Typ);
2912 Attrs.Ghost_Mode_Ignore := Is_Ignored_Ghost_Entity (Task_Typ);
2913 Attrs.SPARK_Mode_On :=
2914 Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = On;
2915 Attrs.Spec_Id := Spec_Id;
2916 Attrs.Task_Decl := Declaration_Node (Task_Typ);
2917 Attrs.Unit_Id := Find_Top_Unit (Task_Typ);
2919 -- At this point certain attributes should always be available
2921 pragma Assert (Present (Attrs.Spec_Id));
2922 pragma Assert (Present (Attrs.Task_Decl));
2923 pragma Assert (Present (Attrs.Unit_Id));
2924 end Extract_Task_Attributes;
2926 -------------------------------------------
2927 -- Extract_Variable_Reference_Attributes --
2928 -------------------------------------------
2930 procedure Extract_Variable_Reference_Attributes
2932 Var_Id : out Entity_Id;
2933 Attrs : out Variable_Attributes)
2936 -- Traverse a possible chain of renamings to obtain the original
2937 -- variable being referenced.
2939 Var_Id := Get_Renamed_Entity (Entity (Ref));
2941 Attrs.SPARK_Mode_On := Is_SPARK_Mode_On_Node (Ref);
2942 Attrs.Unit_Id := Find_Top_Unit (Var_Id);
2944 -- At this point certain attributes should always be available
2946 pragma Assert (Present (Attrs.Unit_Id));
2947 end Extract_Variable_Reference_Attributes;
2949 --------------------
2950 -- Find_Code_Unit --
2951 --------------------
2953 function Find_Code_Unit (N : Node_Or_Entity_Id) return Entity_Id is
2955 return Find_Unit_Entity (Unit (Cunit (Get_Code_Unit (N))));
2958 ---------------------------
2959 -- Find_Elaborated_Units --
2960 ---------------------------
2962 procedure Find_Elaborated_Units is
2963 procedure Add_Pragma (Prag : Node_Id);
2964 -- Determine whether pragma Prag denotes a legal Elaborate[_All] pragma.
2965 -- If this is the case, add the related unit to the elaboration context.
2966 -- For pragma Elaborate_All, include recursively all units withed by the
2970 (Unit_Id : Entity_Id;
2972 Full_Context : Boolean);
2973 -- Add unit Unit_Id to the elaboration context. Prag denotes the pragma
2974 -- which prompted the inclusion of the unit to the elaboration context.
2975 -- If flag Full_Context is set, examine the nonlimited clauses of unit
2976 -- Unit_Id and add each withed unit to the context.
2978 procedure Find_Elaboration_Context (Comp_Unit : Node_Id);
2979 -- Examine the context items of compilation unit Comp_Unit for suitable
2980 -- elaboration-related pragmas and add all related units to the context.
2986 procedure Add_Pragma (Prag : Node_Id) is
2987 Prag_Args : constant List_Id := Pragma_Argument_Associations (Prag);
2988 Prag_Nam : constant Name_Id := Pragma_Name (Prag);
2992 -- Nothing to do if the pragma is not related to elaboration
2994 if not Nam_In (Prag_Nam, Name_Elaborate, Name_Elaborate_All) then
2997 -- Nothing to do when the pragma is illegal
2999 elsif Error_Posted (Prag) then
3003 Unit_Arg := Get_Pragma_Arg (First (Prag_Args));
3005 -- The argument of the pragma may appear in package.package form
3007 if Nkind (Unit_Arg) = N_Selected_Component then
3008 Unit_Arg := Selector_Name (Unit_Arg);
3012 (Unit_Id => Entity (Unit_Arg),
3014 Full_Context => Prag_Nam = Name_Elaborate_All);
3022 (Unit_Id : Entity_Id;
3024 Full_Context : Boolean)
3027 Elab_Attrs : Elaboration_Attributes;
3030 -- Nothing to do when some previous error left a with clause or a
3031 -- pragma in a bad state.
3033 if No (Unit_Id) then
3037 Elab_Attrs := Elaboration_Context.Get (Unit_Id);
3039 -- The current unit is not part of the context. Prepare a new set of
3042 if Elab_Attrs = No_Elaboration_Attributes then
3044 Elaboration_Attributes'(Source_Pragma => Prag,
3045 With_Clause => Empty);
3047 -- The unit is already included in the context by means of pragma
3048 -- Elaborate. "Upgrage" the existing attributes when the unit is
3049 -- subject to Elaborate_All because the new pragma covers a larger
3050 -- set of units. All other properties remain the same.
3052 elsif Pragma_Name (Elab_Attrs.Source_Pragma) = Name_Elaborate
3053 and then Pragma_Name (Prag) = Name_Elaborate_All
3055 Elab_Attrs.Source_Pragma := Prag;
3057 -- Otherwise the unit is already included in the context
3063 -- Add or update the attributes of the unit
3065 Elaboration_Context.Set (Unit_Id, Elab_Attrs);
3067 -- Includes all units withed by the current one when computing the
3070 if Full_Context then
3072 -- Process all nonlimited with clauses found in the context of
3073 -- the current unit. Note that limited clauses do not impose an
3074 -- elaboration order.
3076 Clause := First (Context_Items (Compilation_Unit (Unit_Id)));
3077 while Present (Clause) loop
3078 if Nkind (Clause) = N_With_Clause
3079 and then not Error_Posted (Clause)
3080 and then not Limited_Present (Clause)
3083 (Unit_Id => Entity (Name (Clause)),
3085 Full_Context => Full_Context);
3093 ------------------------------
3094 -- Find_Elaboration_Context --
3095 ------------------------------
3097 procedure Find_Elaboration_Context (Comp_Unit : Node_Id) is
3101 pragma Assert (Nkind (Comp_Unit) = N_Compilation_Unit);
3103 -- Process all elaboration-related pragmas found in the context of
3104 -- the compilation unit.
3106 Prag := First (Context_Items (Comp_Unit));
3107 while Present (Prag) loop
3108 if Nkind (Prag) = N_Pragma then
3114 end Find_Elaboration_Context;
3121 -- Start of processing for Find_Elaborated_Units
3124 -- Perform a traversal which examines the context of the main unit and
3125 -- populates the Elaboration_Context table with all units elaborated
3126 -- prior to the main unit. The traversal performs the following jumps:
3128 -- subunit -> parent subunit
3129 -- parent subunit -> body
3131 -- spec -> parent spec
3132 -- parent spec -> grandparent spec and so on
3134 -- The traversal relies on units rather than scopes because the scope of
3135 -- a subunit is some spec, while this traversal must process the body as
3136 -- well. Given that protected and task bodies can also be subunits, this
3137 -- complicates the scope approach even further.
3139 Unt := Unit (Cunit (Main_Unit));
3141 -- Perform the following traversals when the main unit is a subunit
3143 -- subunit -> parent subunit
3144 -- parent subunit -> body
3146 while Present (Unt) and then Nkind (Unt) = N_Subunit loop
3147 Find_Elaboration_Context (Parent (Unt));
3149 -- Continue the traversal by going to the unit which contains the
3150 -- corresponding stub.
3152 if Present (Corresponding_Stub (Unt)) then
3153 Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Stub (Unt))));
3155 -- Otherwise the subunit may be erroneous or left in a bad state
3162 -- Perform the following traversal now that subunits have been taken
3163 -- care of, or the main unit is a body.
3168 and then Nkind_In (Unt, N_Package_Body, N_Subprogram_Body)
3170 Find_Elaboration_Context (Parent (Unt));
3172 -- Continue the traversal by going to the unit which contains the
3173 -- corresponding spec.
3175 if Present (Corresponding_Spec (Unt)) then
3176 Unt := Unit (Cunit (Get_Source_Unit (Corresponding_Spec (Unt))));
3180 -- Perform the following traversals now that the body has been taken
3181 -- care of, or the main unit is a spec.
3183 -- spec -> parent spec
3184 -- parent spec -> grandparent spec and so on
3187 and then Nkind_In (Unt, N_Generic_Package_Declaration,
3188 N_Generic_Subprogram_Declaration,
3189 N_Package_Declaration,
3190 N_Subprogram_Declaration)
3192 Find_Elaboration_Context (Parent (Unt));
3194 -- Process a potential chain of parent units which ends with the
3195 -- main unit spec. The traversal can now safely rely on the scope
3198 Par_Id := Scope (Defining_Entity (Unt));
3199 while Present (Par_Id) and then Par_Id /= Standard_Standard loop
3200 Find_Elaboration_Context (Compilation_Unit (Par_Id));
3202 Par_Id := Scope (Par_Id);
3205 end Find_Elaborated_Units;
3207 -----------------------------
3208 -- Find_Enclosing_Instance --
3209 -----------------------------
3211 function Find_Enclosing_Instance (N : Node_Id) return Node_Id is
3213 Spec_Id : Entity_Id;
3216 -- Climb the parent chain looking for an enclosing instance spec or body
3219 while Present (Par) loop
3221 -- Generic package or subprogram spec
3223 if Nkind_In (Par, N_Package_Declaration,
3224 N_Subprogram_Declaration)
3225 and then Is_Generic_Instance (Defining_Entity (Par))
3229 -- Generic package or subprogram body
3231 elsif Nkind_In (Par, N_Package_Body, N_Subprogram_Body) then
3232 Spec_Id := Corresponding_Spec (Par);
3234 if Present (Spec_Id) and then Is_Generic_Instance (Spec_Id) then
3239 Par := Parent (Par);
3243 end Find_Enclosing_Instance;
3245 --------------------------
3246 -- Find_Enclosing_Level --
3247 --------------------------
3249 function Find_Enclosing_Level (N : Node_Id) return Enclosing_Level_Kind is
3250 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind;
3251 -- Obtain the corresponding level of unit Unit
3257 function Level_Of (Unit : Node_Id) return Enclosing_Level_Kind is
3258 Spec_Id : Entity_Id;
3261 if Nkind (Unit) in N_Generic_Instantiation then
3262 return Instantiation;
3264 elsif Nkind (Unit) = N_Generic_Package_Declaration then
3265 return Generic_Package_Spec;
3267 elsif Nkind (Unit) = N_Package_Declaration then
3268 return Package_Spec;
3270 elsif Nkind (Unit) = N_Package_Body then
3271 Spec_Id := Corresponding_Spec (Unit);
3273 -- The body belongs to a generic package
3275 if Present (Spec_Id)
3276 and then Ekind (Spec_Id) = E_Generic_Package
3278 return Generic_Package_Body;
3280 -- Otherwise the body belongs to a non-generic package. This also
3281 -- treats an illegal package body without a corresponding spec as
3282 -- a non-generic package body.
3285 return Package_Body;
3298 -- Start of processing for Find_Enclosing_Level
3301 -- Call markers and instantiations which appear at the declaration level
3302 -- but are later relocated in a different context retain their original
3303 -- declaration level.
3305 if Nkind_In (N, N_Call_Marker,
3306 N_Function_Instantiation,
3307 N_Package_Instantiation,
3308 N_Procedure_Instantiation)
3309 and then Is_Declaration_Level_Node (N)
3311 return Declaration_Level;
3314 -- Climb the parent chain looking at the enclosing levels
3317 Curr := Parent (Prev);
3318 while Present (Curr) loop
3320 -- A traversal from a subunit continues via the corresponding stub
3322 if Nkind (Curr) = N_Subunit then
3323 Curr := Corresponding_Stub (Curr);
3325 -- The current construct is a package. Packages are ignored because
3326 -- they are always elaborated when the enclosing context is invoked
3329 elsif Nkind_In (Curr, N_Package_Body, N_Package_Declaration) then
3332 -- The current construct is a block statement
3334 elsif Nkind (Curr) = N_Block_Statement then
3336 -- Ignore internally generated blocks created by the expander for
3337 -- various purposes such as abort defer/undefer.
3339 if not Comes_From_Source (Curr) then
3342 -- If the traversal came from the handled sequence of statments,
3343 -- then the node appears at the level of the enclosing construct.
3344 -- This is a more reliable test because transients scopes within
3345 -- the declarative region of the encapsulator are hard to detect.
3347 elsif Nkind (Prev) = N_Handled_Sequence_Of_Statements
3348 and then Handled_Statement_Sequence (Curr) = Prev
3350 return Find_Enclosing_Level (Parent (Curr));
3352 -- Otherwise the traversal came from the declarations, the node is
3353 -- at the declaration level.
3356 return Declaration_Level;
3359 -- The current construct is a declaration level encapsulator
3361 elsif Nkind_In (Curr, N_Entry_Body,
3365 -- If the traversal came from the handled sequence of statments,
3366 -- then the node cannot possibly appear at any level. This is
3367 -- a more reliable test because transients scopes within the
3368 -- declarative region of the encapsulator are hard to detect.
3370 if Nkind (Prev) = N_Handled_Sequence_Of_Statements
3371 and then Handled_Statement_Sequence (Curr) = Prev
3375 -- Otherwise the traversal came from the declarations, the node is
3376 -- at the declaration level.
3379 return Declaration_Level;
3382 -- The current construct is a non-library level encapsulator which
3383 -- indicates that the node cannot possibly appear at any level.
3384 -- Note that this check must come after the declaration level check
3385 -- because both predicates share certain nodes.
3387 elsif Is_Non_Library_Level_Encapsulator (Curr) then
3388 Context := Parent (Curr);
3390 -- The sole exception is when the encapsulator is the compilation
3391 -- utit itself because the compilation unit node requires special
3392 -- processing (see below).
3394 if Present (Context)
3395 and then Nkind (Context) = N_Compilation_Unit
3399 -- Otherwise the node is not at any level
3405 -- The current construct is a compilation unit. The node appears at
3406 -- the [generic] library level when the unit is a [generic] package.
3408 elsif Nkind (Curr) = N_Compilation_Unit then
3409 return Level_Of (Unit (Curr));
3413 Curr := Parent (Prev);
3417 end Find_Enclosing_Level;
3423 function Find_Top_Unit (N : Node_Or_Entity_Id) return Entity_Id is
3425 return Find_Unit_Entity (Unit (Cunit (Get_Top_Level_Code_Unit (N))));
3428 ----------------------
3429 -- Find_Unit_Entity --
3430 ----------------------
3432 function Find_Unit_Entity (N : Node_Id) return Entity_Id is
3433 Context : constant Node_Id := Parent (N);
3434 Orig_N : constant Node_Id := Original_Node (N);
3437 -- The unit denotes a package body of an instantiation which acts as
3438 -- a compilation unit. The proper entity is that of the package spec.
3440 if Nkind (N) = N_Package_Body
3441 and then Nkind (Orig_N) = N_Package_Instantiation
3442 and then Nkind (Context) = N_Compilation_Unit
3444 return Corresponding_Spec (N);
3446 -- The unit denotes an anonymous package created to wrap a subprogram
3447 -- instantiation which acts as a compilation unit. The proper entity is
3448 -- that of the "related instance".
3450 elsif Nkind (N) = N_Package_Declaration
3451 and then Nkind_In (Orig_N, N_Function_Instantiation,
3452 N_Procedure_Instantiation)
3453 and then Nkind (Context) = N_Compilation_Unit
3456 Related_Instance (Defining_Entity (N, Concurrent_Subunit => True));
3458 -- Otherwise the proper entity is the defining entity
3461 return Defining_Entity (N, Concurrent_Subunit => True);
3463 end Find_Unit_Entity;
3465 -----------------------
3466 -- First_Formal_Type --
3467 -----------------------
3469 function First_Formal_Type (Subp_Id : Entity_Id) return Entity_Id is
3470 Formal_Id : constant Entity_Id := First_Formal (Subp_Id);
3474 if Present (Formal_Id) then
3475 Typ := Etype (Formal_Id);
3477 -- Handle various combinations of concurrent and private types
3480 if Ekind_In (Typ, E_Protected_Type, E_Task_Type)
3481 and then Present (Anonymous_Object (Typ))
3483 Typ := Anonymous_Object (Typ);
3485 elsif Is_Concurrent_Record_Type (Typ) then
3486 Typ := Corresponding_Concurrent_Type (Typ);
3488 elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
3489 Typ := Full_View (Typ);
3500 end First_Formal_Type;
3506 function Has_Body (Pack_Decl : Node_Id) return Boolean is
3507 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id;
3508 -- Try to locate the corresponding body of spec Spec_Id. If no body is
3509 -- found, return Empty.
3512 (Spec_Id : Entity_Id;
3513 From : Node_Id) return Node_Id;
3514 -- Try to locate the corresponding body of spec Spec_Id in the node list
3515 -- which follows arbitrary node From. If no body is found, return Empty.
3517 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id;
3518 -- Attempt to load the body of unit Unit_Nam. If the load failed, return
3519 -- Empty. If the compilation will not generate code, return Empty.
3521 -----------------------------
3522 -- Find_Corresponding_Body --
3523 -----------------------------
3525 function Find_Corresponding_Body (Spec_Id : Entity_Id) return Node_Id is
3526 Context : constant Entity_Id := Scope (Spec_Id);
3527 Spec_Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
3528 Body_Decl : Node_Id;
3529 Body_Id : Entity_Id;
3532 if Is_Compilation_Unit (Spec_Id) then
3533 Body_Id := Corresponding_Body (Spec_Decl);
3535 if Present (Body_Id) then
3536 return Unit_Declaration_Node (Body_Id);
3538 -- The package is at the library and requires a body. Load the
3539 -- corresponding body because the optional body may be declared
3542 elsif Unit_Requires_Body (Spec_Id) then
3545 (Get_Body_Name (Unit_Name (Get_Source_Unit (Spec_Decl))));
3547 -- Otherwise there is no optional body
3553 -- The immediate context is a package. The optional body may be
3554 -- within the body of that package.
3556 -- procedure Proc is
3557 -- package Nested_1 is
3558 -- package Nested_2 is
3565 -- package body Nested_1 is
3566 -- package body Nested_2 is separate;
3569 -- separate (Proc.Nested_1.Nested_2)
3570 -- package body Nested_2 is
3571 -- package body Pack is -- optional body
3576 elsif Is_Package_Or_Generic_Package (Context) then
3577 Body_Decl := Find_Corresponding_Body (Context);
3579 -- The optional body is within the body of the enclosing package
3581 if Present (Body_Decl) then
3584 (Spec_Id => Spec_Id,
3585 From => First (Declarations (Body_Decl)));
3587 -- Otherwise the enclosing package does not have a body. This may
3588 -- be the result of an error or a genuine lack of a body.
3594 -- Otherwise the immediate context is a body. The optional body may
3595 -- be within the same list as the spec.
3597 -- procedure Proc is
3602 -- package body Pack is -- optional body
3609 (Spec_Id => Spec_Id,
3610 From => Next (Spec_Decl));
3612 end Find_Corresponding_Body;
3619 (Spec_Id : Entity_Id;
3620 From : Node_Id) return Node_Id
3622 Spec_Nam : constant Name_Id := Chars (Spec_Id);
3628 while Present (Item) loop
3630 -- The current item denotes the optional body
3632 if Nkind (Item) = N_Package_Body
3633 and then Chars (Defining_Entity (Item)) = Spec_Nam
3637 -- The current item denotes a stub, the optional body may be in
3640 elsif Nkind (Item) = N_Package_Body_Stub
3641 and then Chars (Defining_Entity (Item)) = Spec_Nam
3643 Lib_Unit := Library_Unit (Item);
3645 -- The corresponding subunit was previously loaded
3647 if Present (Lib_Unit) then
3650 -- Otherwise attempt to load the corresponding subunit
3653 return Load_Package_Body (Get_Unit_Name (Item));
3663 -----------------------
3664 -- Load_Package_Body --
3665 -----------------------
3667 function Load_Package_Body (Unit_Nam : Unit_Name_Type) return Node_Id is
3668 Body_Decl : Node_Id;
3669 Unit_Num : Unit_Number_Type;
3672 -- The load is performed only when the compilation will generate code
3674 if Operating_Mode = Generate_Code then
3677 (Load_Name => Unit_Nam,
3680 Error_Node => Pack_Decl);
3682 -- The load failed most likely because the physical file is
3685 if Unit_Num = No_Unit then
3688 -- Otherwise the load was successful, return the body of the unit
3691 Body_Decl := Unit (Cunit (Unit_Num));
3693 -- If the unit is a subunit with an available proper body,
3694 -- return the proper body.
3696 if Nkind (Body_Decl) = N_Subunit
3697 and then Present (Proper_Body (Body_Decl))
3699 Body_Decl := Proper_Body (Body_Decl);
3707 end Load_Package_Body;
3711 Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
3713 -- Start of processing for Has_Body
3716 -- The body is available
3718 if Present (Corresponding_Body (Pack_Decl)) then
3721 -- The body is required if the package spec contains a construct which
3722 -- requires a completion in a body.
3724 elsif Unit_Requires_Body (Pack_Id) then
3727 -- The body may be optional
3730 return Present (Find_Corresponding_Body (Pack_Id));
3734 ---------------------------
3735 -- Has_Prior_Elaboration --
3736 ---------------------------
3738 function Has_Prior_Elaboration
3739 (Unit_Id : Entity_Id;
3740 Context_OK : Boolean := False;
3741 Elab_Body_OK : Boolean := False;
3742 Same_Unit_OK : Boolean := False) return Boolean
3744 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit);
3747 -- A preelaborated unit is always elaborated prior to the main unit
3749 if Is_Preelaborated_Unit (Unit_Id) then
3752 -- An internal unit is always elaborated prior to a non-internal main
3755 elsif In_Internal_Unit (Unit_Id)
3756 and then not In_Internal_Unit (Main_Id)
3760 -- A unit has prior elaboration if it appears within the context of the
3761 -- main unit. Consider this case only when requested by the caller.
3764 and then Elaboration_Context.Get (Unit_Id) /= No_Elaboration_Attributes
3768 -- A unit whose body is elaborated together with its spec has prior
3769 -- elaboration except with respect to itself. Consider this case only
3770 -- when requested by the caller.
3773 and then Has_Pragma_Elaborate_Body (Unit_Id)
3774 and then not Is_Same_Unit (Unit_Id, Main_Id)
3778 -- A unit has no prior elaboration with respect to itself, but does not
3779 -- require any means of ensuring its own elaboration either. Treat this
3780 -- case as valid prior elaboration only when requested by the caller.
3782 elsif Same_Unit_OK and then Is_Same_Unit (Unit_Id, Main_Id) then
3787 end Has_Prior_Elaboration;
3789 --------------------------
3790 -- In_External_Instance --
3791 --------------------------
3793 function In_External_Instance
3795 Target_Decl : Node_Id) return Boolean
3798 Inst_Body : Node_Id;
3799 Inst_Decl : Node_Id;
3802 -- Performance note: parent traversal
3804 Inst_Decl := Find_Enclosing_Instance (Target_Decl);
3806 -- The target declaration appears within an instance spec. Visibility is
3807 -- ignored because internally generated primitives for private types may
3808 -- reside in the private declarations and still be invoked from outside.
3810 if Present (Inst_Decl)
3811 and then Nkind (Inst_Decl) = N_Package_Declaration
3813 -- The scenario comes from the main unit and the instance does not
3815 if In_Extended_Main_Code_Unit (N)
3816 and then not In_Extended_Main_Code_Unit (Inst_Decl)
3820 -- Otherwise the scenario must not appear within the instance spec or
3824 Extract_Instance_Attributes
3825 (Exp_Inst => Inst_Decl,
3826 Inst_Body => Inst_Body,
3827 Inst_Decl => Dummy);
3829 -- Performance note: parent traversal
3831 return not In_Subtree
3834 Root2 => Inst_Body);
3839 end In_External_Instance;
3841 ---------------------
3842 -- In_Main_Context --
3843 ---------------------
3845 function In_Main_Context (N : Node_Id) return Boolean is
3847 -- Scenarios outside the main unit are not considered because the ALI
3848 -- information supplied to binde is for the main unit only.
3850 if not In_Extended_Main_Code_Unit (N) then
3853 -- Scenarios within internal units are not considered unless switch
3854 -- -gnatdE (elaboration checks on predefined units) is in effect.
3856 elsif not Debug_Flag_EE and then In_Internal_Unit (N) then
3861 end In_Main_Context;
3863 ---------------------
3864 -- In_Same_Context --
3865 ---------------------
3867 function In_Same_Context
3870 Nested_OK : Boolean := False) return Boolean
3872 function Find_Enclosing_Context (N : Node_Id) return Node_Id;
3873 -- Return the nearest enclosing non-library level or compilation unit
3874 -- node which which encapsulates arbitrary node N. Return Empty is no
3875 -- such context is available.
3877 function In_Nested_Context
3879 Inner : Node_Id) return Boolean;
3880 -- Determine whether arbitrary node Outer encapsulates arbitrary node
3883 ----------------------------
3884 -- Find_Enclosing_Context --
3885 ----------------------------
3887 function Find_Enclosing_Context (N : Node_Id) return Node_Id is
3893 while Present (Par) loop
3895 -- A traversal from a subunit continues via the corresponding stub
3897 if Nkind (Par) = N_Subunit then
3898 Par := Corresponding_Stub (Par);
3900 -- Stop the traversal when the nearest enclosing non-library level
3901 -- encapsulator has been reached.
3903 elsif Is_Non_Library_Level_Encapsulator (Par) then
3904 Context := Parent (Par);
3906 -- The sole exception is when the encapsulator is the unit of
3907 -- compilation because this case requires special processing
3910 if Present (Context)
3911 and then Nkind (Context) = N_Compilation_Unit
3919 -- Reaching a compilation unit node without hitting a non-library
3920 -- level encapsulator indicates that N is at the library level in
3921 -- which case the compilation unit is the context.
3923 elsif Nkind (Par) = N_Compilation_Unit then
3927 Par := Parent (Par);
3931 end Find_Enclosing_Context;
3933 -----------------------
3934 -- In_Nested_Context --
3935 -----------------------
3937 function In_Nested_Context
3939 Inner : Node_Id) return Boolean
3945 while Present (Par) loop
3947 -- A traversal from a subunit continues via the corresponding stub
3949 if Nkind (Par) = N_Subunit then
3950 Par := Corresponding_Stub (Par);
3952 elsif Par = Outer then
3956 Par := Parent (Par);
3960 end In_Nested_Context;
3964 Context_1 : constant Node_Id := Find_Enclosing_Context (N1);
3965 Context_2 : constant Node_Id := Find_Enclosing_Context (N2);
3967 -- Start of processing for In_Same_Context
3970 -- Both nodes appear within the same context
3972 if Context_1 = Context_2 then
3975 -- Both nodes appear in compilation units. Determine whether one unit
3976 -- is the body of the other.
3978 elsif Nkind (Context_1) = N_Compilation_Unit
3979 and then Nkind (Context_2) = N_Compilation_Unit
3983 (Unit_1 => Defining_Entity (Unit (Context_1)),
3984 Unit_2 => Defining_Entity (Unit (Context_2)));
3986 -- The context of N1 encloses the context of N2
3988 elsif Nested_OK and then In_Nested_Context (Context_1, Context_2) then
3993 end In_Same_Context;
3999 procedure Initialize is
4001 -- Set the soft link which enables Atree.Rewrite to update a top level
4002 -- scenario each time it is transformed into another node.
4004 Set_Rewriting_Proc (Update_Elaboration_Scenario'Access);
4013 Target_Id : Entity_Id;
4017 procedure Info_Accept_Alternative;
4018 pragma Inline (Info_Accept_Alternative);
4019 -- Output information concerning an accept alternative
4021 procedure Info_Simple_Call;
4022 pragma Inline (Info_Simple_Call);
4023 -- Output information concerning the call
4025 procedure Info_Type_Actions (Action : String);
4026 pragma Inline (Info_Type_Actions);
4027 -- Output information concerning action Action of a type
4029 procedure Info_Verification_Call
4033 pragma Inline (Info_Verification_Call);
4034 -- Output information concerning the verification of predicate Pred
4035 -- applied to related entity Id with kind Id_Kind.
4037 -----------------------------
4038 -- Info_Accept_Alternative --
4039 -----------------------------
4041 procedure Info_Accept_Alternative is
4042 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id);
4045 pragma Assert (Present (Entry_Id));
4048 (Msg => "accept for entry & during elaboration",
4051 Info_Msg => Info_Msg,
4052 In_SPARK => In_SPARK);
4053 end Info_Accept_Alternative;
4055 ----------------------
4056 -- Info_Simple_Call --
4057 ----------------------
4059 procedure Info_Simple_Call is
4062 (Msg => "call to & during elaboration",
4065 Info_Msg => Info_Msg,
4066 In_SPARK => In_SPARK);
4067 end Info_Simple_Call;
4069 -----------------------
4070 -- Info_Type_Actions --
4071 -----------------------
4073 procedure Info_Type_Actions (Action : String) is
4074 Typ : constant Entity_Id := First_Formal_Type (Target_Id);
4077 pragma Assert (Present (Typ));
4080 (Msg => Action & " actions for type & during elaboration",
4083 Info_Msg => Info_Msg,
4084 In_SPARK => In_SPARK);
4085 end Info_Type_Actions;
4087 ----------------------------
4088 -- Info_Verification_Call --
4089 ----------------------------
4091 procedure Info_Verification_Call
4097 pragma Assert (Present (Id));
4101 "verification of " & Pred & " of " & Id_Kind & " & during "
4105 Info_Msg => Info_Msg,
4106 In_SPARK => In_SPARK);
4107 end Info_Verification_Call;
4109 -- Start of processing for Info_Call
4112 -- Do not output anything for targets defined in internal units because
4113 -- this creates noise.
4115 if not In_Internal_Unit (Target_Id) then
4117 -- Accept alternative
4119 if Is_Accept_Alternative_Proc (Target_Id) then
4120 Info_Accept_Alternative;
4124 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then
4125 Info_Type_Actions ("adjustment");
4127 -- Default_Initial_Condition
4129 elsif Is_Default_Initial_Condition_Proc (Target_Id) then
4130 Info_Verification_Call
4131 (Pred => "Default_Initial_Condition",
4132 Id => First_Formal_Type (Target_Id),
4137 elsif Is_Protected_Entry (Target_Id) then
4140 -- Task entry calls are never processed because the entry being
4141 -- invoked does not have a corresponding "body", it has a select.
4143 elsif Is_Task_Entry (Target_Id) then
4148 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then
4149 Info_Type_Actions ("finalization");
4151 -- Calls to _Finalizer procedures must not appear in the output
4152 -- because this creates confusing noise.
4154 elsif Is_Finalizer_Proc (Target_Id) then
4157 -- Initial_Condition
4159 elsif Is_Initial_Condition_Proc (Target_Id) then
4160 Info_Verification_Call
4161 (Pred => "Initial_Condition",
4162 Id => Find_Enclosing_Scope (Call),
4163 Id_Kind => "package");
4167 elsif Is_Init_Proc (Target_Id)
4168 or else Is_TSS (Target_Id, TSS_Deep_Initialize)
4170 Info_Type_Actions ("initialization");
4174 elsif Is_Invariant_Proc (Target_Id) then
4175 Info_Verification_Call
4176 (Pred => "invariants",
4177 Id => First_Formal_Type (Target_Id),
4180 -- Partial invariant calls must not appear in the output because this
4181 -- creates confusing noise.
4183 elsif Is_Partial_Invariant_Proc (Target_Id) then
4188 elsif Is_Postconditions_Proc (Target_Id) then
4189 Info_Verification_Call
4190 (Pred => "postconditions",
4191 Id => Find_Enclosing_Scope (Call),
4192 Id_Kind => "subprogram");
4194 -- Subprograms must come last because some of the previous cases fall
4195 -- under this category.
4197 elsif Ekind (Target_Id) = E_Function then
4200 elsif Ekind (Target_Id) = E_Procedure then
4204 pragma Assert (False);
4210 ------------------------
4211 -- Info_Instantiation --
4212 ------------------------
4214 procedure Info_Instantiation
4222 (Msg => "instantiation of & during elaboration",
4225 Info_Msg => Info_Msg,
4226 In_SPARK => In_SPARK);
4227 end Info_Instantiation;
4229 ------------------------
4230 -- Info_Variable_Read --
4231 ------------------------
4233 procedure Info_Variable_Read
4241 (Msg => "read of variable & during elaboration",
4244 Info_Msg => Info_Msg,
4245 In_SPARK => In_SPARK);
4246 end Info_Variable_Read;
4248 --------------------
4249 -- Insertion_Node --
4250 --------------------
4252 function Insertion_Node (N : Node_Id; Ins_Nod : Node_Id) return Node_Id is
4254 -- When the scenario denotes an instantiation, the proper insertion node
4255 -- is the instance spec. This ensures that the generic actuals will not
4256 -- be evaluated prior to a potential ABE.
4258 if Nkind (N) in N_Generic_Instantiation
4259 and then Present (Instance_Spec (N))
4261 return Instance_Spec (N);
4263 -- Otherwise the proper insertion node is the candidate insertion node
4270 -----------------------
4271 -- Install_ABE_Check --
4272 -----------------------
4274 procedure Install_ABE_Check
4279 Check_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod);
4280 -- Insert the check prior to this node
4282 Loc : constant Source_Ptr := Sloc (N);
4283 Spec_Id : constant Entity_Id := Unique_Entity (Id);
4284 Unit_Id : constant Entity_Id := Find_Top_Unit (Id);
4285 Scop_Id : Entity_Id;
4288 -- Nothing to do when compiling for GNATprove because raise statements
4289 -- are not supported.
4291 if GNATprove_Mode then
4294 -- Nothing to do when the compilation will not produce an executable
4296 elsif Serious_Errors_Detected > 0 then
4299 -- Nothing to do for a compilation unit because there is no executable
4300 -- environment at that level.
4302 elsif Nkind (Parent (Check_Ins_Nod)) = N_Compilation_Unit then
4305 -- Nothing to do when the unit is elaborated prior to the main unit.
4306 -- This check must also consider the following cases:
4308 -- * Id's unit appears in the context of the main unit
4310 -- * Id's unit is subject to pragma Elaborate_Body. An ABE check MUST
4311 -- NOT be generated because Id's unit is always elaborated prior to
4314 -- * Id's unit is the main unit. An ABE check MUST be generated in this
4315 -- case because a conditional ABE may be raised depending on the flow
4316 -- of execution within the main unit (flag Same_Unit_OK is False).
4318 elsif Has_Prior_Elaboration
4319 (Unit_Id => Unit_Id,
4321 Elab_Body_OK => True)
4326 -- Prevent multiple scenarios from installing the same ABE check
4328 Set_Is_Elaboration_Checks_OK_Node (N, False);
4330 -- Install the nearest enclosing scope of the scenario as there must be
4331 -- something on the scope stack.
4333 -- Performance note: parent traversal
4335 Scop_Id := Find_Enclosing_Scope (Check_Ins_Nod);
4336 pragma Assert (Present (Scop_Id));
4338 Push_Scope (Scop_Id);
4341 -- if not Spec_Id'Elaborated then
4342 -- raise Program_Error with "access before elaboration";
4345 Insert_Action (Check_Ins_Nod,
4346 Make_Raise_Program_Error (Loc,
4350 Make_Attribute_Reference (Loc,
4351 Prefix => New_Occurrence_Of (Spec_Id, Loc),
4352 Attribute_Name => Name_Elaborated)),
4353 Reason => PE_Access_Before_Elaboration));
4356 end Install_ABE_Check;
4358 -----------------------
4359 -- Install_ABE_Check --
4360 -----------------------
4362 procedure Install_ABE_Check
4364 Target_Id : Entity_Id;
4365 Target_Decl : Node_Id;
4366 Target_Body : Node_Id;
4369 procedure Build_Elaboration_Entity;
4370 pragma Inline (Build_Elaboration_Entity);
4371 -- Create a new elaboration flag for Target_Id, insert it prior to
4372 -- Target_Decl, and set it after Body_Decl.
4374 ------------------------------
4375 -- Build_Elaboration_Entity --
4376 ------------------------------
4378 procedure Build_Elaboration_Entity is
4379 Loc : constant Source_Ptr := Sloc (Target_Id);
4380 Flag_Id : Entity_Id;
4383 -- Create the declaration of the elaboration flag. The name carries a
4384 -- unique counter in case of name overloading.
4387 Make_Defining_Identifier (Loc,
4388 Chars => New_External_Name (Chars (Target_Id), 'E', -1));
4390 Set_Elaboration_Entity (Target_Id, Flag_Id);
4391 Set_Elaboration_Entity_Required (Target_Id);
4393 Push_Scope (Scope (Target_Id));
4396 -- Enn : Short_Integer := 0;
4398 Insert_Action (Target_Decl,
4399 Make_Object_Declaration (Loc,
4400 Defining_Identifier => Flag_Id,
4401 Object_Definition =>
4402 New_Occurrence_Of (Standard_Short_Integer, Loc),
4403 Expression => Make_Integer_Literal (Loc, Uint_0)));
4408 Set_Elaboration_Flag (Target_Body, Target_Id);
4411 end Build_Elaboration_Entity;
4415 Target_Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id);
4417 -- Start for processing for Install_ABE_Check
4420 -- Nothing to do when compiling for GNATprove because raise statements
4421 -- are not supported.
4423 if GNATprove_Mode then
4426 -- Nothing to do when the compilation will not produce an executable
4428 elsif Serious_Errors_Detected > 0 then
4431 -- Nothing to do when the target is a protected subprogram because the
4432 -- check is associated with the protected body subprogram.
4434 elsif Is_Protected_Subp (Target_Id) then
4437 -- Nothing to do when the target is elaborated prior to the main unit.
4438 -- This check must also consider the following cases:
4440 -- * The unit of the target appears in the context of the main unit
4442 -- * The unit of the target is subject to pragma Elaborate_Body. An ABE
4443 -- check MUST NOT be generated because the unit is always elaborated
4444 -- prior to the main unit.
4446 -- * The unit of the target is the main unit. An ABE check MUST be added
4447 -- in this case because a conditional ABE may be raised depending on
4448 -- the flow of execution within the main unit (flag Same_Unit_OK is
4451 elsif Has_Prior_Elaboration
4452 (Unit_Id => Target_Unit_Id,
4454 Elab_Body_OK => True)
4458 -- Create an elaboration flag for the target when it does not have one
4460 elsif No (Elaboration_Entity (Target_Id)) then
4461 Build_Elaboration_Entity;
4468 end Install_ABE_Check;
4470 -------------------------
4471 -- Install_ABE_Failure --
4472 -------------------------
4474 procedure Install_ABE_Failure (N : Node_Id; Ins_Nod : Node_Id) is
4475 Fail_Ins_Nod : constant Node_Id := Insertion_Node (N, Ins_Nod);
4476 -- Insert the failure prior to this node
4478 Loc : constant Source_Ptr := Sloc (N);
4479 Scop_Id : Entity_Id;
4482 -- Nothing to do when compiling for GNATprove because raise statements
4483 -- are not supported.
4485 if GNATprove_Mode then
4488 -- Nothing to do when the compilation will not produce an executable
4490 elsif Serious_Errors_Detected > 0 then
4493 -- Do not install an ABE check for a compilation unit because there is
4494 -- no executable environment at that level.
4496 elsif Nkind (Parent (Fail_Ins_Nod)) = N_Compilation_Unit then
4500 -- Prevent multiple scenarios from installing the same ABE failure
4502 Set_Is_Elaboration_Checks_OK_Node (N, False);
4504 -- Install the nearest enclosing scope of the scenario as there must be
4505 -- something on the scope stack.
4507 -- Performance note: parent traversal
4509 Scop_Id := Find_Enclosing_Scope (Fail_Ins_Nod);
4510 pragma Assert (Present (Scop_Id));
4512 Push_Scope (Scop_Id);
4515 -- raise Program_Error with "access before elaboration";
4517 Insert_Action (Fail_Ins_Nod,
4518 Make_Raise_Program_Error (Loc,
4519 Reason => PE_Access_Before_Elaboration));
4522 end Install_ABE_Failure;
4524 --------------------------------
4525 -- Is_Accept_Alternative_Proc --
4526 --------------------------------
4528 function Is_Accept_Alternative_Proc (Id : Entity_Id) return Boolean is
4530 -- To qualify, the entity must denote a procedure with a receiving entry
4532 return Ekind (Id) = E_Procedure and then Present (Receiving_Entry (Id));
4533 end Is_Accept_Alternative_Proc;
4535 ------------------------
4536 -- Is_Activation_Proc --
4537 ------------------------
4539 function Is_Activation_Proc (Id : Entity_Id) return Boolean is
4541 -- To qualify, the entity must denote one of the runtime procedures in
4542 -- charge of task activation.
4544 if Ekind (Id) = E_Procedure then
4545 if Restricted_Profile then
4546 return Is_RTE (Id, RE_Activate_Restricted_Tasks);
4548 return Is_RTE (Id, RE_Activate_Tasks);
4553 end Is_Activation_Proc;
4555 ----------------------------
4556 -- Is_Ada_Semantic_Target --
4557 ----------------------------
4559 function Is_Ada_Semantic_Target (Id : Entity_Id) return Boolean is
4562 Is_Activation_Proc (Id)
4563 or else Is_Controlled_Proc (Id, Name_Adjust)
4564 or else Is_Controlled_Proc (Id, Name_Finalize)
4565 or else Is_Controlled_Proc (Id, Name_Initialize)
4566 or else Is_Init_Proc (Id)
4567 or else Is_Invariant_Proc (Id)
4568 or else Is_Protected_Entry (Id)
4569 or else Is_Protected_Subp (Id)
4570 or else Is_Protected_Body_Subp (Id)
4571 or else Is_Task_Entry (Id);
4572 end Is_Ada_Semantic_Target;
4574 ----------------------------
4575 -- Is_Bodiless_Subprogram --
4576 ----------------------------
4578 function Is_Bodiless_Subprogram (Subp_Id : Entity_Id) return Boolean is
4580 -- An abstract subprogram does not have a body
4582 if Ekind_In (Subp_Id, E_Function,
4585 and then Is_Abstract_Subprogram (Subp_Id)
4589 -- A formal subprogram does not have a body
4591 elsif Is_Formal_Subprogram (Subp_Id) then
4594 -- An imported subprogram may have a body, however it is not known at
4595 -- compile or bind time where the body resides and whether it will be
4596 -- elaborated on time.
4598 elsif Is_Imported (Subp_Id) then
4603 end Is_Bodiless_Subprogram;
4605 --------------------------------
4606 -- Is_Check_Emitting_Scenario --
4607 --------------------------------
4609 function Is_Check_Emitting_Scenario (N : Node_Id) return Boolean is
4612 Nkind_In (N, N_Call_Marker,
4613 N_Function_Instantiation,
4614 N_Package_Instantiation,
4615 N_Procedure_Instantiation);
4616 end Is_Check_Emitting_Scenario;
4618 ------------------------
4619 -- Is_Controlled_Proc --
4620 ------------------------
4622 function Is_Controlled_Proc
4623 (Subp_Id : Entity_Id;
4624 Subp_Nam : Name_Id) return Boolean
4626 Formal_Id : Entity_Id;
4629 pragma Assert (Nam_In (Subp_Nam, Name_Adjust,
4633 -- To qualify, the subprogram must denote a source procedure with name
4634 -- Adjust, Finalize, or Initialize where the sole formal is controlled.
4636 if Comes_From_Source (Subp_Id)
4637 and then Ekind (Subp_Id) = E_Procedure
4638 and then Chars (Subp_Id) = Subp_Nam
4640 Formal_Id := First_Formal (Subp_Id);
4644 and then Is_Controlled (Etype (Formal_Id))
4645 and then No (Next_Formal (Formal_Id));
4649 end Is_Controlled_Proc;
4651 ---------------------------------------
4652 -- Is_Default_Initial_Condition_Proc --
4653 ---------------------------------------
4655 function Is_Default_Initial_Condition_Proc
4656 (Id : Entity_Id) return Boolean
4659 -- To qualify, the entity must denote a Default_Initial_Condition
4662 return Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id);
4663 end Is_Default_Initial_Condition_Proc;
4665 -----------------------
4666 -- Is_Finalizer_Proc --
4667 -----------------------
4669 function Is_Finalizer_Proc (Id : Entity_Id) return Boolean is
4671 -- To qualify, the entity must denote a _Finalizer procedure
4673 return Ekind (Id) = E_Procedure and then Chars (Id) = Name_uFinalizer;
4674 end Is_Finalizer_Proc;
4676 -----------------------
4677 -- Is_Guaranteed_ABE --
4678 -----------------------
4680 function Is_Guaranteed_ABE
4682 Target_Decl : Node_Id;
4683 Target_Body : Node_Id) return Boolean
4686 -- Avoid cascaded errors if there were previous serious infractions.
4687 -- As a result the scenario will not be treated as a guaranteed ABE.
4688 -- This behaviour parallels that of the old ABE mechanism.
4690 if Serious_Errors_Detected > 0 then
4693 -- The scenario and the target appear within the same context ignoring
4694 -- enclosing library levels.
4696 -- Performance note: parent traversal
4698 elsif In_Same_Context (N, Target_Decl) then
4700 -- The target body has already been encountered. The scenario results
4701 -- in a guaranteed ABE if it appears prior to the body.
4703 if Present (Target_Body) then
4704 return Earlier_In_Extended_Unit (N, Target_Body);
4706 -- Otherwise the body has not been encountered yet. The scenario is
4707 -- a guaranteed ABE since the body will appear later. It is assumed
4708 -- that the caller has already checked whether the scenario is ABE-
4709 -- safe as optional bodies are not considered here.
4717 end Is_Guaranteed_ABE;
4719 -------------------------------
4720 -- Is_Initial_Condition_Proc --
4721 -------------------------------
4723 function Is_Initial_Condition_Proc (Id : Entity_Id) return Boolean is
4725 -- To qualify, the entity must denote an Initial_Condition procedure
4728 Ekind (Id) = E_Procedure and then Is_Initial_Condition_Procedure (Id);
4729 end Is_Initial_Condition_Proc;
4731 --------------------
4732 -- Is_Initialized --
4733 --------------------
4735 function Is_Initialized (Obj_Decl : Node_Id) return Boolean is
4737 -- To qualify, the object declaration must have an expression
4740 Present (Expression (Obj_Decl)) or else Has_Init_Expression (Obj_Decl);
4743 -----------------------
4744 -- Is_Invariant_Proc --
4745 -----------------------
4747 function Is_Invariant_Proc (Id : Entity_Id) return Boolean is
4749 -- To qualify, the entity must denote the "full" invariant procedure
4751 return Ekind (Id) = E_Procedure and then Is_Invariant_Procedure (Id);
4752 end Is_Invariant_Proc;
4754 ---------------------------------------
4755 -- Is_Non_Library_Level_Encapsulator --
4756 ---------------------------------------
4758 function Is_Non_Library_Level_Encapsulator (N : Node_Id) return Boolean is
4761 when N_Abstract_Subprogram_Declaration
4762 | N_Aspect_Specification
4763 | N_Component_Declaration
4765 | N_Entry_Declaration
4766 | N_Expression_Function
4767 | N_Formal_Abstract_Subprogram_Declaration
4768 | N_Formal_Concrete_Subprogram_Declaration
4769 | N_Formal_Object_Declaration
4770 | N_Formal_Package_Declaration
4771 | N_Formal_Type_Declaration
4772 | N_Generic_Association
4773 | N_Implicit_Label_Declaration
4774 | N_Incomplete_Type_Declaration
4775 | N_Private_Extension_Declaration
4776 | N_Private_Type_Declaration
4778 | N_Protected_Type_Declaration
4779 | N_Single_Protected_Declaration
4780 | N_Single_Task_Declaration
4782 | N_Subprogram_Declaration
4784 | N_Task_Type_Declaration
4789 return Is_Generic_Declaration_Or_Body (N);
4791 end Is_Non_Library_Level_Encapsulator;
4793 -------------------------------
4794 -- Is_Partial_Invariant_Proc --
4795 -------------------------------
4797 function Is_Partial_Invariant_Proc (Id : Entity_Id) return Boolean is
4799 -- To qualify, the entity must denote the "partial" invariant procedure
4802 Ekind (Id) = E_Procedure and then Is_Partial_Invariant_Procedure (Id);
4803 end Is_Partial_Invariant_Proc;
4805 ----------------------------
4806 -- Is_Postconditions_Proc --
4807 ----------------------------
4809 function Is_Postconditions_Proc (Id : Entity_Id) return Boolean is
4811 -- To qualify, the entity must denote a _Postconditions procedure
4814 Ekind (Id) = E_Procedure and then Chars (Id) = Name_uPostconditions;
4815 end Is_Postconditions_Proc;
4817 ---------------------------
4818 -- Is_Preelaborated_Unit --
4819 ---------------------------
4821 function Is_Preelaborated_Unit (Id : Entity_Id) return Boolean is
4824 Is_Preelaborated (Id)
4825 or else Is_Pure (Id)
4826 or else Is_Remote_Call_Interface (Id)
4827 or else Is_Remote_Types (Id)
4828 or else Is_Shared_Passive (Id);
4829 end Is_Preelaborated_Unit;
4831 ------------------------
4832 -- Is_Protected_Entry --
4833 ------------------------
4835 function Is_Protected_Entry (Id : Entity_Id) return Boolean is
4837 -- To qualify, the entity must denote an entry defined in a protected
4842 and then Is_Protected_Type (Non_Private_View (Scope (Id)));
4843 end Is_Protected_Entry;
4845 -----------------------
4846 -- Is_Protected_Subp --
4847 -----------------------
4849 function Is_Protected_Subp (Id : Entity_Id) return Boolean is
4851 -- To qualify, the entity must denote a subprogram defined within a
4855 Ekind_In (Id, E_Function, E_Procedure)
4856 and then Is_Protected_Type (Non_Private_View (Scope (Id)));
4857 end Is_Protected_Subp;
4859 ----------------------------
4860 -- Is_Protected_Body_Subp --
4861 ----------------------------
4863 function Is_Protected_Body_Subp (Id : Entity_Id) return Boolean is
4865 -- To qualify, the entity must denote a subprogram with attribute
4866 -- Protected_Subprogram set.
4869 Ekind_In (Id, E_Function, E_Procedure)
4870 and then Present (Protected_Subprogram (Id));
4871 end Is_Protected_Body_Subp;
4873 ------------------------
4874 -- Is_Safe_Activation --
4875 ------------------------
4877 function Is_Safe_Activation
4879 Task_Decl : Node_Id) return Boolean
4882 -- The activation of a task coming from an external instance cannot
4883 -- cause an ABE because the generic was already instantiated. Note
4884 -- that the instantiation itself may lead to an ABE.
4887 In_External_Instance
4889 Target_Decl => Task_Decl);
4890 end Is_Safe_Activation;
4896 function Is_Safe_Call
4898 Target_Attrs : Target_Attributes) return Boolean
4901 -- The target is either an abstract subprogram, formal subprogram, or
4902 -- imported, in which case it does not have a body at compile or bind
4903 -- time. Assume that the call is ABE-safe.
4905 if Is_Bodiless_Subprogram (Target_Attrs.Spec_Id) then
4908 -- The target is an instantiation of a generic subprogram. The call
4909 -- cannot cause an ABE because the generic was already instantiated.
4910 -- Note that the instantiation itself may lead to an ABE.
4912 elsif Is_Generic_Instance (Target_Attrs.Spec_Id) then
4915 -- The invocation of a target coming from an external instance cannot
4916 -- cause an ABE because the generic was already instantiated. Note that
4917 -- the instantiation itself may lead to an ABE.
4919 elsif In_External_Instance
4921 Target_Decl => Target_Attrs.Spec_Decl)
4925 -- The target is a subprogram body without a previous declaration. The
4926 -- call cannot cause an ABE because the body has already been seen.
4928 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body
4929 and then No (Corresponding_Spec (Target_Attrs.Spec_Decl))
4933 -- The target is a subprogram body stub without a prior declaration.
4934 -- The call cannot cause an ABE because the proper body substitutes
4937 elsif Nkind (Target_Attrs.Spec_Decl) = N_Subprogram_Body_Stub
4938 and then No (Corresponding_Spec_Of_Stub (Target_Attrs.Spec_Decl))
4942 -- Subprogram bodies which wrap attribute references used as actuals
4943 -- in instantiations are always ABE-safe. These bodies are artifacts
4946 elsif Present (Target_Attrs.Body_Decl)
4947 and then Nkind (Target_Attrs.Body_Decl) = N_Subprogram_Body
4948 and then Was_Attribute_Reference (Target_Attrs.Body_Decl)
4956 ---------------------------
4957 -- Is_Safe_Instantiation --
4958 ---------------------------
4960 function Is_Safe_Instantiation
4962 Gen_Attrs : Target_Attributes) return Boolean
4965 -- The generic is an intrinsic subprogram in which case it does not
4966 -- have a body at compile or bind time. Assume that the instantiation
4969 if Is_Bodiless_Subprogram (Gen_Attrs.Spec_Id) then
4972 -- The instantiation of an external nested generic cannot cause an ABE
4973 -- if the outer generic was already instantiated. Note that the instance
4974 -- of the outer generic may lead to an ABE.
4976 elsif In_External_Instance
4978 Target_Decl => Gen_Attrs.Spec_Decl)
4982 -- The generic is a package. The instantiation cannot cause an ABE when
4983 -- the package has no body.
4985 elsif Ekind (Gen_Attrs.Spec_Id) = E_Generic_Package
4986 and then not Has_Body (Gen_Attrs.Spec_Decl)
4992 end Is_Safe_Instantiation;
4998 function Is_Same_Unit
4999 (Unit_1 : Entity_Id;
5000 Unit_2 : Entity_Id) return Boolean
5002 function Is_Subunit (Unit_Id : Entity_Id) return Boolean;
5003 pragma Inline (Is_Subunit);
5004 -- Determine whether unit Unit_Id is a subunit
5006 function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id;
5007 -- Strip a potential subunit chain ending with unit Unit_Id and return
5008 -- the corresponding spec.
5014 function Is_Subunit (Unit_Id : Entity_Id) return Boolean is
5016 return Nkind (Parent (Unit_Declaration_Node (Unit_Id))) = N_Subunit;
5019 --------------------
5020 -- Normalize_Unit --
5021 --------------------
5023 function Normalize_Unit (Unit_Id : Entity_Id) return Entity_Id is
5027 -- Eliminate a potential chain of subunits to reach to proper body
5030 while Present (Result)
5031 and then Result /= Standard_Standard
5032 and then Is_Subunit (Result)
5034 Result := Scope (Result);
5037 -- Obtain the entity of the corresponding spec (if any)
5039 return Unique_Entity (Result);
5042 -- Start of processing for Is_Same_Unit
5045 return Normalize_Unit (Unit_1) = Normalize_Unit (Unit_2);
5052 function Is_Scenario (N : Node_Id) return Boolean is
5055 when N_Assignment_Statement
5056 | N_Attribute_Reference
5058 | N_Entry_Call_Statement
5061 | N_Function_Instantiation
5063 | N_Package_Instantiation
5064 | N_Procedure_Call_Statement
5065 | N_Procedure_Instantiation
5066 | N_Requeue_Statement
5075 ------------------------------
5076 -- Is_SPARK_Semantic_Target --
5077 ------------------------------
5079 function Is_SPARK_Semantic_Target (Id : Entity_Id) return Boolean is
5082 Is_Default_Initial_Condition_Proc (Id)
5083 or else Is_Initial_Condition_Proc (Id);
5084 end Is_SPARK_Semantic_Target;
5086 ------------------------
5087 -- Is_Suitable_Access --
5088 ------------------------
5090 function Is_Suitable_Access (N : Node_Id) return Boolean is
5093 Subp_Id : Entity_Id;
5096 -- This scenario is relevant only when the static model is in effect
5097 -- because it is graph-dependent and does not involve any run-time
5098 -- checks. Allowing it in the dynamic model would create confusing
5101 if not Static_Elaboration_Checks then
5104 -- Nothing to do when switch -gnatd.U (ignore 'Access) is in effect
5106 elsif Debug_Flag_Dot_UU then
5109 -- Nothing to do when the scenario is not an attribute reference
5111 elsif Nkind (N) /= N_Attribute_Reference then
5114 -- Nothing to do for internally-generated attributes because they are
5115 -- assumed to be ABE safe.
5117 elsif not Comes_From_Source (N) then
5121 Nam := Attribute_Name (N);
5124 -- Sanitize the prefix of the attribute
5126 if not Is_Entity_Name (Pref) then
5129 elsif No (Entity (Pref)) then
5133 Subp_Id := Entity (Pref);
5135 if not Is_Subprogram_Or_Entry (Subp_Id) then
5139 -- Traverse a possible chain of renamings to obtain the original entry
5140 -- or subprogram which the prefix may rename.
5142 Subp_Id := Get_Renamed_Entity (Subp_Id);
5144 -- To qualify, the attribute must meet the following prerequisites:
5148 -- The prefix must denote a source entry, operator, or subprogram
5149 -- which is not imported.
5151 Comes_From_Source (Subp_Id)
5152 and then Is_Subprogram_Or_Entry (Subp_Id)
5153 and then not Is_Bodiless_Subprogram (Subp_Id)
5155 -- The attribute name must be one of the 'Access forms. Note that
5156 -- 'Unchecked_Access cannot apply to a subprogram.
5158 and then Nam_In (Nam, Name_Access, Name_Unrestricted_Access);
5159 end Is_Suitable_Access;
5161 ----------------------
5162 -- Is_Suitable_Call --
5163 ----------------------
5165 function Is_Suitable_Call (N : Node_Id) return Boolean is
5167 -- Entry and subprogram calls are intentionally ignored because they
5168 -- may undergo expansion depending on the compilation mode, previous
5169 -- errors, generic context, etc. Call markers play the role of calls
5170 -- and provide a uniform foundation for ABE processing.
5172 return Nkind (N) = N_Call_Marker;
5173 end Is_Suitable_Call;
5175 -------------------------------
5176 -- Is_Suitable_Instantiation --
5177 -------------------------------
5179 function Is_Suitable_Instantiation (N : Node_Id) return Boolean is
5180 Orig_N : constant Node_Id := Original_Node (N);
5181 -- Use the original node in case an instantiation library unit is
5182 -- rewritten as a package or subprogram.
5185 -- To qualify, the instantiation must come from source
5188 Comes_From_Source (Orig_N)
5189 and then Nkind (Orig_N) in N_Generic_Instantiation;
5190 end Is_Suitable_Instantiation;
5192 --------------------------
5193 -- Is_Suitable_Scenario --
5194 --------------------------
5196 function Is_Suitable_Scenario (N : Node_Id) return Boolean is
5199 Is_Suitable_Access (N)
5200 or else Is_Suitable_Call (N)
5201 or else Is_Suitable_Instantiation (N)
5202 or else Is_Suitable_Variable_Assignment (N)
5203 or else Is_Suitable_Variable_Read (N);
5204 end Is_Suitable_Scenario;
5206 -------------------------------------
5207 -- Is_Suitable_Variable_Assignment --
5208 -------------------------------------
5210 function Is_Suitable_Variable_Assignment (N : Node_Id) return Boolean is
5212 N_Unit_Id : Entity_Id;
5217 Var_Unit_Id : Entity_Id;
5220 -- This scenario is relevant only when the static model is in effect
5221 -- because it is graph-dependent and does not involve any run-time
5222 -- checks. Allowing it in the dynamic model would create confusing
5225 if not Static_Elaboration_Checks then
5228 -- Nothing to do when the scenario is not an assignment
5230 elsif Nkind (N) /= N_Assignment_Statement then
5233 -- Nothing to do for internally-generated assignments because they are
5234 -- assumed to be ABE safe.
5236 elsif not Comes_From_Source (N) then
5239 -- Assignments are ignored in GNAT mode on the assumption that they are
5240 -- ABE-safe. This behaviour parallels that of the old ABE mechanism.
5242 elsif GNAT_Mode then
5246 Nam := Extract_Assignment_Name (N);
5248 -- Sanitize the left hand side of the assignment
5250 if not Is_Entity_Name (Nam) then
5253 elsif No (Entity (Nam)) then
5257 Var_Id := Entity (Nam);
5259 -- Sanitize the variable
5261 if Var_Id = Any_Id then
5264 elsif Ekind (Var_Id) /= E_Variable then
5268 Var_Decl := Declaration_Node (Var_Id);
5270 if Nkind (Var_Decl) /= N_Object_Declaration then
5274 N_Unit_Id := Find_Top_Unit (N);
5275 N_Unit := Unit_Declaration_Node (N_Unit_Id);
5277 Var_Unit_Id := Find_Top_Unit (Var_Decl);
5278 Var_Unit := Unit_Declaration_Node (Var_Unit_Id);
5280 -- To qualify, the assignment must meet the following prerequisites:
5283 Comes_From_Source (Var_Id)
5285 -- The variable must be declared in the spec of compilation unit U
5287 and then Nkind (Var_Unit) = N_Package_Declaration
5289 -- Performance note: parent traversal
5291 and then Find_Enclosing_Level (Var_Decl) = Package_Spec
5293 -- The assignment must occur in the body of compilation unit U
5295 and then Nkind (N_Unit) = N_Package_Body
5296 and then Present (Corresponding_Body (Var_Unit))
5297 and then Corresponding_Body (Var_Unit) = N_Unit_Id;
5298 end Is_Suitable_Variable_Assignment;
5300 -------------------------------
5301 -- Is_Suitable_Variable_Read --
5302 -------------------------------
5304 function Is_Suitable_Variable_Read (N : Node_Id) return Boolean is
5305 function In_Pragma (Nod : Node_Id) return Boolean;
5306 -- Determine whether arbitrary node Nod appears within a pragma
5308 function Is_Variable_Read (Ref : Node_Id) return Boolean;
5309 -- Determine whether variable reference Ref constitutes a read
5315 function In_Pragma (Nod : Node_Id) return Boolean is
5320 while Present (Par) loop
5321 if Nkind (Par) = N_Pragma then
5324 -- Prevent the search from going too far
5326 elsif Is_Body_Or_Package_Declaration (Par) then
5330 Par := Parent (Par);
5336 ----------------------
5337 -- Is_Variable_Read --
5338 ----------------------
5340 function Is_Variable_Read (Ref : Node_Id) return Boolean is
5341 function Is_Out_Actual (Call : Node_Id) return Boolean;
5342 -- Determine whether the corresponding formal of actual Ref which
5343 -- appears in call Call has mode OUT.
5349 function Is_Out_Actual (Call : Node_Id) return Boolean is
5351 Call_Attrs : Call_Attributes;
5353 Target_Id : Entity_Id;
5356 Extract_Call_Attributes
5358 Target_Id => Target_Id,
5359 Attrs => Call_Attrs);
5361 -- Inspect the actual and formal parameters, trying to find the
5362 -- corresponding formal for Ref.
5364 Actual := First_Actual (Call);
5365 Formal := First_Formal (Target_Id);
5366 while Present (Actual) and then Present (Formal) loop
5367 if Actual = Ref then
5368 return Ekind (Formal) = E_Out_Parameter;
5371 Next_Actual (Actual);
5372 Next_Formal (Formal);
5380 Context : constant Node_Id := Parent (Ref);
5382 -- Start of processing for Is_Variable_Read
5385 -- The majority of variable references are reads, and they can appear
5386 -- in a great number of contexts. To determine whether a reference is
5387 -- a read, it is more practical to find out whether it is a write.
5389 -- A reference is a write when it appears immediately on the left-
5390 -- hand side of an assignment.
5392 if Nkind (Context) = N_Assignment_Statement
5393 and then Name (Context) = Ref
5397 -- A reference is a write when it acts as an actual in a subprogram
5398 -- call and the corresponding formal has mode OUT.
5400 elsif Nkind_In (Context, N_Function_Call,
5401 N_Procedure_Call_Statement)
5402 and then Is_Out_Actual (Context)
5407 -- Any other reference is a read
5410 end Is_Variable_Read;
5417 -- Start of processing for Is_Suitable_Variable_Read
5420 -- This scenario is relevant only when the static model is in effect
5421 -- because it is graph-dependent and does not involve any run-time
5422 -- checks. Allowing it in the dynamic model would create confusing
5425 if not Static_Elaboration_Checks then
5428 -- Attributes and operator sumbols are not considered to be suitable
5429 -- references even though they are part of predicate Is_Entity_Name.
5431 elsif not Nkind_In (N, N_Expanded_Name, N_Identifier) then
5434 -- Nothing to do for internally-generated references because they are
5435 -- assumed to be ABE safe.
5437 elsif not Comes_From_Source (N) then
5441 -- Sanitize the reference
5443 Var_Id := Entity (N);
5448 elsif Var_Id = Any_Id then
5451 elsif Ekind (Var_Id) /= E_Variable then
5455 Prag := SPARK_Pragma (Var_Id);
5457 -- To qualify, the reference must meet the following prerequisites:
5460 Comes_From_Source (Var_Id)
5462 -- Both the variable and the reference must appear in SPARK_Mode On
5463 -- regions because this scenario falls under the SPARK rules.
5465 and then Present (Prag)
5466 and then Get_SPARK_Mode_From_Annotation (Prag) = On
5467 and then Is_SPARK_Mode_On_Node (N)
5469 -- The reference must denote a variable read
5471 and then Is_Variable_Read (N)
5473 -- The reference must not be considered when it appears in a pragma.
5474 -- If the pragma has run-time semantics, then the reference will be
5475 -- reconsidered once the pragma is expanded.
5477 -- Performance note: parent traversal
5479 and then not In_Pragma (N);
5480 end Is_Suitable_Variable_Read;
5486 function Is_Task_Entry (Id : Entity_Id) return Boolean is
5488 -- To qualify, the entity must denote an entry defined in a task type
5491 Is_Entry (Id) and then Is_Task_Type (Non_Private_View (Scope (Id)));
5494 ------------------------
5495 -- Is_Up_Level_Target --
5496 ------------------------
5498 function Is_Up_Level_Target (Target_Decl : Node_Id) return Boolean is
5499 Root : constant Node_Id := Root_Scenario;
5502 -- The root appears within the declaratons of a block statement, entry
5503 -- body, subprogram body, or task body ignoring enclosing packages. The
5504 -- root is always within the main unit. An up level target is a notion
5505 -- applicable only to the static model because scenarios are reached by
5506 -- means of graph traversal started from a fixed declarative or library
5509 -- Performance note: parent traversal
5511 if Static_Elaboration_Checks
5512 and then Find_Enclosing_Level (Root) = Declaration_Level
5514 -- The target is within the main unit. It acts as an up level target
5515 -- when it appears within a context which encloses the root.
5517 -- package body Main_Unit is
5518 -- function Func ...; -- target
5520 -- procedure Proc is
5521 -- X : ... := Func; -- root scenario
5523 if In_Extended_Main_Code_Unit (Target_Decl) then
5525 -- Performance note: parent traversal
5527 return not In_Same_Context (Root, Target_Decl, Nested_OK => True);
5529 -- Otherwise the target is external to the main unit which makes it
5530 -- an up level target.
5538 end Is_Up_Level_Target;
5540 -------------------------------
5541 -- Kill_Elaboration_Scenario --
5542 -------------------------------
5544 procedure Kill_Elaboration_Scenario (N : Node_Id) is
5546 -- Eliminate the scenario by suppressing the generation of conditional
5547 -- ABE checks or guaranteed ABE failures. Note that other diagnostics
5548 -- must be carried out ignoring the fact that the scenario is within
5551 if Is_Scenario (N) then
5552 Set_Is_Elaboration_Checks_OK_Node (N, False);
5554 end Kill_Elaboration_Scenario;
5556 ----------------------------------
5557 -- Meet_Elaboration_Requirement --
5558 ----------------------------------
5560 procedure Meet_Elaboration_Requirement
5562 Target_Id : Entity_Id;
5565 Main_Id : constant Entity_Id := Cunit_Entity (Main_Unit);
5566 Unit_Id : constant Entity_Id := Find_Top_Unit (Target_Id);
5568 function Find_Preelaboration_Pragma
5569 (Prag_Nam : Name_Id) return Node_Id;
5570 pragma Inline (Find_Preelaboration_Pragma);
5571 -- Traverse the visible declarations of unit Unit_Id and locate a source
5572 -- preelaboration-related pragma with name Prag_Nam.
5574 procedure Info_Requirement_Met (Prag : Node_Id);
5575 pragma Inline (Info_Requirement_Met);
5576 -- Output information concerning pragma Prag which meets requirement
5579 procedure Info_Scenario;
5580 pragma Inline (Info_Scenario);
5581 -- Output information concerning scenario N
5583 --------------------------------
5584 -- Find_Preelaboration_Pragma --
5585 --------------------------------
5587 function Find_Preelaboration_Pragma
5588 (Prag_Nam : Name_Id) return Node_Id
5590 Spec : constant Node_Id := Parent (Unit_Id);
5594 -- A preelaboration-related pragma comes from source and appears at
5595 -- the top of the visible declarations of a package.
5597 if Nkind (Spec) = N_Package_Specification then
5598 Decl := First (Visible_Declarations (Spec));
5599 while Present (Decl) loop
5600 if Comes_From_Source (Decl) then
5601 if Nkind (Decl) = N_Pragma
5602 and then Pragma_Name (Decl) = Prag_Nam
5606 -- Otherwise the construct terminates the region where the
5607 -- preelabortion-related pragma may appear.
5619 end Find_Preelaboration_Pragma;
5621 --------------------------
5622 -- Info_Requirement_Met --
5623 --------------------------
5625 procedure Info_Requirement_Met (Prag : Node_Id) is
5627 pragma Assert (Present (Prag));
5629 Error_Msg_Name_1 := Req_Nam;
5630 Error_Msg_Sloc := Sloc (Prag);
5632 ("\\% requirement for unit & met by pragma #", N, Unit_Id);
5633 end Info_Requirement_Met;
5639 procedure Info_Scenario is
5641 if Is_Suitable_Call (N) then
5644 Target_Id => Target_Id,
5648 elsif Is_Suitable_Instantiation (N) then
5651 Gen_Id => Target_Id,
5655 elsif Is_Suitable_Variable_Read (N) then
5658 Var_Id => Target_Id,
5662 -- No other scenario may impose a requirement on the context of the
5666 pragma Assert (False);
5673 Elab_Attrs : Elaboration_Attributes;
5677 -- Start of processing for Meet_Elaboration_Requirement
5680 pragma Assert (Nam_In (Req_Nam, Name_Elaborate, Name_Elaborate_All));
5682 -- Assume that the requirement has not been met
5686 -- Elaboration requirements are verified only when the static model is
5687 -- in effect because this diagnostic is graph-dependent.
5689 if not Static_Elaboration_Checks then
5692 -- If the target is within the main unit, either at the source level or
5693 -- through an instantiation, then there is no real requirement to meet
5694 -- because the main unit cannot force its own elaboration by means of an
5695 -- Elaborate[_All] pragma. Treat this case as valid coverage.
5697 elsif In_Extended_Main_Code_Unit (Target_Id) then
5700 -- Otherwise the target resides in an external unit
5702 -- The requirement is met when the target comes from an internal unit
5703 -- because such a unit is elaborated prior to a non-internal unit.
5705 elsif In_Internal_Unit (Unit_Id)
5706 and then not In_Internal_Unit (Main_Id)
5710 -- The requirement is met when the target comes from a preelaborated
5711 -- unit. This portion must parallel predicate Is_Preelaborated_Unit.
5713 elsif Is_Preelaborated_Unit (Unit_Id) then
5716 -- Output extra information when switch -gnatel (info messages on
5717 -- implicit Elaborate[_All] pragmas.
5719 if Elab_Info_Messages then
5720 if Is_Preelaborated (Unit_Id) then
5721 Elab_Nam := Name_Preelaborate;
5723 elsif Is_Pure (Unit_Id) then
5724 Elab_Nam := Name_Pure;
5726 elsif Is_Remote_Call_Interface (Unit_Id) then
5727 Elab_Nam := Name_Remote_Call_Interface;
5729 elsif Is_Remote_Types (Unit_Id) then
5730 Elab_Nam := Name_Remote_Types;
5733 pragma Assert (Is_Shared_Passive (Unit_Id));
5734 Elab_Nam := Name_Shared_Passive;
5737 Info_Requirement_Met (Find_Preelaboration_Pragma (Elab_Nam));
5740 -- Determine whether the context of the main unit has a pragma strong
5741 -- enough to meet the requirement.
5744 Elab_Attrs := Elaboration_Context.Get (Unit_Id);
5746 -- The pragma must be either Elaborate_All or be as strong as the
5749 if Present (Elab_Attrs.Source_Pragma)
5750 and then Nam_In (Pragma_Name (Elab_Attrs.Source_Pragma),
5756 -- Output extra information when switch -gnatel (info messages on
5757 -- implicit Elaborate[_All] pragmas.
5759 if Elab_Info_Messages then
5760 Info_Requirement_Met (Elab_Attrs.Source_Pragma);
5765 -- The requirement was not met by the context of the main unit, issue an
5771 Error_Msg_Name_1 := Req_Nam;
5772 Error_Msg_Node_2 := Unit_Id;
5773 Error_Msg_NE ("\\unit & requires pragma % for &", N, Main_Id);
5775 Output_Active_Scenarios (N);
5777 end Meet_Elaboration_Requirement;
5779 ----------------------
5780 -- Non_Private_View --
5781 ----------------------
5783 function Non_Private_View (Typ : Entity_Id) return Entity_Id is
5789 if Is_Private_Type (Result) and then Present (Full_View (Result)) then
5790 Result := Full_View (Result);
5794 end Non_Private_View;
5796 -----------------------------
5797 -- Output_Active_Scenarios --
5798 -----------------------------
5800 procedure Output_Active_Scenarios (Error_Nod : Node_Id) is
5801 procedure Output_Access (N : Node_Id);
5802 -- Emit a specific diagnostic message for 'Access denote by N
5804 procedure Output_Activation_Call (N : Node_Id);
5805 -- Emit a specific diagnostic message for task activation N
5807 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id);
5808 -- Emit a specific diagnostic message for call N which invokes target
5811 procedure Output_Header;
5812 -- Emit a specific diagnostic message for the unit of the root scenario
5814 procedure Output_Instantiation (N : Node_Id);
5815 -- Emit a specific diagnostic message for instantiation N
5817 procedure Output_Variable_Assignment (N : Node_Id);
5818 -- Emit a specific diagnostic message for assignment statement N
5820 procedure Output_Variable_Read (N : Node_Id);
5821 -- Emit a specific diagnostic message for reference N which reads a
5828 procedure Output_Access (N : Node_Id) is
5829 Subp_Id : constant Entity_Id := Entity (Prefix (N));
5832 Error_Msg_Name_1 := Attribute_Name (N);
5833 Error_Msg_Sloc := Sloc (N);
5834 Error_Msg_NE ("\\ % of & taken #", Error_Nod, Subp_Id);
5837 ----------------------------
5838 -- Output_Activation_Call --
5839 ----------------------------
5841 procedure Output_Activation_Call (N : Node_Id) is
5842 function Find_Activator (Call : Node_Id) return Entity_Id;
5843 -- Find the nearest enclosing construct which houses call Call
5845 --------------------
5846 -- Find_Activator --
5847 --------------------
5849 function Find_Activator (Call : Node_Id) return Entity_Id is
5853 -- Climb the parent chain looking for a package [body] or a
5854 -- construct with a statement sequence.
5856 Par := Parent (Call);
5857 while Present (Par) loop
5858 if Nkind_In (Par, N_Package_Body, N_Package_Declaration) then
5859 return Defining_Entity (Par);
5861 elsif Nkind (Par) = N_Handled_Sequence_Of_Statements then
5862 return Defining_Entity (Parent (Par));
5865 Par := Parent (Par);
5873 Activator : constant Entity_Id := Find_Activator (N);
5875 -- Start of processing for Output_Activation_Call
5878 pragma Assert (Present (Activator));
5880 Error_Msg_NE ("\\ local tasks of & activated", Error_Nod, Activator);
5881 end Output_Activation_Call;
5887 procedure Output_Call (N : Node_Id; Target_Id : Entity_Id) is
5888 procedure Output_Accept_Alternative;
5889 pragma Inline (Output_Accept_Alternative);
5890 -- Emit a specific diagnostic message concerning an accept
5893 procedure Output_Call (Kind : String);
5894 pragma Inline (Output_Call);
5895 -- Emit a specific diagnostic message concerning a call of kind Kind
5897 procedure Output_Type_Actions (Action : String);
5898 pragma Inline (Output_Type_Actions);
5899 -- Emit a specific diagnostic message concerning action Action of a
5902 procedure Output_Verification_Call
5906 pragma Inline (Output_Verification_Call);
5907 -- Emit a specific diagnostic message concerning the verification of
5908 -- predicate Pred applied to related entity Id with kind Id_Kind.
5910 -------------------------------
5911 -- Output_Accept_Alternative --
5912 -------------------------------
5914 procedure Output_Accept_Alternative is
5915 Entry_Id : constant Entity_Id := Receiving_Entry (Target_Id);
5918 pragma Assert (Present (Entry_Id));
5920 Error_Msg_NE ("\\ entry & selected #", Error_Nod, Entry_Id);
5921 end Output_Accept_Alternative;
5927 procedure Output_Call (Kind : String) is
5929 Error_Msg_NE ("\\ " & Kind & " & called #", Error_Nod, Target_Id);
5932 -------------------------
5933 -- Output_Type_Actions --
5934 -------------------------
5936 procedure Output_Type_Actions (Action : String) is
5937 Typ : constant Entity_Id := First_Formal_Type (Target_Id);
5940 pragma Assert (Present (Typ));
5943 ("\\ " & Action & " actions for type & #", Error_Nod, Typ);
5944 end Output_Type_Actions;
5946 ------------------------------
5947 -- Output_Verification_Call --
5948 ------------------------------
5950 procedure Output_Verification_Call
5956 pragma Assert (Present (Id));
5959 ("\\ " & Pred & " of " & Id_Kind & " & verified #",
5961 end Output_Verification_Call;
5963 -- Start of processing for Output_Call
5966 Error_Msg_Sloc := Sloc (N);
5968 -- Accept alternative
5970 if Is_Accept_Alternative_Proc (Target_Id) then
5971 Output_Accept_Alternative;
5975 elsif Is_TSS (Target_Id, TSS_Deep_Adjust) then
5976 Output_Type_Actions ("adjustment");
5978 -- Default_Initial_Condition
5980 elsif Is_Default_Initial_Condition_Proc (Target_Id) then
5981 Output_Verification_Call
5982 (Pred => "Default_Initial_Condition",
5983 Id => First_Formal_Type (Target_Id),
5988 elsif Is_Protected_Entry (Target_Id) then
5989 Output_Call ("entry");
5991 -- Task entry calls are never processed because the entry being
5992 -- invoked does not have a corresponding "body", it has a select. A
5993 -- task entry call appears in the stack of active scenarios for the
5994 -- sole purpose of checking No_Entry_Calls_In_Elaboration_Code and
5997 elsif Is_Task_Entry (Target_Id) then
6002 elsif Is_TSS (Target_Id, TSS_Deep_Finalize) then
6003 Output_Type_Actions ("finalization");
6005 -- Calls to _Finalizer procedures must not appear in the output
6006 -- because this creates confusing noise.
6008 elsif Is_Finalizer_Proc (Target_Id) then
6011 -- Initial_Condition
6013 elsif Is_Initial_Condition_Proc (Target_Id) then
6014 Output_Verification_Call
6015 (Pred => "Initial_Condition",
6016 Id => Find_Enclosing_Scope (N),
6017 Id_Kind => "package");
6021 elsif Is_Init_Proc (Target_Id)
6022 or else Is_TSS (Target_Id, TSS_Deep_Initialize)
6024 Output_Type_Actions ("initialization");
6028 elsif Is_Invariant_Proc (Target_Id) then
6029 Output_Verification_Call
6030 (Pred => "invariants",
6031 Id => First_Formal_Type (Target_Id),
6034 -- Partial invariant calls must not appear in the output because this
6035 -- creates confusing noise. Note that a partial invariant is always
6036 -- invoked by the "full" invariant which is already placed on the
6039 elsif Is_Partial_Invariant_Proc (Target_Id) then
6044 elsif Is_Postconditions_Proc (Target_Id) then
6045 Output_Verification_Call
6046 (Pred => "postconditions",
6047 Id => Find_Enclosing_Scope (N),
6048 Id_Kind => "subprogram");
6050 -- Subprograms must come last because some of the previous cases fall
6051 -- under this category.
6053 elsif Ekind (Target_Id) = E_Function then
6054 Output_Call ("function");
6056 elsif Ekind (Target_Id) = E_Procedure then
6057 Output_Call ("procedure");
6060 pragma Assert (False);
6069 procedure Output_Header is
6070 Unit_Id : constant Entity_Id := Find_Top_Unit (Root_Scenario);
6073 if Ekind (Unit_Id) = E_Package then
6074 Error_Msg_NE ("\\ spec of unit & elaborated", Error_Nod, Unit_Id);
6076 elsif Ekind (Unit_Id) = E_Package_Body then
6077 Error_Msg_NE ("\\ body of unit & elaborated", Error_Nod, Unit_Id);
6080 Error_Msg_NE ("\\ in body of unit &", Error_Nod, Unit_Id);
6084 --------------------------
6085 -- Output_Instantiation --
6086 --------------------------
6088 procedure Output_Instantiation (N : Node_Id) is
6089 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String);
6090 pragma Inline (Output_Instantiation);
6091 -- Emit a specific diagnostic message concerning an instantiation of
6092 -- generic unit Gen_Id. Kind denotes the kind of the instantiation.
6094 --------------------------
6095 -- Output_Instantiation --
6096 --------------------------
6098 procedure Output_Instantiation (Gen_Id : Entity_Id; Kind : String) is
6101 ("\\ " & Kind & " & instantiated as & #", Error_Nod, Gen_Id);
6102 end Output_Instantiation;
6107 Inst_Attrs : Instantiation_Attributes;
6108 Inst_Id : Entity_Id;
6111 -- Start of processing for Output_Instantiation
6114 Extract_Instantiation_Attributes
6119 Attrs => Inst_Attrs);
6121 Error_Msg_Node_2 := Inst_Id;
6122 Error_Msg_Sloc := Sloc (Inst);
6124 if Nkind (Inst) = N_Function_Instantiation then
6125 Output_Instantiation (Gen_Id, "function");
6127 elsif Nkind (Inst) = N_Package_Instantiation then
6128 Output_Instantiation (Gen_Id, "package");
6130 elsif Nkind (Inst) = N_Procedure_Instantiation then
6131 Output_Instantiation (Gen_Id, "procedure");
6134 pragma Assert (False);
6137 end Output_Instantiation;
6139 --------------------------------
6140 -- Output_Variable_Assignment --
6141 --------------------------------
6143 procedure Output_Variable_Assignment (N : Node_Id) is
6144 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (N));
6147 Error_Msg_Sloc := Sloc (N);
6148 Error_Msg_NE ("\\ variable & assigned #", Error_Nod, Var_Id);
6149 end Output_Variable_Assignment;
6151 --------------------------
6152 -- Output_Variable_Read --
6153 --------------------------
6155 procedure Output_Variable_Read (N : Node_Id) is
6156 Dummy : Variable_Attributes;
6160 Extract_Variable_Reference_Attributes
6165 Error_Msg_Sloc := Sloc (N);
6166 Error_Msg_NE ("\\ variable & read #", Error_Nod, Var_Id);
6167 end Output_Variable_Read;
6171 package Stack renames Scenario_Stack;
6173 Dummy : Call_Attributes;
6176 Target_Id : Entity_Id;
6178 -- Start of processing for Output_Active_Scenarios
6181 -- Active scenarios are emitted only when the static model is in effect
6182 -- because there is an inherent order by which all these scenarios were
6183 -- reached from the declaration or library level.
6185 if not Static_Elaboration_Checks then
6191 for Index in Stack.First .. Stack.Last loop
6192 N := Stack.Table (Index);
6201 if Nkind (N) = N_Attribute_Reference then
6206 elsif Is_Suitable_Call (N) then
6207 Extract_Call_Attributes
6209 Target_Id => Target_Id,
6212 if Is_Activation_Proc (Target_Id) then
6213 Output_Activation_Call (N);
6215 Output_Call (N, Target_Id);
6220 elsif Is_Suitable_Instantiation (N) then
6221 Output_Instantiation (N);
6223 -- Variable assignments
6225 elsif Nkind (N) = N_Assignment_Statement then
6226 Output_Variable_Assignment (N);
6230 elsif Is_Suitable_Variable_Read (N) then
6231 Output_Variable_Read (N);
6234 pragma Assert (False);
6238 end Output_Active_Scenarios;
6240 -------------------------
6241 -- Pop_Active_Scenario --
6242 -------------------------
6244 procedure Pop_Active_Scenario (N : Node_Id) is
6245 Top : Node_Id renames Scenario_Stack.Table (Scenario_Stack.Last);
6248 pragma Assert (Top = N);
6249 Scenario_Stack.Decrement_Last;
6250 end Pop_Active_Scenario;
6252 --------------------
6253 -- Process_Access --
6254 --------------------
6256 procedure Process_Access (Attr : Node_Id; In_Task_Body : Boolean) is
6257 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id;
6258 pragma Inline (Build_Access_Marker);
6259 -- Create a suitable call marker which invokes target Target_Id
6261 -------------------------
6262 -- Build_Access_Marker --
6263 -------------------------
6265 function Build_Access_Marker (Target_Id : Entity_Id) return Node_Id is
6269 Marker := Make_Call_Marker (Sloc (Attr));
6271 -- Inherit relevant attributes from the attribute
6273 -- Performance note: parent traversal
6275 Set_Target (Marker, Target_Id);
6276 Set_Is_Declaration_Level_Node
6277 (Marker, Find_Enclosing_Level (Attr) = Declaration_Level);
6278 Set_Is_Dispatching_Call
6280 Set_Is_Elaboration_Checks_OK_Node
6281 (Marker, Is_Elaboration_Checks_OK_Node (Attr));
6283 (Marker, Comes_From_Source (Attr));
6284 Set_Is_SPARK_Mode_On_Node
6285 (Marker, Is_SPARK_Mode_On_Node (Attr));
6287 -- Partially insert the call marker into the tree by setting its
6290 Set_Parent (Marker, Attr);
6293 end Build_Access_Marker;
6297 Root : constant Node_Id := Root_Scenario;
6298 Target_Id : constant Entity_Id := Entity (Prefix (Attr));
6300 Target_Attrs : Target_Attributes;
6302 -- Start of processing for Process_Access
6305 -- Output relevant information when switch -gnatel (info messages on
6306 -- implicit Elaborate[_All] pragmas) is in effect.
6308 if Elab_Info_Messages then
6310 ("info: access to & during elaboration", Attr, Target_Id);
6313 Extract_Target_Attributes
6314 (Target_Id => Target_Id,
6315 Attrs => Target_Attrs);
6317 -- Both the attribute and the corresponding body are in the same unit.
6318 -- The corresponding body must appear prior to the root scenario which
6319 -- started the recursive search. If this is not the case, then there is
6320 -- a potential ABE if the access value is used to call the subprogram.
6321 -- Emit a warning only when switch -gnatw.f (warnings on suspucious
6322 -- 'Access) is in effect.
6324 if Warn_On_Elab_Access
6325 and then Present (Target_Attrs.Body_Decl)
6326 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl)
6327 and then Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl)
6329 Error_Msg_Name_1 := Attribute_Name (Attr);
6330 Error_Msg_NE ("??% attribute of & before body seen", Attr, Target_Id);
6331 Error_Msg_N ("\possible Program_Error on later references", Attr);
6333 Output_Active_Scenarios (Attr);
6336 -- Treat the attribute as an immediate invocation of the target when
6337 -- switch -gnatd.o (conservative elaboration order for indirect calls)
6338 -- is in effect. Note that the prior elaboration of the unit containing
6339 -- the target is ensured processing the corresponding call marker.
6341 if Debug_Flag_Dot_O then
6343 (N => Build_Access_Marker (Target_Id),
6344 In_Task_Body => In_Task_Body);
6346 -- Otherwise ensure that the unit with the corresponding body is
6347 -- elaborated prior to the main unit.
6350 Ensure_Prior_Elaboration
6352 Unit_Id => Target_Attrs.Unit_Id,
6353 In_Task_Body => In_Task_Body);
6357 -----------------------------
6358 -- Process_Activation_Call --
6359 -----------------------------
6361 procedure Process_Activation_Call
6363 Call_Attrs : Call_Attributes;
6364 In_Task_Body : Boolean)
6366 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id);
6367 -- Perform ABE checks and diagnostics for object Obj_Id with type Typ.
6368 -- Typ may be a task type or a composite type with at least one task
6371 procedure Process_Task_Objects (List : List_Id);
6372 -- Perform ABE checks and diagnostics for all task objects found in
6375 -------------------------
6376 -- Process_Task_Object --
6377 -------------------------
6379 procedure Process_Task_Object (Obj_Id : Entity_Id; Typ : Entity_Id) is
6380 Base_Typ : constant Entity_Id := Base_Type (Typ);
6382 Comp_Id : Entity_Id;
6383 Task_Attrs : Task_Attributes;
6386 if Is_Task_Type (Typ) then
6387 Extract_Task_Attributes
6389 Attrs => Task_Attrs);
6391 Process_Single_Activation
6393 Call_Attrs => Call_Attrs,
6395 Task_Attrs => Task_Attrs,
6396 In_Task_Body => In_Task_Body);
6398 -- Examine the component type when the object is an array
6400 elsif Is_Array_Type (Typ) and then Has_Task (Base_Typ) then
6401 Process_Task_Object (Obj_Id, Component_Type (Typ));
6403 -- Examine individual component types when the object is a record
6405 elsif Is_Record_Type (Typ) and then Has_Task (Base_Typ) then
6406 Comp_Id := First_Component (Typ);
6407 while Present (Comp_Id) loop
6408 Process_Task_Object (Obj_Id, Etype (Comp_Id));
6409 Next_Component (Comp_Id);
6412 end Process_Task_Object;
6414 --------------------------
6415 -- Process_Task_Objects --
6416 --------------------------
6418 procedure Process_Task_Objects (List : List_Id) is
6420 Item_Id : Entity_Id;
6421 Item_Typ : Entity_Id;
6424 -- Examine the contents of the list looking for an object declaration
6425 -- of a task type or one that contains a task within.
6427 Item := First (List);
6428 while Present (Item) loop
6429 if Nkind (Item) = N_Object_Declaration then
6430 Item_Id := Defining_Entity (Item);
6431 Item_Typ := Etype (Item_Id);
6433 if Has_Task (Item_Typ) then
6434 Process_Task_Object (Item_Id, Item_Typ);
6440 end Process_Task_Objects;
6447 -- Start of processing for Process_Activation_Call
6450 -- Nothing to do when the activation is a guaranteed ABE
6452 if Is_Known_Guaranteed_ABE (Call) then
6456 -- Find the proper context of the activation call where all task objects
6457 -- being activated are declared. This is usually the immediate parent of
6460 Context := Parent (Call);
6462 -- In the case of package bodies, the activation call is in the handled
6463 -- sequence of statements, but the task objects are in the declaration
6464 -- list of the body.
6466 if Nkind (Context) = N_Handled_Sequence_Of_Statements
6467 and then Nkind (Parent (Context)) = N_Package_Body
6469 Context := Parent (Context);
6472 -- Process all task objects defined in both the spec and body when the
6473 -- activation call precedes the "begin" of a package body.
6475 if Nkind (Context) = N_Package_Body then
6478 (Unit_Declaration_Node (Corresponding_Spec (Context)));
6480 Process_Task_Objects (Visible_Declarations (Spec));
6481 Process_Task_Objects (Private_Declarations (Spec));
6482 Process_Task_Objects (Declarations (Context));
6484 -- Process all task objects defined in the spec when the activation call
6485 -- appears at the end of a package spec.
6487 elsif Nkind (Context) = N_Package_Specification then
6488 Process_Task_Objects (Visible_Declarations (Context));
6489 Process_Task_Objects (Private_Declarations (Context));
6491 -- Otherwise the context of the activation is some construct with a
6492 -- declarative part. Note that the corresponding record type of a task
6493 -- type is controlled. Because of this, the finalization machinery must
6494 -- relocate the task object to the handled statements of the construct
6495 -- to perform proper finalization in case of an exception. Examine the
6496 -- statements of the construct rather than the declarations.
6499 pragma Assert (Nkind (Context) = N_Handled_Sequence_Of_Statements);
6501 Process_Task_Objects (Statements (Context));
6503 end Process_Activation_Call;
6505 ---------------------------------------------
6506 -- Process_Activation_Conditional_ABE_Impl --
6507 ---------------------------------------------
6509 procedure Process_Activation_Conditional_ABE_Impl
6511 Call_Attrs : Call_Attributes;
6513 Task_Attrs : Task_Attributes;
6514 In_Task_Body : Boolean)
6516 Check_OK : constant Boolean :=
6517 not Is_Ignored_Ghost_Entity (Obj_Id)
6518 and then not Task_Attrs.Ghost_Mode_Ignore
6519 and then Is_Elaboration_Checks_OK_Id (Obj_Id)
6520 and then Task_Attrs.Elab_Checks_OK;
6521 -- A run-time ABE check may be installed only when the object and the
6522 -- task type have active elaboration checks, and both are not ignored
6523 -- Ghost constructs.
6525 Root : constant Node_Id := Root_Scenario;
6528 -- Output relevant information when switch -gnatel (info messages on
6529 -- implicit Elaborate[_All] pragmas) is in effect.
6531 if Elab_Info_Messages then
6533 ("info: activation of & during elaboration", Call, Obj_Id);
6536 -- Nothing to do when the activation is a guaranteed ABE
6538 if Is_Known_Guaranteed_ABE (Call) then
6541 -- Nothing to do when the root scenario appears at the declaration
6542 -- level and the task is in the same unit, but outside this context.
6544 -- task type Task_Typ; -- task declaration
6546 -- procedure Proc is
6547 -- function A ... is
6549 -- if Some_Condition then
6553 -- <activation call> -- activation site
6558 -- X : ... := A; -- root scenario
6561 -- task body Task_Typ is
6565 -- In the example above, the context of X is the declarative list of
6566 -- Proc. The "elaboration" of X may reach the activation of T whose body
6567 -- is defined outside of X's context. The task body is relevant only
6568 -- when Proc is invoked, but this happens only in "normal" elaboration,
6569 -- therefore the task body must not be considered if this is not the
6572 -- Performance note: parent traversal
6574 elsif Is_Up_Level_Target (Task_Attrs.Task_Decl) then
6577 -- Nothing to do when the activation is ABE-safe
6581 -- task type Task_Typ;
6584 -- package body Gen is
6585 -- task body Task_Typ is
6592 -- procedure Main is
6593 -- package Nested is
6597 -- package body Nested is
6598 -- package Inst is new Gen;
6599 -- T : Inst.Task_Typ;
6601 -- <activation call> -- safe activation
6605 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then
6607 -- Note that the task body must still be examined for any nested
6612 -- The activation call and the task body are both in the main unit
6614 elsif Present (Task_Attrs.Body_Decl)
6615 and then In_Extended_Main_Code_Unit (Task_Attrs.Body_Decl)
6617 -- If the root scenario appears prior to the task body, then this is
6618 -- a possible ABE with respect to the root scenario.
6620 -- task type Task_Typ;
6622 -- function A ... is
6624 -- if Some_Condition then
6630 -- package body Pack is
6633 -- <activation call> -- activation of T
6638 -- X : ... := A; -- root scenario
6640 -- task body Task_Typ is -- task body
6644 -- Y : ... := A; -- root scenario
6646 -- IMPORTANT: The activation of T is a possible ABE for X, but
6647 -- not for Y. Intalling an unconditional ABE raise prior to the
6648 -- activation call would be wrong as it will fail for Y as well
6649 -- but in Y's case the activation of T is never an ABE.
6651 if Earlier_In_Extended_Unit (Root, Task_Attrs.Body_Decl) then
6653 -- ABE diagnostics are emitted only in the static model because
6654 -- there is a well-defined order to visiting scenarios. Without
6655 -- this order diagnostics appear jumbled and result in unwanted
6658 if Static_Elaboration_Checks then
6659 Error_Msg_Sloc := Sloc (Call);
6661 ("??task & will be activated # before elaboration of its "
6664 ("\Program_Error may be raised at run time", Obj_Id);
6666 Output_Active_Scenarios (Obj_Id);
6669 -- Install a conditional run-time ABE check to verify that the
6670 -- task body has been elaborated prior to the activation call.
6676 Target_Id => Task_Attrs.Spec_Id,
6677 Target_Decl => Task_Attrs.Task_Decl,
6678 Target_Body => Task_Attrs.Body_Decl);
6682 -- Otherwise the task body is not available in this compilation or it
6683 -- resides in an external unit. Install a run-time ABE check to verify
6684 -- that the task body has been elaborated prior to the activation call
6685 -- when the dynamic model is in effect.
6687 elsif Dynamic_Elaboration_Checks and then Check_OK then
6691 Id => Task_Attrs.Unit_Id);
6694 -- Both the activation call and task type are subject to SPARK_Mode
6695 -- On, this triggers the SPARK rules for task activation. Compared to
6696 -- calls and instantiations, task activation in SPARK does not require
6697 -- the presence of Elaborate[_All] pragmas in case the task type is
6698 -- defined outside the main unit. This is because SPARK utilizes a
6699 -- special policy which activates all tasks after the main unit has
6700 -- finished its elaboration.
6702 if Call_Attrs.SPARK_Mode_On and Task_Attrs.SPARK_Mode_On then
6705 -- Otherwise the Ada rules are in effect. Ensure that the unit with the
6706 -- task body is elaborated prior to the main unit.
6709 Ensure_Prior_Elaboration
6711 Unit_Id => Task_Attrs.Unit_Id,
6712 In_Task_Body => In_Task_Body);
6715 Traverse_Body (Task_Attrs.Body_Decl, In_Task_Body => True);
6716 end Process_Activation_Conditional_ABE_Impl;
6718 procedure Process_Activation_Conditional_ABE is
6719 new Process_Activation_Call (Process_Activation_Conditional_ABE_Impl);
6721 --------------------------------------------
6722 -- Process_Activation_Guaranteed_ABE_Impl --
6723 --------------------------------------------
6725 procedure Process_Activation_Guaranteed_ABE_Impl
6727 Call_Attrs : Call_Attributes;
6729 Task_Attrs : Task_Attributes;
6730 In_Task_Body : Boolean)
6732 pragma Unreferenced (Call_Attrs);
6733 pragma Unreferenced (In_Task_Body);
6735 Check_OK : constant Boolean :=
6736 not Is_Ignored_Ghost_Entity (Obj_Id)
6737 and then not Task_Attrs.Ghost_Mode_Ignore
6738 and then Is_Elaboration_Checks_OK_Id (Obj_Id)
6739 and then Task_Attrs.Elab_Checks_OK;
6740 -- A run-time ABE check may be installed only when the object and the
6741 -- task type have active elaboration checks, and both are not ignored
6742 -- Ghost constructs.
6745 -- Nothing to do when the root scenario appears at the declaration
6746 -- level and the task is in the same unit, but outside this context.
6748 -- task type Task_Typ; -- task declaration
6750 -- procedure Proc is
6751 -- function A ... is
6753 -- if Some_Condition then
6757 -- <activation call> -- activation site
6762 -- X : ... := A; -- root scenario
6765 -- task body Task_Typ is
6769 -- In the example above, the context of X is the declarative list of
6770 -- Proc. The "elaboration" of X may reach the activation of T whose body
6771 -- is defined outside of X's context. The task body is relevant only
6772 -- when Proc is invoked, but this happens only in "normal" elaboration,
6773 -- therefore the task body must not be considered if this is not the
6776 -- Performance note: parent traversal
6778 if Is_Up_Level_Target (Task_Attrs.Task_Decl) then
6781 -- Nothing to do when the activation is ABE-safe
6785 -- task type Task_Typ;
6788 -- package body Gen is
6789 -- task body Task_Typ is
6796 -- procedure Main is
6797 -- package Nested is
6801 -- package body Nested is
6802 -- package Inst is new Gen;
6803 -- T : Inst.Task_Typ;
6805 -- <activation call> -- safe activation
6809 elsif Is_Safe_Activation (Call, Task_Attrs.Task_Decl) then
6812 -- An activation call leads to a guaranteed ABE when the activation
6813 -- call and the task appear within the same context ignoring library
6814 -- levels, and the body of the task has not been seen yet or appears
6815 -- after the activation call.
6817 -- procedure Guaranteed_ABE is
6818 -- task type Task_Typ;
6820 -- package Nested is
6824 -- package body Nested is
6827 -- <activation call> -- guaranteed ABE
6830 -- task body Task_Typ is
6835 -- Performance note: parent traversal
6837 elsif Is_Guaranteed_ABE
6839 Target_Decl => Task_Attrs.Task_Decl,
6840 Target_Body => Task_Attrs.Body_Decl)
6842 Error_Msg_Sloc := Sloc (Call);
6844 ("??task & will be activated # before elaboration of its body",
6846 Error_Msg_N ("\Program_Error will be raised at run time", Obj_Id);
6848 -- Mark the activation call as a guaranteed ABE
6850 Set_Is_Known_Guaranteed_ABE (Call);
6852 -- Install a run-time ABE failue because this activation call will
6853 -- always result in an ABE.
6861 end Process_Activation_Guaranteed_ABE_Impl;
6863 procedure Process_Activation_Guaranteed_ABE is
6864 new Process_Activation_Call (Process_Activation_Guaranteed_ABE_Impl);
6870 procedure Process_Call
6872 Call_Attrs : Call_Attributes;
6873 Target_Id : Entity_Id;
6874 In_Task_Body : Boolean)
6876 SPARK_Rules_On : Boolean;
6877 Target_Attrs : Target_Attributes;
6880 Extract_Target_Attributes
6881 (Target_Id => Target_Id,
6882 Attrs => Target_Attrs);
6884 -- The SPARK rules are in effect when both the call and target are
6885 -- subject to SPARK_Mode On.
6888 Call_Attrs.SPARK_Mode_On and Target_Attrs.SPARK_Mode_On;
6890 -- Output relevant information when switch -gnatel (info messages on
6891 -- implicit Elaborate[_All] pragmas) is in effect.
6893 if Elab_Info_Messages then
6896 Target_Id => Target_Id,
6898 In_SPARK => SPARK_Rules_On);
6901 -- Check whether the invocation of an entry clashes with an existing
6904 if Is_Protected_Entry (Target_Id) then
6905 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call);
6907 elsif Is_Task_Entry (Target_Id) then
6908 Check_Restriction (No_Entry_Calls_In_Elaboration_Code, Call);
6910 -- Task entry calls are never processed because the entry being
6911 -- invoked does not have a corresponding "body", it has a select.
6916 -- Nothing to do when the call is a guaranteed ABE
6918 if Is_Known_Guaranteed_ABE (Call) then
6921 -- Nothing to do when the root scenario appears at the declaration level
6922 -- and the target is in the same unit, but outside this context.
6924 -- function B ...; -- target declaration
6926 -- procedure Proc is
6927 -- function A ... is
6929 -- if Some_Condition then
6930 -- return B; -- call site
6934 -- X : ... := A; -- root scenario
6937 -- function B ... is
6941 -- In the example above, the context of X is the declarative region of
6942 -- Proc. The "elaboration" of X may eventually reach B which is defined
6943 -- outside of X's context. B is relevant only when Proc is invoked, but
6944 -- this happens only by means of "normal" elaboration, therefore B must
6945 -- not be considered if this is not the case.
6947 -- Performance note: parent traversal
6949 elsif Is_Up_Level_Target (Target_Attrs.Spec_Decl) then
6952 -- The SPARK rules are verified only when -gnatd.v (enforce SPARK
6953 -- elaboration rules in SPARK code) is in effect.
6955 elsif SPARK_Rules_On and Debug_Flag_Dot_V then
6958 Call_Attrs => Call_Attrs,
6959 Target_Id => Target_Id,
6960 Target_Attrs => Target_Attrs);
6962 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
6963 -- violate the SPARK rules.
6968 Call_Attrs => Call_Attrs,
6969 Target_Id => Target_Id,
6970 Target_Attrs => Target_Attrs,
6971 In_Task_Body => In_Task_Body);
6974 -- Inspect the target body (and barried function) for other suitable
6975 -- elaboration scenarios.
6977 Traverse_Body (Target_Attrs.Body_Barf, In_Task_Body);
6978 Traverse_Body (Target_Attrs.Body_Decl, In_Task_Body);
6981 ----------------------
6982 -- Process_Call_Ada --
6983 ----------------------
6985 procedure Process_Call_Ada
6987 Call_Attrs : Call_Attributes;
6988 Target_Id : Entity_Id;
6989 Target_Attrs : Target_Attributes;
6990 In_Task_Body : Boolean)
6992 function In_Initialization_Context (N : Node_Id) return Boolean;
6993 -- Determine whether arbitrary node N appears within a type init proc or
6994 -- primitive [Deep_]Initialize.
6996 -------------------------------
6997 -- In_Initialization_Context --
6998 -------------------------------
7000 function In_Initialization_Context (N : Node_Id) return Boolean is
7002 Spec_Id : Entity_Id;
7005 -- Climb the parent chain looking for initialization actions
7008 while Present (Par) loop
7010 -- A block may be part of the initialization actions of a default
7011 -- initialized object.
7013 if Nkind (Par) = N_Block_Statement
7014 and then Is_Initialization_Block (Par)
7018 -- A subprogram body may denote an initialization routine
7020 elsif Nkind (Par) = N_Subprogram_Body then
7021 Spec_Id := Unique_Defining_Entity (Par);
7023 -- The current subprogram body denotes a type init proc or
7024 -- primitive [Deep_]Initialize.
7026 if Is_Init_Proc (Spec_Id)
7027 or else Is_Controlled_Proc (Spec_Id, Name_Initialize)
7028 or else Is_TSS (Spec_Id, TSS_Deep_Initialize)
7033 -- Prevent the search from going too far
7035 elsif Is_Body_Or_Package_Declaration (Par) then
7039 Par := Parent (Par);
7043 end In_Initialization_Context;
7047 Check_OK : constant Boolean :=
7048 not Call_Attrs.Ghost_Mode_Ignore
7049 and then not Target_Attrs.Ghost_Mode_Ignore
7050 and then Call_Attrs.Elab_Checks_OK
7051 and then Target_Attrs.Elab_Checks_OK;
7052 -- A run-time ABE check may be installed only when both the call and the
7053 -- target have active elaboration checks, and both are not ignored Ghost
7056 -- Start of processing for Process_Call_Ada
7059 -- Nothing to do for an Ada dispatching call because there are no ABE
7060 -- diagnostics for either models. ABE checks for the dynamic model are
7061 -- handled by Install_Primitive_Elaboration_Check.
7063 if Call_Attrs.Is_Dispatching then
7066 -- Nothing to do when the call is ABE-safe
7069 -- function Gen ...;
7071 -- function Gen ... is
7077 -- procedure Main is
7078 -- function Inst is new Gen;
7079 -- X : ... := Inst; -- safe call
7082 elsif Is_Safe_Call (Call, Target_Attrs) then
7085 -- The call and the target body are both in the main unit
7087 elsif Present (Target_Attrs.Body_Decl)
7088 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl)
7090 Process_Call_Conditional_ABE
7092 Call_Attrs => Call_Attrs,
7093 Target_Id => Target_Id,
7094 Target_Attrs => Target_Attrs);
7096 -- Otherwise the target body is not available in this compilation or it
7097 -- resides in an external unit. Install a run-time ABE check to verify
7098 -- that the target body has been elaborated prior to the call site when
7099 -- the dynamic model is in effect.
7101 elsif Dynamic_Elaboration_Checks and then Check_OK then
7105 Id => Target_Attrs.Unit_Id);
7108 -- No implicit pragma Elaborate[_All] is generated when the call has
7109 -- elaboration checks suppressed. This behaviour parallels that of the
7110 -- old ABE mechanism.
7112 if not Call_Attrs.Elab_Checks_OK then
7115 -- No implicit pragma Elaborate[_All] is generated for finalization
7116 -- actions when primitive [Deep_]Finalize is not defined in the main
7117 -- unit and the call appears within some initialization actions. This
7118 -- behaviour parallels that of the old ABE mechanism.
7120 -- Performance note: parent traversal
7122 elsif (Is_Controlled_Proc (Target_Id, Name_Finalize)
7123 or else Is_TSS (Target_Id, TSS_Deep_Finalize))
7124 and then not In_Extended_Main_Code_Unit (Target_Attrs.Spec_Decl)
7125 and then In_Initialization_Context (Call)
7129 -- Otherwise ensure that the unit with the target body is elaborated
7130 -- prior to the main unit.
7133 Ensure_Prior_Elaboration
7135 Unit_Id => Target_Attrs.Unit_Id,
7136 In_Task_Body => In_Task_Body);
7138 end Process_Call_Ada;
7140 ----------------------------------
7141 -- Process_Call_Conditional_ABE --
7142 ----------------------------------
7144 procedure Process_Call_Conditional_ABE
7146 Call_Attrs : Call_Attributes;
7147 Target_Id : Entity_Id;
7148 Target_Attrs : Target_Attributes)
7150 Check_OK : constant Boolean :=
7151 not Call_Attrs.Ghost_Mode_Ignore
7152 and then not Target_Attrs.Ghost_Mode_Ignore
7153 and then Call_Attrs.Elab_Checks_OK
7154 and then Target_Attrs.Elab_Checks_OK;
7155 -- A run-time ABE check may be installed only when both the call and the
7156 -- target have active elaboration checks, and both are not ignored Ghost
7159 Root : constant Node_Id := Root_Scenario;
7162 -- If the root scenario appears prior to the target body, then this is a
7163 -- possible ABE with respect to the root scenario.
7167 -- function A ... is
7169 -- if Some_Condition then
7170 -- return B; -- call site
7174 -- X : ... := A; -- root scenario
7176 -- function B ... is -- target body
7180 -- Y : ... := A; -- root scenario
7182 -- IMPORTANT: The call to B from A is a possible ABE for X, but not for
7183 -- Y. Installing an unconditional ABE raise prior to the call to B would
7184 -- be wrong as it will fail for Y as well, but in Y's case the call to B
7187 if Earlier_In_Extended_Unit (Root, Target_Attrs.Body_Decl) then
7189 -- ABE diagnostics are emitted only in the static model because there
7190 -- is a well-defined order to visiting scenarios. Without this order
7191 -- diagnostics appear jumbled and result in unwanted noise.
7193 if Static_Elaboration_Checks then
7194 Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id);
7195 Error_Msg_N ("\Program_Error may be raised at run time", Call);
7197 Output_Active_Scenarios (Call);
7200 -- Install a conditional run-time ABE check to verify that the target
7201 -- body has been elaborated prior to the call.
7207 Target_Id => Target_Attrs.Spec_Id,
7208 Target_Decl => Target_Attrs.Spec_Decl,
7209 Target_Body => Target_Attrs.Body_Decl);
7212 end Process_Call_Conditional_ABE;
7214 ---------------------------------
7215 -- Process_Call_Guaranteed_ABE --
7216 ---------------------------------
7218 procedure Process_Call_Guaranteed_ABE
7220 Call_Attrs : Call_Attributes;
7221 Target_Id : Entity_Id)
7223 Target_Attrs : Target_Attributes;
7226 Extract_Target_Attributes
7227 (Target_Id => Target_Id,
7228 Attrs => Target_Attrs);
7230 -- Nothing to do when the root scenario appears at the declaration level
7231 -- and the target is in the same unit, but outside this context.
7233 -- function B ...; -- target declaration
7235 -- procedure Proc is
7236 -- function A ... is
7238 -- if Some_Condition then
7239 -- return B; -- call site
7243 -- X : ... := A; -- root scenario
7246 -- function B ... is
7250 -- In the example above, the context of X is the declarative region of
7251 -- Proc. The "elaboration" of X may eventually reach B which is defined
7252 -- outside of X's context. B is relevant only when Proc is invoked, but
7253 -- this happens only by means of "normal" elaboration, therefore B must
7254 -- not be considered if this is not the case.
7256 -- Performance note: parent traversal
7258 if Is_Up_Level_Target (Target_Attrs.Spec_Decl) then
7261 -- Nothing to do when the call is ABE-safe
7264 -- function Gen ...;
7266 -- function Gen ... is
7272 -- procedure Main is
7273 -- function Inst is new Gen;
7274 -- X : ... := Inst; -- safe call
7277 elsif Is_Safe_Call (Call, Target_Attrs) then
7280 -- A call leads to a guaranteed ABE when the call and the target appear
7281 -- within the same context ignoring library levels, and the body of the
7282 -- target has not been seen yet or appears after the call.
7284 -- procedure Guaranteed_ABE is
7285 -- function Func ...;
7287 -- package Nested is
7288 -- Obj : ... := Func; -- guaranteed ABE
7291 -- function Func ... is
7296 -- Performance note: parent traversal
7298 elsif Is_Guaranteed_ABE
7300 Target_Decl => Target_Attrs.Spec_Decl,
7301 Target_Body => Target_Attrs.Body_Decl)
7303 Error_Msg_NE ("??cannot call & before body seen", Call, Target_Id);
7304 Error_Msg_N ("\Program_Error will be raised at run time", Call);
7306 -- Mark the call as a guarnateed ABE
7308 Set_Is_Known_Guaranteed_ABE (Call);
7310 -- Install a run-time ABE failure because the call will always result
7311 -- in an ABE. The failure is installed when both the call and target
7312 -- have enabled elaboration checks, and both are not ignored Ghost
7315 if Call_Attrs.Elab_Checks_OK
7316 and then Target_Attrs.Elab_Checks_OK
7317 and then not Call_Attrs.Ghost_Mode_Ignore
7318 and then not Target_Attrs.Ghost_Mode_Ignore
7325 end Process_Call_Guaranteed_ABE;
7327 ------------------------
7328 -- Process_Call_SPARK --
7329 ------------------------
7331 procedure Process_Call_SPARK
7333 Call_Attrs : Call_Attributes;
7334 Target_Id : Entity_Id;
7335 Target_Attrs : Target_Attributes)
7338 -- A call to a source target or to a target which emulates Ada or SPARK
7339 -- semantics imposes an Elaborate_All requirement on the context of the
7340 -- main unit. Determine whether the context has a pragma strong enough
7341 -- to meet the requirement. The check is orthogonal to the ABE effects
7344 if Target_Attrs.From_Source
7345 or else Is_Ada_Semantic_Target (Target_Id)
7346 or else Is_SPARK_Semantic_Target (Target_Id)
7348 Meet_Elaboration_Requirement
7350 Target_Id => Target_Id,
7351 Req_Nam => Name_Elaborate_All);
7354 -- Nothing to do when the call is ABE-safe
7357 -- function Gen ...;
7359 -- function Gen ... is
7365 -- procedure Main is
7366 -- function Inst is new Gen;
7367 -- X : ... := Inst; -- safe call
7370 if Is_Safe_Call (Call, Target_Attrs) then
7373 -- The call and the target body are both in the main unit
7375 elsif Present (Target_Attrs.Body_Decl)
7376 and then In_Extended_Main_Code_Unit (Target_Attrs.Body_Decl)
7378 Process_Call_Conditional_ABE
7380 Call_Attrs => Call_Attrs,
7381 Target_Id => Target_Id,
7382 Target_Attrs => Target_Attrs);
7384 -- Otherwise the target body is not available in this compilation or it
7385 -- resides in an external unit. There is no need to guarantee the prior
7386 -- elaboration of the unit with the target body because either the main
7387 -- unit meets the Elaborate_All requirement imposed by the call, or the
7388 -- program is illegal.
7393 end Process_Call_SPARK;
7395 ----------------------------
7396 -- Process_Guaranteed_ABE --
7397 ----------------------------
7399 procedure Process_Guaranteed_ABE (N : Node_Id) is
7400 Call_Attrs : Call_Attributes;
7401 Target_Id : Entity_Id;
7404 -- Add the current scenario to the stack of active scenarios
7406 Push_Active_Scenario (N);
7408 -- Only calls, instantiations, and task activations may result in a
7411 if Is_Suitable_Call (N) then
7412 Extract_Call_Attributes
7414 Target_Id => Target_Id,
7415 Attrs => Call_Attrs);
7417 if Is_Activation_Proc (Target_Id) then
7418 Process_Activation_Guaranteed_ABE
7420 Call_Attrs => Call_Attrs,
7421 In_Task_Body => False);
7424 Process_Call_Guaranteed_ABE
7426 Call_Attrs => Call_Attrs,
7427 Target_Id => Target_Id);
7430 elsif Is_Suitable_Instantiation (N) then
7431 Process_Instantiation_Guaranteed_ABE (N);
7434 -- Remove the current scenario from the stack of active scenarios once
7435 -- all ABE diagnostics and checks have been performed.
7437 Pop_Active_Scenario (N);
7438 end Process_Guaranteed_ABE;
7440 ---------------------------
7441 -- Process_Instantiation --
7442 ---------------------------
7444 procedure Process_Instantiation
7445 (Exp_Inst : Node_Id;
7446 In_Task_Body : Boolean)
7448 Gen_Attrs : Target_Attributes;
7451 Inst_Attrs : Instantiation_Attributes;
7452 Inst_Id : Entity_Id;
7454 SPARK_Rules_On : Boolean;
7455 -- This flag is set when the SPARK rules are in effect
7458 Extract_Instantiation_Attributes
7459 (Exp_Inst => Exp_Inst,
7463 Attrs => Inst_Attrs);
7465 Extract_Target_Attributes (Gen_Id, Gen_Attrs);
7467 -- The SPARK rules are in effect when both the instantiation and generic
7468 -- are subject to SPARK_Mode On.
7470 SPARK_Rules_On := Inst_Attrs.SPARK_Mode_On and Gen_Attrs.SPARK_Mode_On;
7472 -- Output relevant information when switch -gnatel (info messages on
7473 -- implicit Elaborate[_All] pragmas) is in effect.
7475 if Elab_Info_Messages then
7480 In_SPARK => SPARK_Rules_On);
7483 -- Nothing to do when the instantiation is a guaranteed ABE
7485 if Is_Known_Guaranteed_ABE (Inst) then
7488 -- Nothing to do when the root scenario appears at the declaration level
7489 -- and the generic is in the same unit, but outside this context.
7492 -- procedure Gen is ...; -- generic declaration
7494 -- procedure Proc is
7495 -- function A ... is
7497 -- if Some_Condition then
7499 -- procedure I is new Gen; -- instantiation site
7504 -- X : ... := A; -- root scenario
7511 -- In the example above, the context of X is the declarative region of
7512 -- Proc. The "elaboration" of X may eventually reach Gen which appears
7513 -- outside of X's context. Gen is relevant only when Proc is invoked,
7514 -- but this happens only by means of "normal" elaboration, therefore
7515 -- Gen must not be considered if this is not the case.
7517 -- Performance note: parent traversal
7519 elsif Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then
7522 -- The SPARK rules are verified only when -gnatd.v (enforce SPARK
7523 -- elaboration rules in SPARK code) is in effect.
7525 elsif SPARK_Rules_On and Debug_Flag_Dot_V then
7526 Process_Instantiation_SPARK
7527 (Exp_Inst => Exp_Inst,
7529 Inst_Attrs => Inst_Attrs,
7531 Gen_Attrs => Gen_Attrs);
7533 -- Otherwise the Ada rules are in effect, or SPARK code is allowed to
7534 -- violate the SPARK rules.
7537 Process_Instantiation_Ada
7538 (Exp_Inst => Exp_Inst,
7540 Inst_Attrs => Inst_Attrs,
7542 Gen_Attrs => Gen_Attrs,
7543 In_Task_Body => In_Task_Body);
7545 end Process_Instantiation;
7547 -------------------------------
7548 -- Process_Instantiation_Ada --
7549 -------------------------------
7551 procedure Process_Instantiation_Ada
7552 (Exp_Inst : Node_Id;
7554 Inst_Attrs : Instantiation_Attributes;
7556 Gen_Attrs : Target_Attributes;
7557 In_Task_Body : Boolean)
7559 Check_OK : constant Boolean :=
7560 not Inst_Attrs.Ghost_Mode_Ignore
7561 and then not Gen_Attrs.Ghost_Mode_Ignore
7562 and then Inst_Attrs.Elab_Checks_OK
7563 and then Gen_Attrs.Elab_Checks_OK;
7564 -- A run-time ABE check may be installed only when both the instance and
7565 -- the generic have active elaboration checks and both are not ignored
7566 -- Ghost constructs.
7569 -- Nothing to do when the instantiation is ABE-safe
7576 -- package body Gen is
7581 -- procedure Main is
7582 -- package Inst is new Gen (ABE); -- safe instantiation
7585 if Is_Safe_Instantiation (Inst, Gen_Attrs) then
7588 -- The instantiation and the generic body are both in the main unit
7590 elsif Present (Gen_Attrs.Body_Decl)
7591 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl)
7593 Process_Instantiation_Conditional_ABE
7594 (Exp_Inst => Exp_Inst,
7596 Inst_Attrs => Inst_Attrs,
7598 Gen_Attrs => Gen_Attrs);
7600 -- Otherwise the generic body is not available in this compilation or it
7601 -- resides in an external unit. Install a run-time ABE check to verify
7602 -- that the generic body has been elaborated prior to the instantiation
7603 -- when the dynamic model is in effect.
7605 elsif Dynamic_Elaboration_Checks and then Check_OK then
7608 Ins_Nod => Exp_Inst,
7609 Id => Gen_Attrs.Unit_Id);
7612 -- Ensure that the unit with the generic body is elaborated prior to
7613 -- the main unit. No implicit pragma Elaborate[_All] is generated if
7614 -- the instantiation has elaboration checks suppressed. This behaviour
7615 -- parallels that of the old ABE mechanism.
7617 if Inst_Attrs.Elab_Checks_OK then
7618 Ensure_Prior_Elaboration
7620 Unit_Id => Gen_Attrs.Unit_Id,
7621 In_Task_Body => In_Task_Body);
7623 end Process_Instantiation_Ada;
7625 -------------------------------------------
7626 -- Process_Instantiation_Conditional_ABE --
7627 -------------------------------------------
7629 procedure Process_Instantiation_Conditional_ABE
7630 (Exp_Inst : Node_Id;
7632 Inst_Attrs : Instantiation_Attributes;
7634 Gen_Attrs : Target_Attributes)
7636 Check_OK : constant Boolean :=
7637 not Inst_Attrs.Ghost_Mode_Ignore
7638 and then not Gen_Attrs.Ghost_Mode_Ignore
7639 and then Inst_Attrs.Elab_Checks_OK
7640 and then Gen_Attrs.Elab_Checks_OK;
7641 -- A run-time ABE check may be installed only when both the instance and
7642 -- the generic have active elaboration checks and both are not ignored
7643 -- Ghost constructs.
7645 Root : constant Node_Id := Root_Scenario;
7648 -- If the root scenario appears prior to the generic body, then this is
7649 -- a possible ABE with respect to the root scenario.
7656 -- function A ... is
7658 -- if Some_Condition then
7660 -- package Inst is new Gen; -- instantiation site
7664 -- X : ... := A; -- root scenario
7666 -- package body Gen is -- generic body
7670 -- Y : ... := A; -- root scenario
7672 -- IMPORTANT: The instantiation of Gen is a possible ABE for X, but not
7673 -- for Y. Installing an unconditional ABE raise prior to the instance
7674 -- site would be wrong as it will fail for Y as well, but in Y's case
7675 -- the instantiation of Gen is never an ABE.
7677 if Earlier_In_Extended_Unit (Root, Gen_Attrs.Body_Decl) then
7679 -- ABE diagnostics are emitted only in the static model because there
7680 -- is a well-defined order to visiting scenarios. Without this order
7681 -- diagnostics appear jumbled and result in unwanted noise.
7683 if Static_Elaboration_Checks then
7685 ("??cannot instantiate & before body seen", Inst, Gen_Id);
7686 Error_Msg_N ("\Program_Error may be raised at run time", Inst);
7688 Output_Active_Scenarios (Inst);
7691 -- Install a conditional run-time ABE check to verify that the
7692 -- generic body has been elaborated prior to the instantiation.
7697 Ins_Nod => Exp_Inst,
7698 Target_Id => Gen_Attrs.Spec_Id,
7699 Target_Decl => Gen_Attrs.Spec_Decl,
7700 Target_Body => Gen_Attrs.Body_Decl);
7703 end Process_Instantiation_Conditional_ABE;
7705 ------------------------------------------
7706 -- Process_Instantiation_Guaranteed_ABE --
7707 ------------------------------------------
7709 procedure Process_Instantiation_Guaranteed_ABE (Exp_Inst : Node_Id) is
7710 Gen_Attrs : Target_Attributes;
7713 Inst_Attrs : Instantiation_Attributes;
7714 Inst_Id : Entity_Id;
7717 Extract_Instantiation_Attributes
7718 (Exp_Inst => Exp_Inst,
7722 Attrs => Inst_Attrs);
7724 Extract_Target_Attributes (Gen_Id, Gen_Attrs);
7726 -- Nothing to do when the root scenario appears at the declaration level
7727 -- and the generic is in the same unit, but outside this context.
7730 -- procedure Gen is ...; -- generic declaration
7732 -- procedure Proc is
7733 -- function A ... is
7735 -- if Some_Condition then
7737 -- procedure I is new Gen; -- instantiation site
7742 -- X : ... := A; -- root scenario
7749 -- In the example above, the context of X is the declarative region of
7750 -- Proc. The "elaboration" of X may eventually reach Gen which appears
7751 -- outside of X's context. Gen is relevant only when Proc is invoked,
7752 -- but this happens only by means of "normal" elaboration, therefore
7753 -- Gen must not be considered if this is not the case.
7755 -- Performance note: parent traversal
7757 if Is_Up_Level_Target (Gen_Attrs.Spec_Decl) then
7760 -- Nothing to do when the instantiation is ABE-safe
7767 -- package body Gen is
7772 -- procedure Main is
7773 -- package Inst is new Gen (ABE); -- safe instantiation
7776 elsif Is_Safe_Instantiation (Inst, Gen_Attrs) then
7779 -- An instantiation leads to a guaranteed ABE when the instantiation and
7780 -- the generic appear within the same context ignoring library levels,
7781 -- and the body of the generic has not been seen yet or appears after
7782 -- the instantiation.
7784 -- procedure Guaranteed_ABE is
7788 -- package Nested is
7789 -- procedure Inst is new Gen; -- guaranteed ABE
7797 -- Performance note: parent traversal
7799 elsif Is_Guaranteed_ABE
7801 Target_Decl => Gen_Attrs.Spec_Decl,
7802 Target_Body => Gen_Attrs.Body_Decl)
7805 ("??cannot instantiate & before body seen", Inst, Gen_Id);
7806 Error_Msg_N ("\Program_Error will be raised at run time", Inst);
7808 -- Mark the instantiation as a guarantee ABE. This automatically
7809 -- suppresses the instantiation of the generic body.
7811 Set_Is_Known_Guaranteed_ABE (Inst);
7813 -- Install a run-time ABE failure because the instantiation will
7814 -- always result in an ABE. The failure is installed when both the
7815 -- instance and the generic have enabled elaboration checks, and both
7816 -- are not ignored Ghost constructs.
7818 if Inst_Attrs.Elab_Checks_OK
7819 and then Gen_Attrs.Elab_Checks_OK
7820 and then not Inst_Attrs.Ghost_Mode_Ignore
7821 and then not Gen_Attrs.Ghost_Mode_Ignore
7825 Ins_Nod => Exp_Inst);
7828 end Process_Instantiation_Guaranteed_ABE;
7830 ---------------------------------
7831 -- Process_Instantiation_SPARK --
7832 ---------------------------------
7834 procedure Process_Instantiation_SPARK
7835 (Exp_Inst : Node_Id;
7837 Inst_Attrs : Instantiation_Attributes;
7839 Gen_Attrs : Target_Attributes)
7844 -- A source instantiation imposes an Elaborate[_All] requirement on the
7845 -- context of the main unit. Determine whether the context has a pragma
7846 -- strong enough to meet the requirement. The check is orthogonal to the
7847 -- ABE ramifications of the instantiation.
7849 if Nkind (Inst) = N_Package_Instantiation then
7850 Req_Nam := Name_Elaborate_All;
7852 Req_Nam := Name_Elaborate;
7855 Meet_Elaboration_Requirement
7857 Target_Id => Gen_Id,
7858 Req_Nam => Req_Nam);
7860 -- Nothing to do when the instantiation is ABE-safe
7867 -- package body Gen is
7872 -- procedure Main is
7873 -- package Inst is new Gen (ABE); -- safe instantiation
7876 if Is_Safe_Instantiation (Inst, Gen_Attrs) then
7879 -- The instantiation and the generic body are both in the main unit
7881 elsif Present (Gen_Attrs.Body_Decl)
7882 and then In_Extended_Main_Code_Unit (Gen_Attrs.Body_Decl)
7884 Process_Instantiation_Conditional_ABE
7885 (Exp_Inst => Exp_Inst,
7887 Inst_Attrs => Inst_Attrs,
7889 Gen_Attrs => Gen_Attrs);
7891 -- Otherwise the generic body is not available in this compilation or
7892 -- it resides in an external unit. There is no need to guarantee the
7893 -- prior elaboration of the unit with the generic body because either
7894 -- the main unit meets the Elaborate[_All] requirement imposed by the
7895 -- instantiation, or the program is illegal.
7900 end Process_Instantiation_SPARK;
7902 ---------------------------------
7903 -- Process_Variable_Assignment --
7904 ---------------------------------
7906 procedure Process_Variable_Assignment (Asmt : Node_Id) is
7907 Var_Id : constant Entity_Id := Entity (Extract_Assignment_Name (Asmt));
7908 Prag : constant Node_Id := SPARK_Pragma (Var_Id);
7910 SPARK_Rules_On : Boolean;
7911 -- This flag is set when the SPARK rules are in effect
7914 -- The SPARK rules are in effect when both the assignment and the
7915 -- variable are subject to SPARK_Mode On.
7919 and then Get_SPARK_Mode_From_Annotation (Prag) = On
7920 and then Is_SPARK_Mode_On_Node (Asmt);
7922 -- Output relevant information when switch -gnatel (info messages on
7923 -- implicit Elaborate[_All] pragmas) is in effect.
7925 if Elab_Info_Messages then
7927 (Msg => "assignment to & during elaboration",
7931 In_SPARK => SPARK_Rules_On);
7934 -- The SPARK rules are in effect. These rules are applied regardless of
7935 -- whether -gnatd.v (enforce SPARK elaboration rules in SPARK code) is
7936 -- in effect because the static model cannot ensure safe assignment of
7939 if SPARK_Rules_On then
7940 Process_Variable_Assignment_SPARK
7944 -- Otherwise the Ada rules are in effect
7947 Process_Variable_Assignment_Ada
7951 end Process_Variable_Assignment;
7953 -------------------------------------
7954 -- Process_Variable_Assignment_Ada --
7955 -------------------------------------
7957 procedure Process_Variable_Assignment_Ada
7961 Var_Decl : constant Node_Id := Declaration_Node (Var_Id);
7962 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl);
7965 -- Emit a warning when an uninitialized variable declared in a package
7966 -- spec without a pragma Elaborate_Body is initialized by elaboration
7967 -- code within the corresponding body.
7969 if not Warnings_Off (Var_Id)
7970 and then not Is_Initialized (Var_Decl)
7971 and then not Has_Pragma_Elaborate_Body (Spec_Id)
7973 -- Generate an implicit Elaborate_Body in the spec
7975 Set_Elaborate_Body_Desirable (Spec_Id);
7978 ("??variable & can be accessed by clients before this "
7979 & "initialization", Asmt, Var_Id);
7982 ("\add pragma ""Elaborate_Body"" to spec & to ensure proper "
7983 & "initialization", Asmt, Spec_Id);
7985 Output_Active_Scenarios (Asmt);
7987 end Process_Variable_Assignment_Ada;
7989 ---------------------------------------
7990 -- Process_Variable_Assignment_SPARK --
7991 ---------------------------------------
7993 procedure Process_Variable_Assignment_SPARK
7997 Var_Decl : constant Node_Id := Declaration_Node (Var_Id);
7998 Spec_Id : constant Entity_Id := Find_Top_Unit (Var_Decl);
8001 -- Emit an error when an initialized variable declared in a package spec
8002 -- without pragma Elaborate_Body is further modified by elaboration code
8003 -- within the corresponding body.
8005 if Is_Initialized (Var_Decl)
8006 and then not Has_Pragma_Elaborate_Body (Spec_Id)
8009 ("variable & modified by elaboration code in package body",
8013 ("\add pragma ""Elaborate_Body"" to spec & to ensure full "
8014 & "initialization", Asmt, Spec_Id);
8016 Output_Active_Scenarios (Asmt);
8018 end Process_Variable_Assignment_SPARK;
8020 ---------------------------
8021 -- Process_Variable_Read --
8022 ---------------------------
8024 procedure Process_Variable_Read (Ref : Node_Id) is
8025 Var_Attrs : Variable_Attributes;
8029 Extract_Variable_Reference_Attributes
8032 Attrs => Var_Attrs);
8034 -- Output relevant information when switch -gnatel (info messages on
8035 -- implicit Elaborate[_All] pragmas) is in effect.
8037 if Elab_Info_Messages then
8039 (Msg => "read of variable & during elaboration",
8046 -- Nothing to do when the variable appears within the main unit because
8047 -- diagnostics on reads are relevant only for external variables.
8049 if Is_Same_Unit (Var_Attrs.Unit_Id, Cunit_Entity (Main_Unit)) then
8052 -- Nothing to do when the variable is already initialized. Note that the
8053 -- variable may be further modified by the external unit.
8055 elsif Is_Initialized (Declaration_Node (Var_Id)) then
8058 -- Nothing to do when the external unit guarantees the initialization of
8059 -- the variable by means of pragma Elaborate_Body.
8061 elsif Has_Pragma_Elaborate_Body (Var_Attrs.Unit_Id) then
8064 -- A variable read imposes an Elaborate requirement on the context of
8065 -- the main unit. Determine whether the context has a pragma strong
8066 -- enough to meet the requirement.
8069 Meet_Elaboration_Requirement
8071 Target_Id => Var_Id,
8072 Req_Nam => Name_Elaborate);
8074 end Process_Variable_Read;
8076 --------------------------
8077 -- Push_Active_Scenario --
8078 --------------------------
8080 procedure Push_Active_Scenario (N : Node_Id) is
8082 Scenario_Stack.Append (N);
8083 end Push_Active_Scenario;
8085 ----------------------
8086 -- Process_Scenario --
8087 ----------------------
8089 procedure Process_Scenario (N : Node_Id; In_Task_Body : Boolean := False) is
8090 Call_Attrs : Call_Attributes;
8091 Target_Id : Entity_Id;
8094 -- Add the current scenario to the stack of active scenarios
8096 Push_Active_Scenario (N);
8100 if Is_Suitable_Access (N) then
8101 Process_Access (N, In_Task_Body);
8105 elsif Is_Suitable_Call (N) then
8107 -- In general, only calls found within the main unit are processed
8108 -- because the ALI information supplied to binde is for the main
8109 -- unit only. However, to preserve the consistency of the tree and
8110 -- ensure proper serialization of internal names, external calls
8111 -- also receive corresponding call markers (see Build_Call_Marker).
8112 -- Regardless of the reason, external calls must not be processed.
8114 if In_Main_Context (N) then
8115 Extract_Call_Attributes
8117 Target_Id => Target_Id,
8118 Attrs => Call_Attrs);
8120 if Is_Activation_Proc (Target_Id) then
8121 Process_Activation_Conditional_ABE
8123 Call_Attrs => Call_Attrs,
8124 In_Task_Body => In_Task_Body);
8129 Call_Attrs => Call_Attrs,
8130 Target_Id => Target_Id,
8131 In_Task_Body => In_Task_Body);
8137 elsif Is_Suitable_Instantiation (N) then
8138 Process_Instantiation (N, In_Task_Body);
8140 -- Variable assignments
8142 elsif Is_Suitable_Variable_Assignment (N) then
8143 Process_Variable_Assignment (N);
8147 elsif Is_Suitable_Variable_Read (N) then
8148 Process_Variable_Read (N);
8151 -- Remove the current scenario from the stack of active scenarios once
8152 -- all ABE diagnostics and checks have been performed.
8154 Pop_Active_Scenario (N);
8155 end Process_Scenario;
8157 ---------------------------------
8158 -- Record_Elaboration_Scenario --
8159 ---------------------------------
8161 procedure Record_Elaboration_Scenario (N : Node_Id) is
8162 Level : Enclosing_Level_Kind;
8164 Declaration_Level_OK : Boolean;
8165 -- This flag is set when a particular scenario is allowed to appear at
8166 -- the declaration level.
8169 -- Assume that the scenario must not appear at the declaration level
8171 Declaration_Level_OK := False;
8173 -- Nothing to do for ASIS. As a result, no ABE checks and diagnostics
8174 -- are performed in this mode.
8179 -- Nothing to do when the scenario is being preanalyzed
8181 elsif Preanalysis_Active then
8185 -- Ensure that a library level call does not appear in a preelaborated
8186 -- unit. The check must come before ignoring scenarios within external
8187 -- units or inside generics because calls in those context must also be
8190 if Is_Suitable_Call (N) then
8191 Check_Preelaborated_Call (N);
8194 -- Nothing to do when the scenario does not appear within the main unit
8196 if not In_Main_Context (N) then
8199 -- Scenarios within a generic unit are never considered because generics
8200 -- cannot be elaborated.
8202 elsif Inside_A_Generic then
8205 -- Scenarios which do not fall in one of the elaboration categories
8206 -- listed below are not considered. The categories are:
8208 -- 'Access for entries, operators, and subprograms
8209 -- Assignments to variables
8210 -- Calls (includes task activation)
8212 -- Reads of variables
8214 elsif Is_Suitable_Access (N) then
8215 -- Signal any enclosing local exception handlers that the 'Access may
8216 -- raise Program_Error due to a failed ABE check when switch -gnatd.o
8217 -- (conservative elaboration order for indirect calls) is in effect.
8218 -- Marking the exception handlers ensures proper expansion by both
8219 -- the front and back end restriction when No_Exception_Propagation
8222 if Debug_Flag_Dot_O then
8223 Possible_Local_Raise (N, Standard_Program_Error);
8226 elsif Is_Suitable_Call (N) or else Is_Suitable_Instantiation (N) then
8227 Declaration_Level_OK := True;
8229 -- Signal any enclosing local exception handlers that the call or
8230 -- instantiation may raise Program_Error due to a failed ABE check.
8231 -- Marking the exception handlers ensures proper expansion by both
8232 -- the front and back end restriction when No_Exception_Propagation
8235 Possible_Local_Raise (N, Standard_Program_Error);
8237 elsif Is_Suitable_Variable_Assignment (N)
8238 or else Is_Suitable_Variable_Read (N)
8242 -- Otherwise the input does not denote a suitable scenario
8248 -- The static model imposes additional restrictions on the placement of
8249 -- scenarios. In contrast, the dynamic model assumes that every scenario
8250 -- will be elaborated or invoked at some point.
8252 if Static_Elaboration_Checks then
8254 -- Performance note: parent traversal
8256 Level := Find_Enclosing_Level (N);
8258 -- Declaration level scenario
8260 if Declaration_Level_OK and then Level = Declaration_Level then
8263 -- Library level scenario
8265 elsif Level in Library_Level then
8268 -- Instantiation library level scenario
8270 elsif Level = Instantiation then
8273 -- Otherwise the scenario does not appear at the proper level and
8274 -- cannot possibly act as a top level scenario.
8281 -- Perform early detection of guaranteed ABEs in order to suppress the
8282 -- instantiation of generic bodies as gigi cannot handle certain types
8283 -- of premature instantiations.
8285 Process_Guaranteed_ABE (N);
8287 -- At this point all checks have been performed. Record the scenario for
8288 -- later processing by the ABE phase.
8290 Top_Level_Scenarios.Append (N);
8292 -- Mark a scenario which may produce run-time conditional ABE checks or
8293 -- guaranteed ABE failures as recorded. The flag ensures that scenario
8294 -- rewriting performed by Atree.Rewrite will be properly reflected in
8295 -- all relevant internal data structures.
8297 if Is_Check_Emitting_Scenario (N) then
8298 Set_Is_Recorded_Scenario (N);
8300 end Record_Elaboration_Scenario;
8306 function Root_Scenario return Node_Id is
8307 package Stack renames Scenario_Stack;
8310 -- Ensure that the scenario stack has at least one active scenario in
8311 -- it. The one at the bottom (index First) is the root scenario.
8313 pragma Assert (Stack.Last >= Stack.First);
8314 return Stack.Table (Stack.First);
8317 -------------------------------
8318 -- Static_Elaboration_Checks --
8319 -------------------------------
8321 function Static_Elaboration_Checks return Boolean is
8323 return not Dynamic_Elaboration_Checks;
8324 end Static_Elaboration_Checks;
8330 procedure Traverse_Body (N : Node_Id; In_Task_Body : Boolean) is
8331 function Is_Potential_Scenario (Nod : Node_Id) return Traverse_Result;
8332 -- Determine whether arbitrary node Nod denotes a suitable scenario and
8333 -- if so, process it.
8335 procedure Traverse_Potential_Scenarios is
8336 new Traverse_Proc (Is_Potential_Scenario);
8338 procedure Traverse_List (List : List_Id);
8339 -- Inspect list List for suitable elaboration scenarios and process them
8341 ---------------------------
8342 -- Is_Potential_Scenario --
8343 ---------------------------
8345 function Is_Potential_Scenario (Nod : Node_Id) return Traverse_Result is
8349 -- Skip constructs which do not have elaboration of their own and
8350 -- need to be elaborated by other means such as invocation, task
8353 if Is_Non_Library_Level_Encapsulator (Nod) then
8356 -- Terminate the traversal of a task body with an accept statement
8357 -- when no entry calls in elaboration are allowed because the task
8358 -- will block at run-time and none of the remaining statements will
8361 elsif Nkind_In (Original_Node (Nod), N_Accept_Statement,
8363 and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
8367 -- Certain nodes carry semantic lists which act as repositories until
8368 -- expansion transforms the node and relocates the contents. Examine
8369 -- these lists in case expansion is disabled.
8371 elsif Nkind_In (Nod, N_And_Then, N_Or_Else) then
8372 Traverse_List (Actions (Nod));
8374 elsif Nkind_In (Nod, N_Elsif_Part, N_Iteration_Scheme) then
8375 Traverse_List (Condition_Actions (Nod));
8377 elsif Nkind (Nod) = N_If_Expression then
8378 Traverse_List (Then_Actions (Nod));
8379 Traverse_List (Else_Actions (Nod));
8381 elsif Nkind_In (Nod, N_Component_Association,
8382 N_Iterated_Component_Association)
8384 Traverse_List (Loop_Actions (Nod));
8388 elsif Is_Suitable_Scenario (Nod) then
8389 Process_Scenario (Nod, In_Task_Body);
8393 end Is_Potential_Scenario;
8399 procedure Traverse_List (List : List_Id) is
8403 Item := First (List);
8404 while Present (Item) loop
8405 Traverse_Potential_Scenarios (Item);
8410 -- Start of processing for Traverse_Body
8413 -- Nothing to do when there is no body
8418 elsif Nkind (N) /= N_Subprogram_Body then
8422 -- Nothing to do if the body was already traversed during the processing
8423 -- of the same top level scenario.
8425 if Visited_Bodies.Get (N) then
8428 -- Otherwise mark the body as traversed
8431 Visited_Bodies.Set (N, True);
8434 -- Examine the declarations for suitable scenarios
8436 Traverse_List (Declarations (N));
8438 -- Examine the handled sequence of statements. This also includes any
8439 -- exceptions handlers.
8441 Traverse_Potential_Scenarios (Handled_Statement_Sequence (N));
8444 ---------------------------------
8445 -- Update_Elaboration_Scenario --
8446 ---------------------------------
8448 procedure Update_Elaboration_Scenario (New_N : Node_Id; Old_N : Node_Id) is
8449 package Scenarios renames Top_Level_Scenarios;
8452 -- A scenario is being transformed by Atree.Rewrite. Update all relevant
8453 -- internal data structures to reflect this change. This ensures that a
8454 -- potential run-time conditional ABE check or a guaranteed ABE failure
8455 -- is inserted at the proper place in the tree.
8457 if Is_Check_Emitting_Scenario (Old_N)
8458 and then Is_Recorded_Scenario (Old_N)
8459 and then Old_N /= New_N
8461 -- Performance note: list traversal
8463 for Index in Scenarios.First .. Scenarios.Last loop
8464 if Scenarios.Table (Index) = Old_N then
8465 Scenarios.Table (Index) := New_N;
8467 Set_Is_Recorded_Scenario (Old_N, False);
8468 Set_Is_Recorded_Scenario (New_N);
8473 -- A recorded scenario must be in the table of recorded scenarios
8475 pragma Assert (False);
8477 end Update_Elaboration_Scenario;
8479 -------------------------
8480 -- Visited_Bodies_Hash --
8481 -------------------------
8483 function Visited_Bodies_Hash (Key : Node_Id) return Visited_Bodies_Index is
8485 return Visited_Bodies_Index (Key mod Visited_Bodies_Max);
8486 end Visited_Bodies_Hash;