1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, 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 Debug_A
; use Debug_A
;
29 with Elists
; use Elists
;
30 with Exp_SPARK
; use Exp_SPARK
;
31 with Expander
; use Expander
;
32 with Ghost
; use Ghost
;
34 with Lib
.Load
; use Lib
.Load
;
35 with Nlists
; use Nlists
;
36 with Output
; use Output
;
37 with Restrict
; use Restrict
;
38 with Sem_Attr
; use Sem_Attr
;
39 with Sem_Aux
; use Sem_Aux
;
40 with Sem_Ch2
; use Sem_Ch2
;
41 with Sem_Ch3
; use Sem_Ch3
;
42 with Sem_Ch4
; use Sem_Ch4
;
43 with Sem_Ch5
; use Sem_Ch5
;
44 with Sem_Ch6
; use Sem_Ch6
;
45 with Sem_Ch7
; use Sem_Ch7
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Ch9
; use Sem_Ch9
;
48 with Sem_Ch10
; use Sem_Ch10
;
49 with Sem_Ch11
; use Sem_Ch11
;
50 with Sem_Ch12
; use Sem_Ch12
;
51 with Sem_Ch13
; use Sem_Ch13
;
52 with Sem_Prag
; use Sem_Prag
;
53 with Sem_Util
; use Sem_Util
;
54 with Sinfo
; use Sinfo
;
55 with Stand
; use Stand
;
56 with Stylesw
; use Stylesw
;
57 with Uintp
; use Uintp
;
58 with Uname
; use Uname
;
60 with Unchecked_Deallocation
;
62 pragma Warnings
(Off
, Sem_Util
);
63 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
67 Debug_Unit_Walk
: Boolean renames Debug_Flag_Dot_WW
;
68 -- Controls debugging printouts for Walk_Library_Items
70 Outer_Generic_Scope
: Entity_Id
:= Empty
;
71 -- Global reference to the outer scope that is generic. In a non-generic
72 -- context, it is empty. At the moment, it is only used for avoiding
73 -- freezing of external references in generics.
75 Comp_Unit_List
: Elist_Id
:= No_Elist
;
76 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
77 -- processed by Semantics, in an appropriate order. Initialized to
78 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
79 -- to New_Elmt_List on first use.
82 with procedure Action
(Withed_Unit
: Node_Id
);
83 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean);
84 -- Walk all the with clauses of CU, and call Action for the with'ed unit.
85 -- Ignore limited withs, unless Include_Limited is True. CU must be an
86 -- N_Compilation_Unit.
89 with procedure Action
(Withed_Unit
: Node_Id
);
90 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean);
91 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
92 -- of this unit, since they count as dependences on their parent library
93 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
99 -- WARNING: This routine manages Ghost regions. Return statements must be
100 -- replaced by gotos which jump to the end of the routine and restore the
103 procedure Analyze
(N
: Node_Id
) is
104 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
105 -- Save the Ghost mode to restore on exit
108 Debug_A_Entry
("analyzing ", N
);
110 -- Immediate return if already analyzed
113 Debug_A_Exit
("analyzing ", N
, " (done, analyzed already)");
117 -- A declaration may be subject to pragma Ghost. Set the mode now to
118 -- ensure that any nodes generated during analysis and expansion are
121 if Is_Declaration
(N
) then
122 Mark_And_Set_Ghost_Declaration
(N
);
125 -- Otherwise processing depends on the node kind
128 when N_Abort_Statement
=>
129 Analyze_Abort_Statement
(N
);
131 when N_Abstract_Subprogram_Declaration
=>
132 Analyze_Abstract_Subprogram_Declaration
(N
);
134 when N_Accept_Alternative
=>
135 Analyze_Accept_Alternative
(N
);
137 when N_Accept_Statement
=>
138 Analyze_Accept_Statement
(N
);
141 Analyze_Aggregate
(N
);
144 Analyze_Allocator
(N
);
147 Analyze_Short_Circuit
(N
);
149 when N_Assignment_Statement
=>
150 Analyze_Assignment
(N
);
152 when N_Asynchronous_Select
=>
153 Analyze_Asynchronous_Select
(N
);
156 Analyze_At_Clause
(N
);
158 when N_Attribute_Reference
=>
159 Analyze_Attribute
(N
);
161 when N_Attribute_Definition_Clause
=>
162 Analyze_Attribute_Definition_Clause
(N
);
164 when N_Block_Statement
=>
165 Analyze_Block_Statement
(N
);
167 when N_Case_Expression
=>
168 Analyze_Case_Expression
(N
);
170 when N_Case_Statement
=>
171 Analyze_Case_Statement
(N
);
173 when N_Character_Literal
=>
174 Analyze_Character_Literal
(N
);
176 when N_Code_Statement
=>
177 Analyze_Code_Statement
(N
);
179 when N_Compilation_Unit
=>
180 Analyze_Compilation_Unit
(N
);
182 when N_Component_Declaration
=>
183 Analyze_Component_Declaration
(N
);
185 when N_Compound_Statement
=>
186 Analyze_Compound_Statement
(N
);
188 when N_Conditional_Entry_Call
=>
189 Analyze_Conditional_Entry_Call
(N
);
191 when N_Delay_Alternative
=>
192 Analyze_Delay_Alternative
(N
);
194 when N_Delay_Relative_Statement
=>
195 Analyze_Delay_Relative
(N
);
197 when N_Delay_Until_Statement
=>
198 Analyze_Delay_Until
(N
);
200 when N_Delta_Aggregate
=>
201 Analyze_Aggregate
(N
);
204 Analyze_Entry_Body
(N
);
206 when N_Entry_Body_Formal_Part
=>
207 Analyze_Entry_Body_Formal_Part
(N
);
209 when N_Entry_Call_Alternative
=>
210 Analyze_Entry_Call_Alternative
(N
);
212 when N_Entry_Declaration
=>
213 Analyze_Entry_Declaration
(N
);
215 when N_Entry_Index_Specification
=>
216 Analyze_Entry_Index_Specification
(N
);
218 when N_Enumeration_Representation_Clause
=>
219 Analyze_Enumeration_Representation_Clause
(N
);
221 when N_Exception_Declaration
=>
222 Analyze_Exception_Declaration
(N
);
224 when N_Exception_Renaming_Declaration
=>
225 Analyze_Exception_Renaming
(N
);
227 when N_Exit_Statement
=>
228 Analyze_Exit_Statement
(N
);
230 when N_Expanded_Name
=>
231 Analyze_Expanded_Name
(N
);
233 when N_Explicit_Dereference
=>
234 Analyze_Explicit_Dereference
(N
);
236 when N_Expression_Function
=>
237 Analyze_Expression_Function
(N
);
239 when N_Expression_With_Actions
=>
240 Analyze_Expression_With_Actions
(N
);
242 when N_Extended_Return_Statement
=>
243 Analyze_Extended_Return_Statement
(N
);
245 when N_Extension_Aggregate
=>
246 Analyze_Aggregate
(N
);
248 when N_Formal_Object_Declaration
=>
249 Analyze_Formal_Object_Declaration
(N
);
251 when N_Formal_Package_Declaration
=>
252 Analyze_Formal_Package_Declaration
(N
);
254 when N_Formal_Subprogram_Declaration
=>
255 Analyze_Formal_Subprogram_Declaration
(N
);
257 when N_Formal_Type_Declaration
=>
258 Analyze_Formal_Type_Declaration
(N
);
260 when N_Free_Statement
=>
261 Analyze_Free_Statement
(N
);
263 when N_Freeze_Entity
=>
264 Analyze_Freeze_Entity
(N
);
266 when N_Freeze_Generic_Entity
=>
267 Analyze_Freeze_Generic_Entity
(N
);
269 when N_Full_Type_Declaration
=>
270 Analyze_Full_Type_Declaration
(N
);
272 when N_Function_Call
=>
273 Analyze_Function_Call
(N
);
275 when N_Function_Instantiation
=>
276 Analyze_Function_Instantiation
(N
);
278 when N_Generic_Function_Renaming_Declaration
=>
279 Analyze_Generic_Function_Renaming
(N
);
281 when N_Generic_Package_Declaration
=>
282 Analyze_Generic_Package_Declaration
(N
);
284 when N_Generic_Package_Renaming_Declaration
=>
285 Analyze_Generic_Package_Renaming
(N
);
287 when N_Generic_Procedure_Renaming_Declaration
=>
288 Analyze_Generic_Procedure_Renaming
(N
);
290 when N_Generic_Subprogram_Declaration
=>
291 Analyze_Generic_Subprogram_Declaration
(N
);
293 when N_Goto_Statement
=>
294 Analyze_Goto_Statement
(N
);
296 when N_Handled_Sequence_Of_Statements
=>
297 Analyze_Handled_Statements
(N
);
300 Analyze_Identifier
(N
);
302 when N_If_Expression
=>
303 Analyze_If_Expression
(N
);
305 when N_If_Statement
=>
306 Analyze_If_Statement
(N
);
308 when N_Implicit_Label_Declaration
=>
309 Analyze_Implicit_Label_Declaration
(N
);
312 Analyze_Membership_Op
(N
);
314 when N_Incomplete_Type_Declaration
=>
315 Analyze_Incomplete_Type_Decl
(N
);
317 when N_Indexed_Component
=>
318 Analyze_Indexed_Component_Form
(N
);
320 when N_Integer_Literal
=>
321 Analyze_Integer_Literal
(N
);
323 when N_Iterator_Specification
=>
324 Analyze_Iterator_Specification
(N
);
326 when N_Itype_Reference
=>
327 Analyze_Itype_Reference
(N
);
332 when N_Loop_Parameter_Specification
=>
333 Analyze_Loop_Parameter_Specification
(N
);
335 when N_Loop_Statement
=>
336 Analyze_Loop_Statement
(N
);
339 Analyze_Membership_Op
(N
);
344 when N_Null_Statement
=>
345 Analyze_Null_Statement
(N
);
347 when N_Number_Declaration
=>
348 Analyze_Number_Declaration
(N
);
350 when N_Object_Declaration
=>
351 Analyze_Object_Declaration
(N
);
353 when N_Object_Renaming_Declaration
=>
354 Analyze_Object_Renaming
(N
);
356 when N_Operator_Symbol
=>
357 Analyze_Operator_Symbol
(N
);
360 Analyze_Unary_Op
(N
);
363 Analyze_Arithmetic_Op
(N
);
366 Analyze_Logical_Op
(N
);
369 Analyze_Concatenation
(N
);
372 Analyze_Arithmetic_Op
(N
);
375 Analyze_Equality_Op
(N
);
378 Analyze_Arithmetic_Op
(N
);
381 Analyze_Comparison_Op
(N
);
384 Analyze_Comparison_Op
(N
);
387 Analyze_Comparison_Op
(N
);
390 Analyze_Comparison_Op
(N
);
393 Analyze_Unary_Op
(N
);
398 when N_Op_Multiply
=>
399 Analyze_Arithmetic_Op
(N
);
402 Analyze_Equality_Op
(N
);
405 Analyze_Negation
(N
);
408 Analyze_Logical_Op
(N
);
411 Analyze_Unary_Op
(N
);
414 Analyze_Arithmetic_Op
(N
);
416 when N_Op_Rotate_Left
=>
417 Analyze_Arithmetic_Op
(N
);
419 when N_Op_Rotate_Right
=>
420 Analyze_Arithmetic_Op
(N
);
422 when N_Op_Shift_Left
=>
423 Analyze_Arithmetic_Op
(N
);
425 when N_Op_Shift_Right
=>
426 Analyze_Arithmetic_Op
(N
);
428 when N_Op_Shift_Right_Arithmetic
=>
429 Analyze_Arithmetic_Op
(N
);
431 when N_Op_Subtract
=>
432 Analyze_Arithmetic_Op
(N
);
435 Analyze_Logical_Op
(N
);
438 Analyze_Short_Circuit
(N
);
440 when N_Others_Choice
=>
441 Analyze_Others_Choice
(N
);
443 when N_Package_Body
=>
444 Analyze_Package_Body
(N
);
446 when N_Package_Body_Stub
=>
447 Analyze_Package_Body_Stub
(N
);
449 when N_Package_Declaration
=>
450 Analyze_Package_Declaration
(N
);
452 when N_Package_Instantiation
=>
453 Analyze_Package_Instantiation
(N
);
455 when N_Package_Renaming_Declaration
=>
456 Analyze_Package_Renaming
(N
);
458 when N_Package_Specification
=>
459 Analyze_Package_Specification
(N
);
461 when N_Parameter_Association
=>
462 Analyze_Parameter_Association
(N
);
467 when N_Private_Extension_Declaration
=>
468 Analyze_Private_Extension_Declaration
(N
);
470 when N_Private_Type_Declaration
=>
471 Analyze_Private_Type_Declaration
(N
);
473 when N_Procedure_Call_Statement
=>
474 Analyze_Procedure_Call
(N
);
476 when N_Procedure_Instantiation
=>
477 Analyze_Procedure_Instantiation
(N
);
479 when N_Protected_Body
=>
480 Analyze_Protected_Body
(N
);
482 when N_Protected_Body_Stub
=>
483 Analyze_Protected_Body_Stub
(N
);
485 when N_Protected_Definition
=>
486 Analyze_Protected_Definition
(N
);
488 when N_Protected_Type_Declaration
=>
489 Analyze_Protected_Type_Declaration
(N
);
491 when N_Qualified_Expression
=>
492 Analyze_Qualified_Expression
(N
);
494 when N_Quantified_Expression
=>
495 Analyze_Quantified_Expression
(N
);
497 when N_Raise_Expression
=>
498 Analyze_Raise_Expression
(N
);
500 when N_Raise_Statement
=>
501 Analyze_Raise_Statement
(N
);
503 when N_Raise_xxx_Error
=>
504 Analyze_Raise_xxx_Error
(N
);
509 when N_Range_Constraint
=>
510 Analyze_Range
(Range_Expression
(N
));
512 when N_Real_Literal
=>
513 Analyze_Real_Literal
(N
);
515 when N_Record_Representation_Clause
=>
516 Analyze_Record_Representation_Clause
(N
);
518 when N_Reduction_Expression
=>
519 Analyze_Reduction_Expression
(N
);
521 when N_Reduction_Expression_Parameter
=>
522 Analyze_Reduction_Expression_Parameter
(N
);
525 Analyze_Reference
(N
);
527 when N_Requeue_Statement
=>
530 when N_Simple_Return_Statement
=>
531 Analyze_Simple_Return_Statement
(N
);
533 when N_Selected_Component
=>
534 Find_Selected_Component
(N
);
535 -- ??? why not Analyze_Selected_Component, needs comments
537 when N_Selective_Accept
=>
538 Analyze_Selective_Accept
(N
);
540 when N_Single_Protected_Declaration
=>
541 Analyze_Single_Protected_Declaration
(N
);
543 when N_Single_Task_Declaration
=>
544 Analyze_Single_Task_Declaration
(N
);
549 when N_String_Literal
=>
550 Analyze_String_Literal
(N
);
552 when N_Subprogram_Body
=>
553 Analyze_Subprogram_Body
(N
);
555 when N_Subprogram_Body_Stub
=>
556 Analyze_Subprogram_Body_Stub
(N
);
558 when N_Subprogram_Declaration
=>
559 Analyze_Subprogram_Declaration
(N
);
561 when N_Subprogram_Renaming_Declaration
=>
562 Analyze_Subprogram_Renaming
(N
);
564 when N_Subtype_Declaration
=>
565 Analyze_Subtype_Declaration
(N
);
567 when N_Subtype_Indication
=>
568 Analyze_Subtype_Indication
(N
);
573 when N_Target_Name
=>
574 Analyze_Target_Name
(N
);
577 Analyze_Task_Body
(N
);
579 when N_Task_Body_Stub
=>
580 Analyze_Task_Body_Stub
(N
);
582 when N_Task_Definition
=>
583 Analyze_Task_Definition
(N
);
585 when N_Task_Type_Declaration
=>
586 Analyze_Task_Type_Declaration
(N
);
588 when N_Terminate_Alternative
=>
589 Analyze_Terminate_Alternative
(N
);
591 when N_Timed_Entry_Call
=>
592 Analyze_Timed_Entry_Call
(N
);
594 when N_Triggering_Alternative
=>
595 Analyze_Triggering_Alternative
(N
);
597 when N_Type_Conversion
=>
598 Analyze_Type_Conversion
(N
);
600 when N_Unchecked_Expression
=>
601 Analyze_Unchecked_Expression
(N
);
603 when N_Unchecked_Type_Conversion
=>
604 Analyze_Unchecked_Type_Conversion
(N
);
606 when N_Use_Package_Clause
=>
607 Analyze_Use_Package
(N
);
609 when N_Use_Type_Clause
=>
610 Analyze_Use_Type
(N
);
612 when N_Validate_Unchecked_Conversion
=>
615 when N_Variant_Part
=>
616 Analyze_Variant_Part
(N
);
618 when N_With_Clause
=>
619 Analyze_With_Clause
(N
);
621 -- A call to analyze a marker is ignored because the node does not
622 -- have any static and run-time semantics.
625 | N_Variable_Reference_Marker
629 -- A call to analyze the Empty node is an error, but most likely it
630 -- is an error caused by an attempt to analyze a malformed piece of
631 -- tree caused by some other error, so if there have been any other
632 -- errors, we just ignore it, otherwise it is a real internal error
633 -- which we complain about.
635 -- We must also consider the case of call to a runtime function that
636 -- is not available in the configurable runtime.
639 pragma Assert
(Serious_Errors_Detected
/= 0
640 or else Configurable_Run_Time_Violations
/= 0);
643 -- A call to analyze the error node is simply ignored, to avoid
644 -- causing cascaded errors (happens of course only in error cases)
645 -- Disable expansion in case it is still enabled, to prevent other
646 -- subsequent compiler glitches.
649 Expander_Mode_Save_And_Set
(False);
652 -- Push/Pop nodes normally don't come through an analyze call. An
653 -- exception is the dummy ones bracketing a subprogram body. In any
654 -- case there is nothing to be done to analyze such nodes.
656 when N_Push_Pop_xxx_Label
=>
659 -- SCIL nodes don't need analysis because they are decorated when
660 -- they are built. They are added to the tree by Insert_Actions and
661 -- the call to analyze them is generated when the full list is
664 when N_SCIL_Dispatch_Table_Tag_Init
665 | N_SCIL_Dispatching_Call
666 | N_SCIL_Membership_Test
670 -- A quantified expression with a missing "all" or "some" qualifier
671 -- looks identical to an iterated component association. By language
672 -- definition, the latter must be present within array aggregates. If
673 -- this is not the case, then the iterated component association is
674 -- really an illegal quantified expression. Diagnose this scenario.
676 when N_Iterated_Component_Association
=>
677 Diagnose_Iterated_Component_Association
(N
);
679 -- For the remaining node types, we generate compiler abort, because
680 -- these nodes are always analyzed within the Sem_Chn routines and
681 -- there should never be a case of making a call to the main Analyze
682 -- routine for these node kinds. For example, an N_Access_Definition
683 -- node appears only in the context of a type declaration, and is
684 -- processed by the analyze routine for type declarations.
686 when N_Abortable_Part
687 | N_Access_Definition
688 | N_Access_Function_Definition
689 | N_Access_Procedure_Definition
690 | N_Access_To_Object_Definition
691 | N_Aspect_Specification
692 | N_Case_Expression_Alternative
693 | N_Case_Statement_Alternative
694 | N_Compilation_Unit_Aux
695 | N_Component_Association
697 | N_Component_Definition
699 | N_Constrained_Array_Definition
701 | N_Decimal_Fixed_Point_Definition
702 | N_Defining_Character_Literal
703 | N_Defining_Identifier
704 | N_Defining_Operator_Symbol
705 | N_Defining_Program_Unit_Name
707 | N_Derived_Type_Definition
709 | N_Digits_Constraint
710 | N_Discriminant_Association
711 | N_Discriminant_Specification
713 | N_Entry_Call_Statement
714 | N_Enumeration_Type_Definition
715 | N_Exception_Handler
716 | N_Floating_Point_Definition
717 | N_Formal_Decimal_Fixed_Point_Definition
718 | N_Formal_Derived_Type_Definition
719 | N_Formal_Discrete_Type_Definition
720 | N_Formal_Floating_Point_Definition
721 | N_Formal_Modular_Type_Definition
722 | N_Formal_Ordinary_Fixed_Point_Definition
723 | N_Formal_Private_Type_Definition
724 | N_Formal_Incomplete_Type_Definition
725 | N_Formal_Signed_Integer_Type_Definition
726 | N_Function_Specification
727 | N_Generic_Association
728 | N_Index_Or_Discriminant_Constraint
731 | N_Modular_Type_Definition
732 | N_Ordinary_Fixed_Point_Definition
733 | N_Parameter_Specification
734 | N_Pragma_Argument_Association
735 | N_Procedure_Specification
736 | N_Real_Range_Specification
737 | N_Record_Definition
738 | N_Signed_Integer_Type_Definition
739 | N_Unconstrained_Array_Definition
747 Debug_A_Exit
("analyzing ", N
, " (done)");
749 -- Mark relevant use-type and use-package clauses as effective
750 -- preferring the original node over the analyzed one in the case that
751 -- constant folding has occurred and removed references that need to be
752 -- examined. Also, if the node in question is overloaded then this is
753 -- deferred until resolution.
756 Operat
: Node_Id
:= Empty
;
758 -- Attempt to obtain a checkable operator node
760 if Nkind
(Original_Node
(N
)) in N_Op
then
761 Operat
:= Original_Node
(N
);
762 elsif Nkind
(N
) in N_Op
then
769 and then Present
(Entity
(Operat
))
770 and then not Is_Overloaded
(Operat
)
772 Mark_Use_Clauses
(Operat
);
776 -- Now that we have analyzed the node, we call the expander to perform
777 -- possible expansion. We skip this for subexpressions, because we don't
778 -- have the type yet, and the expander will need to know the type before
779 -- it can do its job. For subexpression nodes, the call to the expander
780 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
781 -- which can appear in a statement context, and needs expanding now in
782 -- the case (distinguished by Etype, as documented in Sinfo).
784 -- The Analyzed flag is also set at this point for non-subexpression
785 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
786 -- since resolution and expansion have not yet been completed). Note
787 -- that for N_Raise_xxx_Error we have to distinguish the expression
788 -- case from the statement case.
790 if Nkind
(N
) not in N_Subexpr
791 or else (Nkind
(N
) in N_Raise_xxx_Error
792 and then Etype
(N
) = Standard_Void_Type
)
796 -- Replace a reference to a renaming with the renamed object for SPARK.
797 -- In general this modification is performed by Expand_SPARK, however
798 -- certain constructs may not reach the resolution or expansion phase
799 -- and thus remain unchanged. The replacement is not performed when the
800 -- construct is overloaded as resolution must first take place. This is
801 -- also not done when analyzing a generic to preserve the original tree
802 -- and because the reference may become overloaded in the instance.
805 and then Nkind_In
(N
, N_Expanded_Name
, N_Identifier
)
806 and then not Is_Overloaded
(N
)
807 and then not Inside_A_Generic
809 Expand_SPARK_Potential_Renaming
(N
);
812 Restore_Ghost_Mode
(Saved_GM
);
815 -- Version with check(s) suppressed
817 procedure Analyze
(N
: Node_Id
; Suppress
: Check_Id
) is
819 if Suppress
= All_Checks
then
821 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
823 Scope_Suppress
.Suppress
:= (others => True);
825 Scope_Suppress
.Suppress
:= Svs
;
828 elsif Suppress
= Overflow_Check
then
830 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
832 Scope_Suppress
.Suppress
(Suppress
) := True;
834 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
843 procedure Analyze_List
(L
: List_Id
) is
848 while Present
(Node
) loop
854 -- Version with check(s) suppressed
856 procedure Analyze_List
(L
: List_Id
; Suppress
: Check_Id
) is
858 if Suppress
= All_Checks
then
860 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
862 Scope_Suppress
.Suppress
:= (others => True);
864 Scope_Suppress
.Suppress
:= Svs
;
869 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
871 Scope_Suppress
.Suppress
(Suppress
) := True;
873 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
878 --------------------------
879 -- Copy_Suppress_Status --
880 --------------------------
882 procedure Copy_Suppress_Status
888 pragma Warnings
(Off
, Found
);
890 procedure Search_Stack
891 (Top
: Suppress_Stack_Entry_Ptr
;
892 Found
: out Boolean);
893 -- Search given suppress stack for matching entry for entity. If found
894 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
895 -- entry for To onto the local suppress stack.
901 procedure Search_Stack
902 (Top
: Suppress_Stack_Entry_Ptr
;
905 Ptr
: Suppress_Stack_Entry_Ptr
;
909 while Ptr
/= null loop
911 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
914 Set_Checks_May_Be_Suppressed
(To
, True);
915 Push_Local_Suppress_Stack_Entry
931 -- Start of processing for Copy_Suppress_Status
934 if not Checks_May_Be_Suppressed
(From
) then
938 -- First search the global entity suppress table for a matching entry.
939 -- We also search this in reverse order so that if there are multiple
940 -- pragmas for the same entity, the last one applies.
942 Search_Stack
(Global_Suppress_Stack_Top
, Found
);
948 -- Now search the local entity suppress stack, we search this in
949 -- reverse order so that we get the innermost entry that applies to
950 -- this case if there are nested entries. Note that for the purpose
951 -- of this procedure we are ONLY looking for entries corresponding
952 -- to a two-argument Suppress, where the second argument matches From.
954 Search_Stack
(Local_Suppress_Stack_Top
, Found
);
955 end Copy_Suppress_Status
;
957 -------------------------
958 -- Enter_Generic_Scope --
959 -------------------------
961 procedure Enter_Generic_Scope
(S
: Entity_Id
) is
963 if No
(Outer_Generic_Scope
) then
964 Outer_Generic_Scope
:= S
;
966 end Enter_Generic_Scope
;
968 ------------------------
969 -- Exit_Generic_Scope --
970 ------------------------
972 procedure Exit_Generic_Scope
(S
: Entity_Id
) is
974 if S
= Outer_Generic_Scope
then
975 Outer_Generic_Scope
:= Empty
;
977 end Exit_Generic_Scope
;
979 -----------------------
980 -- Explicit_Suppress --
981 -----------------------
983 function Explicit_Suppress
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
984 Ptr
: Suppress_Stack_Entry_Ptr
;
987 if not Checks_May_Be_Suppressed
(E
) then
991 Ptr
:= Global_Suppress_Stack_Top
;
992 while Ptr
/= null loop
994 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
1004 end Explicit_Suppress
;
1006 -----------------------------
1007 -- External_Ref_In_Generic --
1008 -----------------------------
1010 function External_Ref_In_Generic
(E
: Entity_Id
) return Boolean is
1014 -- Entity is global if defined outside of current outer_generic_scope:
1015 -- Either the entity has a smaller depth that the outer generic, or it
1016 -- is in a different compilation unit, or it is defined within a unit
1017 -- in the same compilation, that is not within the outer_generic.
1019 if No
(Outer_Generic_Scope
) then
1022 elsif Scope_Depth
(Scope
(E
)) < Scope_Depth
(Outer_Generic_Scope
)
1023 or else not In_Same_Source_Unit
(E
, Outer_Generic_Scope
)
1029 while Present
(Scop
) loop
1030 if Scop
= Outer_Generic_Scope
then
1032 elsif Scope_Depth
(Scop
) < Scope_Depth
(Outer_Generic_Scope
) then
1035 Scop
:= Scope
(Scop
);
1041 end External_Ref_In_Generic
;
1047 procedure Initialize
is
1048 Next
: Suppress_Stack_Entry_Ptr
;
1050 procedure Free
is new Unchecked_Deallocation
1051 (Suppress_Stack_Entry
, Suppress_Stack_Entry_Ptr
);
1054 -- Free any global suppress stack entries from a previous invocation
1055 -- of the compiler (in the normal case this loop does nothing).
1057 while Suppress_Stack_Entries
/= null loop
1058 Next
:= Suppress_Stack_Entries
.Next
;
1059 Free
(Suppress_Stack_Entries
);
1060 Suppress_Stack_Entries
:= Next
;
1063 Local_Suppress_Stack_Top
:= null;
1064 Global_Suppress_Stack_Top
:= null;
1066 -- Clear scope stack, and reset global variables
1069 Unloaded_Subunits
:= False;
1072 ------------------------------
1073 -- Insert_After_And_Analyze --
1074 ------------------------------
1076 procedure Insert_After_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
1082 -- If we are not at the end of the list, then the easiest
1083 -- coding is simply to insert before our successor.
1085 if Present
(Next
(N
)) then
1086 Insert_Before_And_Analyze
(Next
(N
), M
);
1088 -- Case of inserting at the end of the list
1091 -- Capture the Node_Id of the node to be inserted. This Node_Id
1092 -- will still be the same after the insert operation.
1095 Insert_After
(N
, M
);
1097 -- Now just analyze from the inserted node to the end of
1098 -- the new list (note that this properly handles the case
1099 -- where any of the analyze calls result in the insertion of
1100 -- nodes after the analyzed node, expecting analysis).
1102 while Present
(Node
) loop
1104 Mark_Rewrite_Insertion
(Node
);
1109 end Insert_After_And_Analyze
;
1111 -- Version with check(s) suppressed
1113 procedure Insert_After_And_Analyze
1116 Suppress
: Check_Id
)
1119 if Suppress
= All_Checks
then
1121 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1123 Scope_Suppress
.Suppress
:= (others => True);
1124 Insert_After_And_Analyze
(N
, M
);
1125 Scope_Suppress
.Suppress
:= Svs
;
1130 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1132 Scope_Suppress
.Suppress
(Suppress
) := True;
1133 Insert_After_And_Analyze
(N
, M
);
1134 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1137 end Insert_After_And_Analyze
;
1139 -------------------------------
1140 -- Insert_Before_And_Analyze --
1141 -------------------------------
1143 procedure Insert_Before_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
1149 -- Capture the Node_Id of the first list node to be inserted.
1150 -- This will still be the first node after the insert operation,
1151 -- since Insert_List_After does not modify the Node_Id values.
1154 Insert_Before
(N
, M
);
1156 -- The insertion does not change the Id's of any of the nodes in
1157 -- the list, and they are still linked, so we can simply loop from
1158 -- the original first node until we meet the node before which the
1159 -- insertion is occurring. Note that this properly handles the case
1160 -- where any of the analyzed nodes insert nodes after themselves,
1161 -- expecting them to get analyzed.
1163 while Node
/= N
loop
1165 Mark_Rewrite_Insertion
(Node
);
1169 end Insert_Before_And_Analyze
;
1171 -- Version with check(s) suppressed
1173 procedure Insert_Before_And_Analyze
1176 Suppress
: Check_Id
)
1179 if Suppress
= All_Checks
then
1181 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1183 Scope_Suppress
.Suppress
:= (others => True);
1184 Insert_Before_And_Analyze
(N
, M
);
1185 Scope_Suppress
.Suppress
:= Svs
;
1190 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1192 Scope_Suppress
.Suppress
(Suppress
) := True;
1193 Insert_Before_And_Analyze
(N
, M
);
1194 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1197 end Insert_Before_And_Analyze
;
1199 -----------------------------------
1200 -- Insert_List_After_And_Analyze --
1201 -----------------------------------
1203 procedure Insert_List_After_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1204 After
: constant Node_Id
:= Next
(N
);
1208 if Is_Non_Empty_List
(L
) then
1210 -- Capture the Node_Id of the first list node to be inserted.
1211 -- This will still be the first node after the insert operation,
1212 -- since Insert_List_After does not modify the Node_Id values.
1215 Insert_List_After
(N
, L
);
1217 -- Now just analyze from the original first node until we get to the
1218 -- successor of the original insertion point (which may be Empty if
1219 -- the insertion point was at the end of the list). Note that this
1220 -- properly handles the case where any of the analyze calls result in
1221 -- the insertion of nodes after the analyzed node (possibly calling
1222 -- this routine recursively).
1224 while Node
/= After
loop
1226 Mark_Rewrite_Insertion
(Node
);
1230 end Insert_List_After_And_Analyze
;
1232 ------------------------------------
1233 -- Insert_List_Before_And_Analyze --
1234 ------------------------------------
1236 procedure Insert_List_Before_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1240 if Is_Non_Empty_List
(L
) then
1242 -- Capture the Node_Id of the first list node to be inserted. This
1243 -- will still be the first node after the insert operation, since
1244 -- Insert_List_After does not modify the Node_Id values.
1247 Insert_List_Before
(N
, L
);
1249 -- The insertion does not change the Id's of any of the nodes in
1250 -- the list, and they are still linked, so we can simply loop from
1251 -- the original first node until we meet the node before which the
1252 -- insertion is occurring. Note that this properly handles the case
1253 -- where any of the analyzed nodes insert nodes after themselves,
1254 -- expecting them to get analyzed.
1256 while Node
/= N
loop
1258 Mark_Rewrite_Insertion
(Node
);
1262 end Insert_List_Before_And_Analyze
;
1270 Scope_Stack
.Release
;
1271 Scope_Stack
.Locked
:= True;
1274 ------------------------
1275 -- Preanalysis_Active --
1276 ------------------------
1278 function Preanalysis_Active
return Boolean is
1280 return not Full_Analysis
and not Expander_Active
;
1281 end Preanalysis_Active
;
1287 procedure Preanalyze
(N
: Node_Id
) is
1288 Save_Full_Analysis
: constant Boolean := Full_Analysis
;
1291 Full_Analysis
:= False;
1292 Expander_Mode_Save_And_Set
(False);
1296 Expander_Mode_Restore
;
1297 Full_Analysis
:= Save_Full_Analysis
;
1300 --------------------------------------
1301 -- Push_Global_Suppress_Stack_Entry --
1302 --------------------------------------
1304 procedure Push_Global_Suppress_Stack_Entry
1305 (Entity
: Entity_Id
;
1310 Global_Suppress_Stack_Top
:=
1311 new Suppress_Stack_Entry
'
1314 Suppress => Suppress,
1315 Prev => Global_Suppress_Stack_Top,
1316 Next => Suppress_Stack_Entries);
1317 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1319 end Push_Global_Suppress_Stack_Entry;
1321 -------------------------------------
1322 -- Push_Local_Suppress_Stack_Entry --
1323 -------------------------------------
1325 procedure Push_Local_Suppress_Stack_Entry
1326 (Entity : Entity_Id;
1331 Local_Suppress_Stack_Top :=
1332 new Suppress_Stack_Entry'
1335 Suppress
=> Suppress
,
1336 Prev
=> Local_Suppress_Stack_Top
,
1337 Next
=> Suppress_Stack_Entries
);
1338 Suppress_Stack_Entries
:= Local_Suppress_Stack_Top
;
1341 end Push_Local_Suppress_Stack_Entry
;
1347 procedure Semantics
(Comp_Unit
: Node_Id
) is
1348 procedure Do_Analyze
;
1349 -- Perform the analysis of the compilation unit
1355 -- WARNING: This routine manages Ghost regions. Return statements must
1356 -- be replaced by gotos which jump to the end of the routine and restore
1359 procedure Do_Analyze
is
1360 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1362 -- Generally style checks are preserved across compilations, with
1363 -- one exception: s-oscons.ads, which allows arbitrary long lines
1364 -- unconditionally, and has no restore mechanism, because it is
1365 -- intended as a lowest-level Pure package.
1367 Save_Max_Line
: constant Int
:= Style_Max_Line_Length
;
1372 List
:= Save_Scope_Stack
;
1373 Push_Scope
(Standard_Standard
);
1375 -- Set up a clean environment before analyzing
1377 Install_Ghost_Mode
(None
);
1378 Outer_Generic_Scope
:= Empty
;
1379 Scope_Suppress
:= Suppress_Options
;
1381 (Scope_Stack
.Last
).Component_Alignment_Default
:=
1382 Configuration_Component_Alignment
;
1384 (Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
1386 -- Now analyze the top level compilation unit node
1388 Analyze
(Comp_Unit
);
1390 -- Check for scope mismatch on exit from compilation
1392 pragma Assert
(Current_Scope
= Standard_Standard
1393 or else Comp_Unit
= Cunit
(Main_Unit
));
1395 -- Then pop entry for Standard, and pop implicit types
1398 Restore_Scope_Stack
(List
);
1399 Restore_Ghost_Mode
(Save_Ghost_Mode
);
1400 Style_Max_Line_Length
:= Save_Max_Line
;
1405 -- The following locations save the corresponding global flags and
1406 -- variables so that they can be restored on completion. This is needed
1407 -- so that calls to Rtsfind start with the proper default values for
1408 -- these variables, and also that such calls do not disturb the settings
1409 -- for units being analyzed at a higher level.
1411 S_Current_Sem_Unit
: constant Unit_Number_Type
:= Current_Sem_Unit
;
1412 S_Full_Analysis
: constant Boolean := Full_Analysis
;
1413 S_GNAT_Mode
: constant Boolean := GNAT_Mode
;
1414 S_Global_Dis_Names
: constant Boolean := Global_Discard_Names
;
1415 S_In_Assertion_Expr
: constant Nat
:= In_Assertion_Expr
;
1416 S_In_Default_Expr
: constant Boolean := In_Default_Expr
;
1417 S_In_Spec_Expr
: constant Boolean := In_Spec_Expression
;
1418 S_Inside_A_Generic
: constant Boolean := Inside_A_Generic
;
1419 S_Outer_Gen_Scope
: constant Entity_Id
:= Outer_Generic_Scope
;
1420 S_Style_Check
: constant Boolean := Style_Check
;
1422 Already_Analyzed
: constant Boolean := Analyzed
(Comp_Unit
);
1424 Curunit
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(Comp_Unit
);
1425 -- New value of Current_Sem_Unit
1427 Generic_Main
: constant Boolean :=
1428 Nkind
(Unit
(Cunit
(Main_Unit
))) in N_Generic_Declaration
;
1429 -- If the main unit is generic, every compiled unit, including its
1430 -- context, is compiled with expansion disabled.
1432 Is_Main_Unit_Or_Main_Unit_Spec
: constant Boolean :=
1435 (Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
1436 and then Library_Unit
(Cunit
(Main_Unit
)) = Cunit
(Curunit
));
1437 -- Configuration flags have special settings when compiling a predefined
1438 -- file as a main unit. This applies to its spec as well.
1440 Ext_Main_Source_Unit
: constant Boolean :=
1441 In_Extended_Main_Source_Unit
(Comp_Unit
);
1442 -- Determine if unit is in extended main source unit
1444 Save_Config_Switches
: Config_Switches_Type
;
1445 -- Variable used to save values of config switches while we analyze the
1446 -- new unit, to be restored on exit for proper recursive behavior.
1448 Save_Cunit_Restrictions
: Save_Cunit_Boolean_Restrictions
;
1449 -- Used to save non-partition wide restrictions before processing new
1450 -- unit. All with'ed units are analyzed with config restrictions reset
1451 -- and we need to restore these saved values at the end.
1453 -- Start of processing for Semantics
1456 if Debug_Unit_Walk
then
1457 if Already_Analyzed
then
1458 Write_Str
("(done)");
1462 (Get_Cunit_Unit_Number
(Comp_Unit
),
1468 Compiler_State
:= Analyzing
;
1469 Current_Sem_Unit
:= Curunit
;
1471 -- Compile predefined units with GNAT_Mode set to True, to properly
1472 -- process the categorization stuff. However, do not set GNAT_Mode
1473 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1474 -- Sequential_IO) as this would prevent pragma Extend_System from being
1475 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1477 if Is_Predefined_Unit
(Current_Sem_Unit
)
1478 and then not Is_Predefined_Renaming
(Current_Sem_Unit
)
1483 -- For generic main, never do expansion
1485 if Generic_Main
then
1486 Expander_Mode_Save_And_Set
(False);
1491 Expander_Mode_Save_And_Set
1493 -- Turn on expansion if generating code
1495 (Operating_Mode
= Generate_Code
1497 -- Or if special debug flag -gnatdx is set
1499 or else Debug_Flag_X
1501 -- Or if in configuration run-time mode. We do this so we get
1502 -- error messages about missing entities in the run-time even
1503 -- if we are compiling in -gnatc (no code generation) mode.
1504 -- Similar processing applies to No_Run_Time_Mode. However,
1505 -- don't do this if debug flag -gnatd.Z is set or when we are
1506 -- compiling a separate unit (this is to handle a situation
1507 -- where this new processing causes trouble).
1510 ((Configurable_Run_Time_Mode
or No_Run_Time_Mode
)
1511 and then not Debug_Flag_Dot_ZZ
1512 and then Nkind
(Unit
(Cunit
(Main_Unit
))) /= N_Subunit
));
1515 Full_Analysis
:= True;
1516 Inside_A_Generic
:= False;
1517 In_Assertion_Expr
:= 0;
1518 In_Default_Expr
:= False;
1519 In_Spec_Expression
:= False;
1520 Set_Comes_From_Source_Default
(False);
1522 -- Save current config switches and reset then appropriately
1524 Save_Opt_Config_Switches
(Save_Config_Switches
);
1525 Set_Opt_Config_Switches
1526 (Is_Internal_Unit
(Current_Sem_Unit
),
1527 Is_Main_Unit_Or_Main_Unit_Spec
);
1529 -- Save current non-partition-wide restrictions
1531 Save_Cunit_Restrictions
:= Cunit_Boolean_Restrictions_Save
;
1533 -- For unit in main extended unit, we reset the configuration values
1534 -- for the non-partition-wide restrictions. For other units reset them.
1536 if Ext_Main_Source_Unit
then
1537 Restore_Config_Cunit_Boolean_Restrictions
;
1539 Reset_Cunit_Boolean_Restrictions
;
1542 -- Turn off style checks for unit that is not in the extended main
1543 -- source unit. This improves processing efficiency for such units
1544 -- (for which we don't want style checks anyway, and where they will
1545 -- get suppressed), and is definitely needed to stop some style checks
1546 -- from invading the run-time units (e.g. overriding checks).
1548 if not Ext_Main_Source_Unit
then
1549 Style_Check
:= False;
1551 -- If this is part of the extended main source unit, set style check
1552 -- mode to match the style check mode of the main source unit itself.
1555 Style_Check
:= Style_Check_Main
;
1558 -- Only do analysis of unit that has not already been analyzed
1560 if not Analyzed
(Comp_Unit
) then
1561 Initialize_Version
(Current_Sem_Unit
);
1563 -- Do analysis, and then append the compilation unit onto the
1564 -- Comp_Unit_List, if appropriate. This is done after analysis,
1565 -- so if this unit depends on some others, they have already been
1566 -- appended. We ignore bodies, except for the main unit itself, and
1567 -- for subprogram bodies that act as specs. We have also to guard
1568 -- against ill-formed subunits that have an improper context.
1572 if Present
(Comp_Unit
)
1573 and then Nkind
(Unit
(Comp_Unit
)) in N_Proper_Body
1574 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Subprogram_Body
1575 or else not Acts_As_Spec
(Comp_Unit
))
1576 and then not In_Extended_Main_Source_Unit
(Comp_Unit
)
1581 Append_New_Elmt
(Comp_Unit
, To
=> Comp_Unit_List
);
1583 if Debug_Unit_Walk
then
1584 Write_Str
("Appending ");
1586 (Get_Cunit_Unit_Number
(Comp_Unit
), Unit
(Comp_Unit
));
1591 -- Save indication of dynamic elaboration checks for ALI file
1593 Set_Dynamic_Elab
(Current_Sem_Unit
, Dynamic_Elaboration_Checks
);
1595 -- Restore settings of saved switches to entry values
1597 Current_Sem_Unit
:= S_Current_Sem_Unit
;
1598 Full_Analysis
:= S_Full_Analysis
;
1599 Global_Discard_Names
:= S_Global_Dis_Names
;
1600 GNAT_Mode
:= S_GNAT_Mode
;
1601 In_Assertion_Expr
:= S_In_Assertion_Expr
;
1602 In_Default_Expr
:= S_In_Default_Expr
;
1603 In_Spec_Expression
:= S_In_Spec_Expr
;
1604 Inside_A_Generic
:= S_Inside_A_Generic
;
1605 Outer_Generic_Scope
:= S_Outer_Gen_Scope
;
1606 Style_Check
:= S_Style_Check
;
1608 Restore_Opt_Config_Switches
(Save_Config_Switches
);
1610 -- Deal with restore of restrictions
1612 Cunit_Boolean_Restrictions_Restore
(Save_Cunit_Restrictions
);
1614 Expander_Mode_Restore
;
1616 if Debug_Unit_Walk
then
1619 if Already_Analyzed
then
1620 Write_Str
("(done)");
1624 (Get_Cunit_Unit_Number
(Comp_Unit
),
1634 function ss
(Index
: Int
) return Scope_Stack_Entry
is
1636 return Scope_Stack
.Table
(Index
);
1643 function sst
return Scope_Stack_Entry
is
1645 return ss
(Scope_Stack
.Last
);
1654 Scope_Stack
.Locked
:= False;
1657 ------------------------
1658 -- Walk_Library_Items --
1659 ------------------------
1661 procedure Walk_Library_Items
is
1662 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
1663 pragma Pack
(Unit_Number_Set
);
1665 Main_CU
: constant Node_Id
:= Cunit
(Main_Unit
);
1667 Seen
, Done
: Unit_Number_Set
:= (others => False);
1668 -- Seen (X) is True after we have seen unit X in the walk. This is used
1669 -- to prevent processing the same unit more than once. Done (X) is True
1670 -- after we have fully processed X, and is used only for debugging
1671 -- printouts and assertions.
1673 Do_Main
: Boolean := False;
1674 -- Flag to delay processing the main body until after all other units.
1675 -- This is needed because the spec of the main unit may appear in the
1676 -- context of some other unit. We do not want this to force processing
1677 -- of the main body before all other units have been processed.
1679 -- Another circularity pattern occurs when the main unit is a child unit
1680 -- and the body of an ancestor has a with-clause of the main unit or on
1681 -- one of its children. In both cases the body in question has a with-
1682 -- clause on the main unit, and must be excluded from the traversal. In
1683 -- some convoluted cases this may lead to a CodePeer error because the
1684 -- spec of a subprogram declared in an instance within the parent will
1685 -- not be seen in the main unit.
1687 function Depends_On_Main
(CU
: Node_Id
) return Boolean;
1688 -- The body of a unit that is withed by the spec of the main unit may in
1689 -- turn have a with_clause on that spec. In that case do not traverse
1690 -- the body, to prevent loops. It can also happen that the main body has
1691 -- a with_clause on a child, which of course has an implicit with on its
1692 -- parent. It's OK to traverse the child body if the main spec has been
1693 -- processed, otherwise we also have a circularity to avoid.
1695 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
);
1696 -- Calls Action, with some validity checks
1698 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
);
1699 -- Calls Do_Action, first on the units with'ed by this one, then on
1700 -- this unit. If it's an instance body, do the spec first. If it is
1701 -- an instance spec, do the body last.
1703 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
);
1704 -- Apply Do_Unit_And_Dependents to a unit in a context clause
1706 procedure Process_Bodies_In_Context
(Comp
: Node_Id
);
1707 -- The main unit and its spec may depend on bodies that contain generics
1708 -- that are instantiated in them. Iterate through the corresponding
1709 -- contexts before processing main (spec/body) itself, to process bodies
1710 -- that may be present, together with their context. The spec of main
1711 -- is processed wherever it appears in the list of units, while the body
1712 -- is processed as the last unit in the list.
1714 ---------------------
1715 -- Depends_On_Main --
1716 ---------------------
1718 function Depends_On_Main
(CU
: Node_Id
) return Boolean is
1720 MCU
: constant Node_Id
:= Unit
(Main_CU
);
1723 CL
:= First
(Context_Items
(CU
));
1725 -- Problem does not arise with main subprograms
1728 not Nkind_In
(MCU
, N_Package_Body
, N_Package_Declaration
)
1733 while Present
(CL
) loop
1734 if Nkind
(CL
) = N_With_Clause
1735 and then Library_Unit
(CL
) = Main_CU
1736 and then not Done
(Get_Cunit_Unit_Number
(Library_Unit
(CL
)))
1745 end Depends_On_Main
;
1751 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
) is
1753 -- This calls Action at the end. All the preceding code is just
1754 -- assertions and debugging output.
1756 pragma Assert
(No
(CU
) or else Nkind
(CU
) = N_Compilation_Unit
);
1758 case Nkind
(Item
) is
1759 when N_Generic_Function_Renaming_Declaration
1760 | N_Generic_Package_Declaration
1761 | N_Generic_Package_Renaming_Declaration
1762 | N_Generic_Procedure_Renaming_Declaration
1763 | N_Generic_Subprogram_Declaration
1764 | N_Package_Declaration
1765 | N_Package_Renaming_Declaration
1766 | N_Subprogram_Declaration
1767 | N_Subprogram_Renaming_Declaration
1773 when N_Package_Body
=>
1775 -- Package bodies are processed separately if the main unit
1780 when N_Subprogram_Body
=>
1782 -- A subprogram body must be the main unit
1784 pragma Assert
(Acts_As_Spec
(CU
)
1785 or else CU
= Cunit
(Main_Unit
));
1788 when N_Function_Instantiation
1789 | N_Package_Instantiation
1790 | N_Procedure_Instantiation
1792 -- Can only happen if some generic body (needed for gnat2scil
1793 -- traversal, but not by GNAT) is not available, ignore.
1797 -- All other cases cannot happen
1800 pragma Assert
(False, "subunit");
1803 when N_Null_Statement
=>
1805 -- Do not call Action for an ignored ghost unit
1807 pragma Assert
(Is_Ignored_Ghost_Node
(Original_Node
(Item
)));
1811 pragma Assert
(False);
1815 if Present
(CU
) then
1816 pragma Assert
(Item
/= Stand
.Standard_Package_Node
);
1817 pragma Assert
(Item
= Unit
(CU
));
1820 Unit_Num
: constant Unit_Number_Type
:=
1821 Get_Cunit_Unit_Number
(CU
);
1823 procedure Assert_Done
(Withed_Unit
: Node_Id
);
1824 -- Assert Withed_Unit is already Done, unless it's a body. It
1825 -- might seem strange for a with_clause to refer to a body, but
1826 -- this happens in the case of a generic instantiation, which
1827 -- gets transformed into the instance body (and the instance
1828 -- spec is also created). With clauses pointing to the
1829 -- instantiation end up pointing to the instance body.
1835 procedure Assert_Done
(Withed_Unit
: Node_Id
) is
1837 if not Done
(Get_Cunit_Unit_Number
(Withed_Unit
)) then
1839 (Unit
(Withed_Unit
),
1840 N_Generic_Package_Declaration
,
1842 N_Package_Renaming_Declaration
,
1846 (Unit_Name
(Get_Cunit_Unit_Number
(Withed_Unit
)));
1847 Write_Str
(" not yet walked!");
1849 if Get_Cunit_Unit_Number
(Withed_Unit
) = Unit_Num
then
1850 Write_Str
(" (self-ref)");
1855 pragma Assert
(False);
1860 procedure Assert_Withed_Units_Done
is
1861 new Walk_Withs
(Assert_Done
);
1864 if Debug_Unit_Walk
then
1865 Write_Unit_Info
(Unit_Num
, Item
, Withs
=> True);
1868 -- Main unit should come last, except in the case where we
1869 -- skipped System_Aux_Id, in which case we missed the things it
1870 -- depends on, and in the case of parent bodies if present.
1873 (not Done
(Main_Unit
)
1874 or else Present
(System_Aux_Id
)
1875 or else Nkind
(Item
) = N_Package_Body
);
1877 -- We shouldn't do the same thing twice
1879 pragma Assert
(not Done
(Unit_Num
));
1881 -- Everything we depend upon should already be done
1884 (Assert_Withed_Units_Done
(CU
, Include_Limited
=> False));
1888 -- Must be Standard, which has no entry in the units table
1890 pragma Assert
(Item
= Stand
.Standard_Package_Node
);
1892 if Debug_Unit_Walk
then
1893 Write_Line
("Standard");
1900 --------------------
1901 -- Do_Withed_Unit --
1902 --------------------
1904 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
) is
1906 Do_Unit_And_Dependents
(Withed_Unit
, Unit
(Withed_Unit
));
1908 -- If the unit in the with_clause is a generic instance, the clause
1909 -- now denotes the instance body. Traverse the corresponding spec
1910 -- because there may be no other dependence that will force the
1911 -- traversal of its own context.
1913 if Nkind
(Unit
(Withed_Unit
)) = N_Package_Body
1914 and then Is_Generic_Instance
1915 (Defining_Entity
(Unit
(Library_Unit
(Withed_Unit
))))
1917 Do_Withed_Unit
(Library_Unit
(Withed_Unit
));
1921 ----------------------------
1922 -- Do_Unit_And_Dependents --
1923 ----------------------------
1925 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
) is
1926 Unit_Num
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(CU
);
1928 Body_U
: Unit_Number_Type
;
1929 Parent_CU
: Node_Id
;
1931 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
1934 if not Seen
(Unit_Num
) then
1936 -- Process the with clauses
1938 Do_Withed_Units
(CU
, Include_Limited
=> False);
1940 -- Process the unit if it is a spec or the main unit, if it
1941 -- has no previous spec or we have done all other units.
1943 if not Nkind_In
(Item
, N_Package_Body
, N_Subprogram_Body
)
1944 or else Acts_As_Spec
(CU
)
1946 if CU
= Cunit
(Main_Unit
)
1947 and then not Do_Main
1949 Seen
(Unit_Num
) := False;
1952 Seen
(Unit_Num
) := True;
1954 if CU
= Library_Unit
(Main_CU
) then
1955 Process_Bodies_In_Context
(CU
);
1957 -- If main is a child unit, examine parent unit contexts
1958 -- to see if they include instantiated units. Also, if
1959 -- the parent itself is an instance, process its body
1960 -- because it may contain subprograms that are called
1961 -- in the main unit.
1963 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
1964 Child
:= Cunit_Entity
(Main_Unit
);
1965 while Is_Child_Unit
(Child
) loop
1968 (Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
1969 Process_Bodies_In_Context
(Parent_CU
);
1971 if Nkind
(Unit
(Parent_CU
)) = N_Package_Body
1973 Nkind
(Original_Node
(Unit
(Parent_CU
)))
1974 = N_Package_Instantiation
1976 not Seen
(Get_Cunit_Unit_Number
(Parent_CU
))
1978 Body_U
:= Get_Cunit_Unit_Number
(Parent_CU
);
1979 Seen
(Body_U
) := True;
1980 Do_Action
(Parent_CU
, Unit
(Parent_CU
));
1981 Done
(Body_U
) := True;
1984 Child
:= Scope
(Child
);
1989 Do_Action
(CU
, Item
);
1990 Done
(Unit_Num
) := True;
1994 end Do_Unit_And_Dependents
;
1996 -------------------------------
1997 -- Process_Bodies_In_Context --
1998 -------------------------------
2000 procedure Process_Bodies_In_Context
(Comp
: Node_Id
) is
2002 Body_U
: Unit_Number_Type
;
2006 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
2008 -- Start of processing for Process_Bodies_In_Context
2011 Clause
:= First
(Context_Items
(Comp
));
2012 while Present
(Clause
) loop
2013 if Nkind
(Clause
) = N_With_Clause
then
2014 Spec
:= Library_Unit
(Clause
);
2015 Body_CU
:= Library_Unit
(Spec
);
2017 -- If we are processing the spec of the main unit, load bodies
2018 -- only if the with_clause indicates that it forced the loading
2019 -- of the body for a generic instantiation. Note that bodies of
2020 -- parents that are instances have been loaded already.
2022 if Present
(Body_CU
)
2023 and then Body_CU
/= Cunit
(Main_Unit
)
2024 and then Nkind
(Unit
(Body_CU
)) /= N_Subprogram_Body
2025 and then (Nkind
(Unit
(Comp
)) /= N_Package_Declaration
2026 or else Present
(Withed_Body
(Clause
)))
2028 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
2030 if not Seen
(Body_U
)
2031 and then not Depends_On_Main
(Body_CU
)
2033 Seen
(Body_U
) := True;
2034 Do_Withed_Units
(Body_CU
, Include_Limited
=> False);
2035 Do_Action
(Body_CU
, Unit
(Body_CU
));
2036 Done
(Body_U
) := True;
2043 end Process_Bodies_In_Context
;
2045 -- Local Declarations
2049 -- Start of processing for Walk_Library_Items
2052 if Debug_Unit_Walk
then
2053 Write_Line
("Walk_Library_Items:");
2057 -- Do Standard first, then walk the Comp_Unit_List
2059 Do_Action
(Empty
, Standard_Package_Node
);
2061 -- First place the context of all instance bodies on the corresponding
2062 -- spec, because it may be needed to analyze the code at the place of
2063 -- the instantiation.
2065 Cur
:= First_Elmt
(Comp_Unit_List
);
2066 while Present
(Cur
) loop
2068 CU
: constant Node_Id
:= Node
(Cur
);
2069 N
: constant Node_Id
:= Unit
(CU
);
2072 if Nkind
(N
) = N_Package_Body
2073 and then Is_Generic_Instance
(Defining_Entity
(N
))
2076 (Context_Items
(CU
), Context_Items
(Library_Unit
(CU
)));
2083 -- Now traverse compilation units (specs) in order
2085 Cur
:= First_Elmt
(Comp_Unit_List
);
2086 while Present
(Cur
) loop
2088 CU
: constant Node_Id
:= Node
(Cur
);
2089 N
: constant Node_Id
:= Unit
(CU
);
2093 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2097 -- If it is a subprogram body, process it if it has no
2100 -- If it's a package body, ignore it, unless it is a body
2101 -- created for an instance that is the main unit. In the case
2102 -- of subprograms, the body is the wrapper package. In case of
2103 -- a package, the original file carries the body, and the spec
2104 -- appears as a later entry in the units list.
2106 -- Otherwise bodies appear in the list only because of inlining
2107 -- or instantiations, and they are processed only if relevant.
2108 -- The flag Withed_Body on a context clause indicates that a
2109 -- unit contains an instantiation that may be needed later,
2110 -- and therefore the body that contains the generic body (and
2111 -- its context) must be traversed immediately after the
2112 -- corresponding spec (see Do_Unit_And_Dependents).
2114 -- The main unit itself is processed separately after all other
2115 -- specs, and relevant bodies are examined in Process_Main.
2117 when N_Subprogram_Body
=>
2118 if Acts_As_Spec
(N
) then
2119 Do_Unit_And_Dependents
(CU
, N
);
2122 when N_Package_Body
=>
2124 and then Nkind
(Original_Node
(Unit
(Main_CU
))) in
2125 N_Generic_Instantiation
2126 and then Present
(Library_Unit
(Main_CU
))
2128 Do_Unit_And_Dependents
2129 (Library_Unit
(Main_CU
),
2130 Unit
(Library_Unit
(Main_CU
)));
2133 -- It is a spec, process it, and the units it depends on,
2134 -- unless it is a descendant of the main unit. This can happen
2135 -- when the body of a parent depends on some other descendant.
2137 when N_Null_Statement
=>
2139 -- Ignore an ignored ghost unit
2141 pragma Assert
(Is_Ignored_Ghost_Node
(Original_Node
(N
)));
2145 Par
:= Scope
(Defining_Entity
(Unit
(CU
)));
2147 if Is_Child_Unit
(Defining_Entity
(Unit
(CU
))) then
2149 and then Par
/= Standard_Standard
2150 and then Par
/= Cunit_Entity
(Main_Unit
)
2156 if Par
/= Cunit_Entity
(Main_Unit
) then
2157 Do_Unit_And_Dependents
(CU
, N
);
2165 -- Now process package bodies on which main depends, followed by bodies
2166 -- of parents, if present, and finally main itself.
2168 if not Done
(Main_Unit
) then
2171 Process_Main
: declare
2172 Parent_CU
: Node_Id
;
2174 Body_U
: Unit_Number_Type
;
2177 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean;
2178 -- If the main unit has subunits, their context may include
2179 -- bodies that are needed in the body of main. We must examine
2180 -- the context of the subunits, which are otherwise not made
2181 -- explicit in the main unit.
2183 ------------------------
2184 -- Is_Subunit_Of_Main --
2185 ------------------------
2187 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean is
2193 Lib
:= Library_Unit
(U
);
2194 return Nkind
(Unit
(U
)) = N_Subunit
2196 (Lib
= Cunit
(Main_Unit
)
2197 or else Is_Subunit_Of_Main
(Lib
));
2199 end Is_Subunit_Of_Main
;
2201 -- Start of processing for Process_Main
2204 Process_Bodies_In_Context
(Main_CU
);
2206 for Unit_Num
in Done
'Range loop
2207 if Is_Subunit_Of_Main
(Cunit
(Unit_Num
)) then
2208 Process_Bodies_In_Context
(Cunit
(Unit_Num
));
2212 -- If the main unit is a child unit, parent bodies may be present
2213 -- because they export instances or inlined subprograms. Check for
2214 -- presence of these, which are not present in context clauses.
2215 -- Note that if the parents are instances, their bodies have been
2216 -- processed before the main spec, because they may be needed
2217 -- therein, so the following loop only affects non-instances.
2219 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
2220 Child
:= Cunit_Entity
(Main_Unit
);
2221 while Is_Child_Unit
(Child
) loop
2223 Cunit
(Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
2224 Body_CU
:= Library_Unit
(Parent_CU
);
2226 if Present
(Body_CU
)
2227 and then not Seen
(Get_Cunit_Unit_Number
(Body_CU
))
2228 and then not Depends_On_Main
(Body_CU
)
2230 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
2231 Seen
(Body_U
) := True;
2232 Do_Action
(Body_CU
, Unit
(Body_CU
));
2233 Done
(Body_U
) := True;
2236 Child
:= Scope
(Child
);
2240 Do_Action
(Main_CU
, Unit
(Main_CU
));
2241 Done
(Main_Unit
) := True;
2245 if Debug_Unit_Walk
then
2246 if Done
/= (Done
'Range => True) then
2248 Write_Line
("Ignored units:");
2252 for Unit_Num
in Done
'Range loop
2253 if not Done
(Unit_Num
) then
2255 (Unit_Num
, Unit
(Cunit
(Unit_Num
)), Withs
=> True);
2263 pragma Assert
(Done
(Main_Unit
));
2265 if Debug_Unit_Walk
then
2267 Write_Line
("end Walk_Library_Items.");
2269 end Walk_Library_Items
;
2275 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean) is
2276 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2277 pragma Assert
(Nkind
(Unit
(CU
)) /= N_Subunit
);
2279 procedure Walk_Immediate
is new Walk_Withs_Immediate
(Action
);
2282 -- First walk the withs immediately on the library item
2284 Walk_Immediate
(CU
, Include_Limited
);
2286 -- For a body, we must also check for any subunits which belong to it
2287 -- and which have context clauses of their own, since these with'ed
2288 -- units are part of its own dependencies.
2290 if Nkind
(Unit
(CU
)) in N_Unit_Body
then
2291 for S
in Main_Unit
.. Last_Unit
loop
2293 -- We are only interested in subunits. For preproc. data and def.
2294 -- files, Cunit is Empty, so we need to test that first.
2296 if Cunit
(S
) /= Empty
2297 and then Nkind
(Unit
(Cunit
(S
))) = N_Subunit
2303 Pnode
:= Library_Unit
(Cunit
(S
));
2305 -- In -gnatc mode, the errors in the subunits will not have
2306 -- been recorded, but the analysis of the subunit may have
2307 -- failed, so just quit.
2313 -- Find ultimate parent of the subunit
2315 while Nkind
(Unit
(Pnode
)) = N_Subunit
loop
2316 Pnode
:= Library_Unit
(Pnode
);
2319 -- See if it belongs to current unit, and if so, include its
2320 -- with_clauses. Do not process main unit prematurely.
2322 if Pnode
= CU
and then CU
/= Cunit
(Main_Unit
) then
2323 Walk_Immediate
(Cunit
(S
), Include_Limited
);
2331 --------------------------
2332 -- Walk_Withs_Immediate --
2333 --------------------------
2335 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean) is
2336 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2338 Context_Item
: Node_Id
;
2343 Context_Item
:= First
(Context_Items
(CU
));
2344 while Present
(Context_Item
) loop
2345 if Nkind
(Context_Item
) = N_With_Clause
2346 and then (Include_Limited
2347 or else not Limited_Present
(Context_Item
))
2349 Lib_Unit
:= Library_Unit
(Context_Item
);
2352 -- If the context item indicates that a package body is needed
2353 -- because of an instantiation in CU, traverse the body now, even
2354 -- if CU is not related to the main unit. If the generic itself
2355 -- appears in a package body, the context item is this body, and
2356 -- it already appears in the traversal order, so we only need to
2357 -- examine the case of a context item being a package declaration.
2359 if Present
(Withed_Body
(Context_Item
))
2360 and then Nkind
(Unit
(Lib_Unit
)) = N_Package_Declaration
2361 and then Present
(Corresponding_Body
(Unit
(Lib_Unit
)))
2365 (Unit_Declaration_Node
2366 (Corresponding_Body
(Unit
(Lib_Unit
))));
2368 -- A body may have an implicit with on its own spec, in which
2369 -- case we must ignore this context item to prevent looping.
2371 if Unit
(CU
) /= Unit
(Body_CU
) then
2377 Context_Item
:= Next
(Context_Item
);
2379 end Walk_Withs_Immediate
;