1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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 Expander
; use Expander
;
31 with Fname
; use Fname
;
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 procedure Analyze
(N
: Node_Id
) is
100 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
103 Debug_A_Entry
("analyzing ", N
);
105 -- Immediate return if already analyzed
108 Debug_A_Exit
("analyzing ", N
, " (done, analyzed already)");
112 -- A declaration may be subject to pragma Ghost. Set the mode now to
113 -- ensure that any nodes generated during analysis and expansion are
116 if Is_Declaration
(N
) then
120 -- Otherwise processing depends on the node kind
123 when N_Abort_Statement
=>
124 Analyze_Abort_Statement
(N
);
126 when N_Abstract_Subprogram_Declaration
=>
127 Analyze_Abstract_Subprogram_Declaration
(N
);
129 when N_Accept_Alternative
=>
130 Analyze_Accept_Alternative
(N
);
132 when N_Accept_Statement
=>
133 Analyze_Accept_Statement
(N
);
136 Analyze_Aggregate
(N
);
139 Analyze_Allocator
(N
);
142 Analyze_Short_Circuit
(N
);
144 when N_Assignment_Statement
=>
145 Analyze_Assignment
(N
);
147 when N_Asynchronous_Select
=>
148 Analyze_Asynchronous_Select
(N
);
151 Analyze_At_Clause
(N
);
153 when N_Attribute_Reference
=>
154 Analyze_Attribute
(N
);
156 when N_Attribute_Definition_Clause
=>
157 Analyze_Attribute_Definition_Clause
(N
);
159 when N_Block_Statement
=>
160 Analyze_Block_Statement
(N
);
162 when N_Case_Expression
=>
163 Analyze_Case_Expression
(N
);
165 when N_Case_Statement
=>
166 Analyze_Case_Statement
(N
);
168 when N_Character_Literal
=>
169 Analyze_Character_Literal
(N
);
171 when N_Code_Statement
=>
172 Analyze_Code_Statement
(N
);
174 when N_Compilation_Unit
=>
175 Analyze_Compilation_Unit
(N
);
177 when N_Component_Declaration
=>
178 Analyze_Component_Declaration
(N
);
180 when N_Compound_Statement
=>
181 Analyze_Compound_Statement
(N
);
183 when N_Conditional_Entry_Call
=>
184 Analyze_Conditional_Entry_Call
(N
);
186 when N_Delay_Alternative
=>
187 Analyze_Delay_Alternative
(N
);
189 when N_Delay_Relative_Statement
=>
190 Analyze_Delay_Relative
(N
);
192 when N_Delay_Until_Statement
=>
193 Analyze_Delay_Until
(N
);
196 Analyze_Entry_Body
(N
);
198 when N_Entry_Body_Formal_Part
=>
199 Analyze_Entry_Body_Formal_Part
(N
);
201 when N_Entry_Call_Alternative
=>
202 Analyze_Entry_Call_Alternative
(N
);
204 when N_Entry_Declaration
=>
205 Analyze_Entry_Declaration
(N
);
207 when N_Entry_Index_Specification
=>
208 Analyze_Entry_Index_Specification
(N
);
210 when N_Enumeration_Representation_Clause
=>
211 Analyze_Enumeration_Representation_Clause
(N
);
213 when N_Exception_Declaration
=>
214 Analyze_Exception_Declaration
(N
);
216 when N_Exception_Renaming_Declaration
=>
217 Analyze_Exception_Renaming
(N
);
219 when N_Exit_Statement
=>
220 Analyze_Exit_Statement
(N
);
222 when N_Expanded_Name
=>
223 Analyze_Expanded_Name
(N
);
225 when N_Explicit_Dereference
=>
226 Analyze_Explicit_Dereference
(N
);
228 when N_Expression_Function
=>
229 Analyze_Expression_Function
(N
);
231 when N_Expression_With_Actions
=>
232 Analyze_Expression_With_Actions
(N
);
234 when N_Extended_Return_Statement
=>
235 Analyze_Extended_Return_Statement
(N
);
237 when N_Extension_Aggregate
=>
238 Analyze_Aggregate
(N
);
240 when N_Formal_Object_Declaration
=>
241 Analyze_Formal_Object_Declaration
(N
);
243 when N_Formal_Package_Declaration
=>
244 Analyze_Formal_Package_Declaration
(N
);
246 when N_Formal_Subprogram_Declaration
=>
247 Analyze_Formal_Subprogram_Declaration
(N
);
249 when N_Formal_Type_Declaration
=>
250 Analyze_Formal_Type_Declaration
(N
);
252 when N_Free_Statement
=>
253 Analyze_Free_Statement
(N
);
255 when N_Freeze_Entity
=>
256 Analyze_Freeze_Entity
(N
);
258 when N_Freeze_Generic_Entity
=>
259 Analyze_Freeze_Generic_Entity
(N
);
261 when N_Full_Type_Declaration
=>
262 Analyze_Full_Type_Declaration
(N
);
264 when N_Function_Call
=>
265 Analyze_Function_Call
(N
);
267 when N_Function_Instantiation
=>
268 Analyze_Function_Instantiation
(N
);
270 when N_Generic_Function_Renaming_Declaration
=>
271 Analyze_Generic_Function_Renaming
(N
);
273 when N_Generic_Package_Declaration
=>
274 Analyze_Generic_Package_Declaration
(N
);
276 when N_Generic_Package_Renaming_Declaration
=>
277 Analyze_Generic_Package_Renaming
(N
);
279 when N_Generic_Procedure_Renaming_Declaration
=>
280 Analyze_Generic_Procedure_Renaming
(N
);
282 when N_Generic_Subprogram_Declaration
=>
283 Analyze_Generic_Subprogram_Declaration
(N
);
285 when N_Goto_Statement
=>
286 Analyze_Goto_Statement
(N
);
288 when N_Handled_Sequence_Of_Statements
=>
289 Analyze_Handled_Statements
(N
);
292 Analyze_Identifier
(N
);
294 when N_If_Expression
=>
295 Analyze_If_Expression
(N
);
297 when N_If_Statement
=>
298 Analyze_If_Statement
(N
);
300 when N_Implicit_Label_Declaration
=>
301 Analyze_Implicit_Label_Declaration
(N
);
304 Analyze_Membership_Op
(N
);
306 when N_Incomplete_Type_Declaration
=>
307 Analyze_Incomplete_Type_Decl
(N
);
309 when N_Indexed_Component
=>
310 Analyze_Indexed_Component_Form
(N
);
312 when N_Integer_Literal
=>
313 Analyze_Integer_Literal
(N
);
315 when N_Iterator_Specification
=>
316 Analyze_Iterator_Specification
(N
);
318 when N_Itype_Reference
=>
319 Analyze_Itype_Reference
(N
);
324 when N_Loop_Parameter_Specification
=>
325 Analyze_Loop_Parameter_Specification
(N
);
327 when N_Loop_Statement
=>
328 Analyze_Loop_Statement
(N
);
331 Analyze_Membership_Op
(N
);
336 when N_Null_Statement
=>
337 Analyze_Null_Statement
(N
);
339 when N_Number_Declaration
=>
340 Analyze_Number_Declaration
(N
);
342 when N_Object_Declaration
=>
343 Analyze_Object_Declaration
(N
);
345 when N_Object_Renaming_Declaration
=>
346 Analyze_Object_Renaming
(N
);
348 when N_Operator_Symbol
=>
349 Analyze_Operator_Symbol
(N
);
352 Analyze_Unary_Op
(N
);
355 Analyze_Arithmetic_Op
(N
);
358 Analyze_Logical_Op
(N
);
361 Analyze_Concatenation
(N
);
364 Analyze_Arithmetic_Op
(N
);
367 Analyze_Equality_Op
(N
);
370 Analyze_Arithmetic_Op
(N
);
373 Analyze_Comparison_Op
(N
);
376 Analyze_Comparison_Op
(N
);
379 Analyze_Comparison_Op
(N
);
382 Analyze_Comparison_Op
(N
);
385 Analyze_Unary_Op
(N
);
390 when N_Op_Multiply
=>
391 Analyze_Arithmetic_Op
(N
);
394 Analyze_Equality_Op
(N
);
397 Analyze_Negation
(N
);
400 Analyze_Logical_Op
(N
);
403 Analyze_Unary_Op
(N
);
406 Analyze_Arithmetic_Op
(N
);
408 when N_Op_Rotate_Left
=>
409 Analyze_Arithmetic_Op
(N
);
411 when N_Op_Rotate_Right
=>
412 Analyze_Arithmetic_Op
(N
);
414 when N_Op_Shift_Left
=>
415 Analyze_Arithmetic_Op
(N
);
417 when N_Op_Shift_Right
=>
418 Analyze_Arithmetic_Op
(N
);
420 when N_Op_Shift_Right_Arithmetic
=>
421 Analyze_Arithmetic_Op
(N
);
423 when N_Op_Subtract
=>
424 Analyze_Arithmetic_Op
(N
);
427 Analyze_Logical_Op
(N
);
430 Analyze_Short_Circuit
(N
);
432 when N_Others_Choice
=>
433 Analyze_Others_Choice
(N
);
435 when N_Package_Body
=>
436 Analyze_Package_Body
(N
);
438 when N_Package_Body_Stub
=>
439 Analyze_Package_Body_Stub
(N
);
441 when N_Package_Declaration
=>
442 Analyze_Package_Declaration
(N
);
444 when N_Package_Instantiation
=>
445 Analyze_Package_Instantiation
(N
);
447 when N_Package_Renaming_Declaration
=>
448 Analyze_Package_Renaming
(N
);
450 when N_Package_Specification
=>
451 Analyze_Package_Specification
(N
);
453 when N_Parameter_Association
=>
454 Analyze_Parameter_Association
(N
);
459 when N_Private_Extension_Declaration
=>
460 Analyze_Private_Extension_Declaration
(N
);
462 when N_Private_Type_Declaration
=>
463 Analyze_Private_Type_Declaration
(N
);
465 when N_Procedure_Call_Statement
=>
466 Analyze_Procedure_Call
(N
);
468 when N_Procedure_Instantiation
=>
469 Analyze_Procedure_Instantiation
(N
);
471 when N_Protected_Body
=>
472 Analyze_Protected_Body
(N
);
474 when N_Protected_Body_Stub
=>
475 Analyze_Protected_Body_Stub
(N
);
477 when N_Protected_Definition
=>
478 Analyze_Protected_Definition
(N
);
480 when N_Protected_Type_Declaration
=>
481 Analyze_Protected_Type_Declaration
(N
);
483 when N_Qualified_Expression
=>
484 Analyze_Qualified_Expression
(N
);
486 when N_Quantified_Expression
=>
487 Analyze_Quantified_Expression
(N
);
489 when N_Raise_Expression
=>
490 Analyze_Raise_Expression
(N
);
492 when N_Raise_Statement
=>
493 Analyze_Raise_Statement
(N
);
495 when N_Raise_xxx_Error
=>
496 Analyze_Raise_xxx_Error
(N
);
501 when N_Range_Constraint
=>
502 Analyze_Range
(Range_Expression
(N
));
504 when N_Real_Literal
=>
505 Analyze_Real_Literal
(N
);
507 when N_Record_Representation_Clause
=>
508 Analyze_Record_Representation_Clause
(N
);
511 Analyze_Reference
(N
);
513 when N_Requeue_Statement
=>
516 when N_Simple_Return_Statement
=>
517 Analyze_Simple_Return_Statement
(N
);
519 when N_Selected_Component
=>
520 Find_Selected_Component
(N
);
521 -- ??? why not Analyze_Selected_Component, needs comments
523 when N_Selective_Accept
=>
524 Analyze_Selective_Accept
(N
);
526 when N_Single_Protected_Declaration
=>
527 Analyze_Single_Protected_Declaration
(N
);
529 when N_Single_Task_Declaration
=>
530 Analyze_Single_Task_Declaration
(N
);
535 when N_String_Literal
=>
536 Analyze_String_Literal
(N
);
538 when N_Subprogram_Body
=>
539 Analyze_Subprogram_Body
(N
);
541 when N_Subprogram_Body_Stub
=>
542 Analyze_Subprogram_Body_Stub
(N
);
544 when N_Subprogram_Declaration
=>
545 Analyze_Subprogram_Declaration
(N
);
547 when N_Subprogram_Renaming_Declaration
=>
548 Analyze_Subprogram_Renaming
(N
);
550 when N_Subtype_Declaration
=>
551 Analyze_Subtype_Declaration
(N
);
553 when N_Subtype_Indication
=>
554 Analyze_Subtype_Indication
(N
);
560 Analyze_Task_Body
(N
);
562 when N_Task_Body_Stub
=>
563 Analyze_Task_Body_Stub
(N
);
565 when N_Task_Definition
=>
566 Analyze_Task_Definition
(N
);
568 when N_Task_Type_Declaration
=>
569 Analyze_Task_Type_Declaration
(N
);
571 when N_Terminate_Alternative
=>
572 Analyze_Terminate_Alternative
(N
);
574 when N_Timed_Entry_Call
=>
575 Analyze_Timed_Entry_Call
(N
);
577 when N_Triggering_Alternative
=>
578 Analyze_Triggering_Alternative
(N
);
580 when N_Type_Conversion
=>
581 Analyze_Type_Conversion
(N
);
583 when N_Unchecked_Expression
=>
584 Analyze_Unchecked_Expression
(N
);
586 when N_Unchecked_Type_Conversion
=>
587 Analyze_Unchecked_Type_Conversion
(N
);
589 when N_Use_Package_Clause
=>
590 Analyze_Use_Package
(N
);
592 when N_Use_Type_Clause
=>
593 Analyze_Use_Type
(N
);
595 when N_Validate_Unchecked_Conversion
=>
598 when N_Variant_Part
=>
599 Analyze_Variant_Part
(N
);
601 when N_With_Clause
=>
602 Analyze_With_Clause
(N
);
604 -- A call to analyze the Empty node is an error, but most likely it
605 -- is an error caused by an attempt to analyze a malformed piece of
606 -- tree caused by some other error, so if there have been any other
607 -- errors, we just ignore it, otherwise it is a real internal error
608 -- which we complain about.
610 -- We must also consider the case of call to a runtime function that
611 -- is not available in the configurable runtime.
614 pragma Assert
(Serious_Errors_Detected
/= 0
615 or else Configurable_Run_Time_Violations
/= 0);
618 -- A call to analyze the error node is simply ignored, to avoid
619 -- causing cascaded errors (happens of course only in error cases)
624 -- Push/Pop nodes normally don't come through an analyze call. An
625 -- exception is the dummy ones bracketing a subprogram body. In any
626 -- case there is nothing to be done to analyze such nodes.
628 when N_Push_Pop_xxx_Label
=>
631 -- SCIL nodes don't need analysis because they are decorated when
632 -- they are built. They are added to the tree by Insert_Actions and
633 -- the call to analyze them is generated when the full list is
636 when N_SCIL_Dispatch_Table_Tag_Init |
637 N_SCIL_Dispatching_Call |
638 N_SCIL_Membership_Test
=>
641 -- For the remaining node types, we generate compiler abort, because
642 -- these nodes are always analyzed within the Sem_Chn routines and
643 -- there should never be a case of making a call to the main Analyze
644 -- routine for these node kinds. For example, an N_Access_Definition
645 -- node appears only in the context of a type declaration, and is
646 -- processed by the analyze routine for type declarations.
648 when N_Abortable_Part |
649 N_Access_Definition |
650 N_Access_Function_Definition |
651 N_Access_Procedure_Definition |
652 N_Access_To_Object_Definition |
653 N_Aspect_Specification |
654 N_Case_Expression_Alternative |
655 N_Case_Statement_Alternative |
656 N_Compilation_Unit_Aux |
657 N_Component_Association |
659 N_Component_Definition |
661 N_Constrained_Array_Definition |
663 N_Decimal_Fixed_Point_Definition |
664 N_Defining_Character_Literal |
665 N_Defining_Identifier |
666 N_Defining_Operator_Symbol |
667 N_Defining_Program_Unit_Name |
669 N_Derived_Type_Definition |
671 N_Digits_Constraint |
672 N_Discriminant_Association |
673 N_Discriminant_Specification |
675 N_Entry_Call_Statement |
676 N_Enumeration_Type_Definition |
677 N_Exception_Handler |
678 N_Floating_Point_Definition |
679 N_Formal_Decimal_Fixed_Point_Definition |
680 N_Formal_Derived_Type_Definition |
681 N_Formal_Discrete_Type_Definition |
682 N_Formal_Floating_Point_Definition |
683 N_Formal_Modular_Type_Definition |
684 N_Formal_Ordinary_Fixed_Point_Definition |
685 N_Formal_Private_Type_Definition |
686 N_Formal_Incomplete_Type_Definition |
687 N_Formal_Signed_Integer_Type_Definition |
688 N_Function_Specification |
689 N_Generic_Association |
690 N_Index_Or_Discriminant_Constraint |
693 N_Modular_Type_Definition |
694 N_Ordinary_Fixed_Point_Definition |
695 N_Parameter_Specification |
696 N_Pragma_Argument_Association |
697 N_Procedure_Specification |
698 N_Real_Range_Specification |
699 N_Record_Definition |
700 N_Signed_Integer_Type_Definition |
701 N_Unconstrained_Array_Definition |
708 Debug_A_Exit
("analyzing ", N
, " (done)");
710 -- Now that we have analyzed the node, we call the expander to perform
711 -- possible expansion. We skip this for subexpressions, because we don't
712 -- have the type yet, and the expander will need to know the type before
713 -- it can do its job. For subexpression nodes, the call to the expander
714 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
715 -- which can appear in a statement context, and needs expanding now in
716 -- the case (distinguished by Etype, as documented in Sinfo).
718 -- The Analyzed flag is also set at this point for non-subexpression
719 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
720 -- since resolution and expansion have not yet been completed). Note
721 -- that for N_Raise_xxx_Error we have to distinguish the expression
722 -- case from the statement case.
724 if Nkind
(N
) not in N_Subexpr
725 or else (Nkind
(N
) in N_Raise_xxx_Error
726 and then Etype
(N
) = Standard_Void_Type
)
731 Ghost_Mode
:= Save_Ghost_Mode
;
734 -- Version with check(s) suppressed
736 procedure Analyze
(N
: Node_Id
; Suppress
: Check_Id
) is
738 if Suppress
= All_Checks
then
740 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
742 Scope_Suppress
.Suppress
:= (others => True);
744 Scope_Suppress
.Suppress
:= Svs
;
747 elsif Suppress
= Overflow_Check
then
749 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
751 Scope_Suppress
.Suppress
(Suppress
) := True;
753 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
762 procedure Analyze_List
(L
: List_Id
) is
767 while Present
(Node
) loop
773 -- Version with check(s) suppressed
775 procedure Analyze_List
(L
: List_Id
; Suppress
: Check_Id
) is
777 if Suppress
= All_Checks
then
779 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
781 Scope_Suppress
.Suppress
:= (others => True);
783 Scope_Suppress
.Suppress
:= Svs
;
788 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
790 Scope_Suppress
.Suppress
(Suppress
) := True;
792 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
797 --------------------------
798 -- Copy_Suppress_Status --
799 --------------------------
801 procedure Copy_Suppress_Status
807 pragma Warnings
(Off
, Found
);
809 procedure Search_Stack
810 (Top
: Suppress_Stack_Entry_Ptr
;
811 Found
: out Boolean);
812 -- Search given suppress stack for matching entry for entity. If found
813 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
814 -- entry for To onto the local suppress stack.
820 procedure Search_Stack
821 (Top
: Suppress_Stack_Entry_Ptr
;
824 Ptr
: Suppress_Stack_Entry_Ptr
;
828 while Ptr
/= null loop
830 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
833 Set_Checks_May_Be_Suppressed
(To
, True);
834 Push_Local_Suppress_Stack_Entry
850 -- Start of processing for Copy_Suppress_Status
853 if not Checks_May_Be_Suppressed
(From
) then
857 -- First search the global entity suppress table for a matching entry.
858 -- We also search this in reverse order so that if there are multiple
859 -- pragmas for the same entity, the last one applies.
861 Search_Stack
(Global_Suppress_Stack_Top
, Found
);
867 -- Now search the local entity suppress stack, we search this in
868 -- reverse order so that we get the innermost entry that applies to
869 -- this case if there are nested entries. Note that for the purpose
870 -- of this procedure we are ONLY looking for entries corresponding
871 -- to a two-argument Suppress, where the second argument matches From.
873 Search_Stack
(Local_Suppress_Stack_Top
, Found
);
874 end Copy_Suppress_Status
;
876 -------------------------
877 -- Enter_Generic_Scope --
878 -------------------------
880 procedure Enter_Generic_Scope
(S
: Entity_Id
) is
882 if No
(Outer_Generic_Scope
) then
883 Outer_Generic_Scope
:= S
;
885 end Enter_Generic_Scope
;
887 ------------------------
888 -- Exit_Generic_Scope --
889 ------------------------
891 procedure Exit_Generic_Scope
(S
: Entity_Id
) is
893 if S
= Outer_Generic_Scope
then
894 Outer_Generic_Scope
:= Empty
;
896 end Exit_Generic_Scope
;
898 -----------------------
899 -- Explicit_Suppress --
900 -----------------------
902 function Explicit_Suppress
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
903 Ptr
: Suppress_Stack_Entry_Ptr
;
906 if not Checks_May_Be_Suppressed
(E
) then
910 Ptr
:= Global_Suppress_Stack_Top
;
911 while Ptr
/= null loop
913 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
923 end Explicit_Suppress
;
925 -----------------------------
926 -- External_Ref_In_Generic --
927 -----------------------------
929 function External_Ref_In_Generic
(E
: Entity_Id
) return Boolean is
933 -- Entity is global if defined outside of current outer_generic_scope:
934 -- Either the entity has a smaller depth that the outer generic, or it
935 -- is in a different compilation unit, or it is defined within a unit
936 -- in the same compilation, that is not within the outer_generic.
938 if No
(Outer_Generic_Scope
) then
941 elsif Scope_Depth
(Scope
(E
)) < Scope_Depth
(Outer_Generic_Scope
)
942 or else not In_Same_Source_Unit
(E
, Outer_Generic_Scope
)
948 while Present
(Scop
) loop
949 if Scop
= Outer_Generic_Scope
then
951 elsif Scope_Depth
(Scop
) < Scope_Depth
(Outer_Generic_Scope
) then
954 Scop
:= Scope
(Scop
);
960 end External_Ref_In_Generic
;
966 procedure Initialize
is
967 Next
: Suppress_Stack_Entry_Ptr
;
969 procedure Free
is new Unchecked_Deallocation
970 (Suppress_Stack_Entry
, Suppress_Stack_Entry_Ptr
);
973 -- Free any global suppress stack entries from a previous invocation
974 -- of the compiler (in the normal case this loop does nothing).
976 while Suppress_Stack_Entries
/= null loop
977 Next
:= Suppress_Stack_Entries
.Next
;
978 Free
(Suppress_Stack_Entries
);
979 Suppress_Stack_Entries
:= Next
;
982 Local_Suppress_Stack_Top
:= null;
983 Global_Suppress_Stack_Top
:= null;
985 -- Clear scope stack, and reset global variables
988 Unloaded_Subunits
:= False;
991 ------------------------------
992 -- Insert_After_And_Analyze --
993 ------------------------------
995 procedure Insert_After_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
1001 -- If we are not at the end of the list, then the easiest
1002 -- coding is simply to insert before our successor
1004 if Present
(Next
(N
)) then
1005 Insert_Before_And_Analyze
(Next
(N
), M
);
1007 -- Case of inserting at the end of the list
1010 -- Capture the Node_Id of the node to be inserted. This Node_Id
1011 -- will still be the same after the insert operation.
1014 Insert_After
(N
, M
);
1016 -- Now just analyze from the inserted node to the end of
1017 -- the new list (note that this properly handles the case
1018 -- where any of the analyze calls result in the insertion of
1019 -- nodes after the analyzed node, expecting analysis).
1021 while Present
(Node
) loop
1023 Mark_Rewrite_Insertion
(Node
);
1028 end Insert_After_And_Analyze
;
1030 -- Version with check(s) suppressed
1032 procedure Insert_After_And_Analyze
1035 Suppress
: Check_Id
)
1038 if Suppress
= All_Checks
then
1040 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1042 Scope_Suppress
.Suppress
:= (others => True);
1043 Insert_After_And_Analyze
(N
, M
);
1044 Scope_Suppress
.Suppress
:= Svs
;
1049 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1051 Scope_Suppress
.Suppress
(Suppress
) := True;
1052 Insert_After_And_Analyze
(N
, M
);
1053 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1056 end Insert_After_And_Analyze
;
1058 -------------------------------
1059 -- Insert_Before_And_Analyze --
1060 -------------------------------
1062 procedure Insert_Before_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
1068 -- Capture the Node_Id of the first list node to be inserted.
1069 -- This will still be the first node after the insert operation,
1070 -- since Insert_List_After does not modify the Node_Id values.
1073 Insert_Before
(N
, M
);
1075 -- The insertion does not change the Id's of any of the nodes in
1076 -- the list, and they are still linked, so we can simply loop from
1077 -- the original first node until we meet the node before which the
1078 -- insertion is occurring. Note that this properly handles the case
1079 -- where any of the analyzed nodes insert nodes after themselves,
1080 -- expecting them to get analyzed.
1082 while Node
/= N
loop
1084 Mark_Rewrite_Insertion
(Node
);
1088 end Insert_Before_And_Analyze
;
1090 -- Version with check(s) suppressed
1092 procedure Insert_Before_And_Analyze
1095 Suppress
: Check_Id
)
1098 if Suppress
= All_Checks
then
1100 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1102 Scope_Suppress
.Suppress
:= (others => True);
1103 Insert_Before_And_Analyze
(N
, M
);
1104 Scope_Suppress
.Suppress
:= Svs
;
1109 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1111 Scope_Suppress
.Suppress
(Suppress
) := True;
1112 Insert_Before_And_Analyze
(N
, M
);
1113 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1116 end Insert_Before_And_Analyze
;
1118 -----------------------------------
1119 -- Insert_List_After_And_Analyze --
1120 -----------------------------------
1122 procedure Insert_List_After_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1123 After
: constant Node_Id
:= Next
(N
);
1127 if Is_Non_Empty_List
(L
) then
1129 -- Capture the Node_Id of the first list node to be inserted.
1130 -- This will still be the first node after the insert operation,
1131 -- since Insert_List_After does not modify the Node_Id values.
1134 Insert_List_After
(N
, L
);
1136 -- Now just analyze from the original first node until we get to the
1137 -- successor of the original insertion point (which may be Empty if
1138 -- the insertion point was at the end of the list). Note that this
1139 -- properly handles the case where any of the analyze calls result in
1140 -- the insertion of nodes after the analyzed node (possibly calling
1141 -- this routine recursively).
1143 while Node
/= After
loop
1145 Mark_Rewrite_Insertion
(Node
);
1149 end Insert_List_After_And_Analyze
;
1151 -- Version with check(s) suppressed
1153 procedure Insert_List_After_And_Analyze
1154 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1157 if Suppress
= All_Checks
then
1159 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1161 Scope_Suppress
.Suppress
:= (others => True);
1162 Insert_List_After_And_Analyze
(N
, L
);
1163 Scope_Suppress
.Suppress
:= Svs
;
1168 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1170 Scope_Suppress
.Suppress
(Suppress
) := True;
1171 Insert_List_After_And_Analyze
(N
, L
);
1172 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1175 end Insert_List_After_And_Analyze
;
1177 ------------------------------------
1178 -- Insert_List_Before_And_Analyze --
1179 ------------------------------------
1181 procedure Insert_List_Before_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1185 if Is_Non_Empty_List
(L
) then
1187 -- Capture the Node_Id of the first list node to be inserted. This
1188 -- will still be the first node after the insert operation, since
1189 -- Insert_List_After does not modify the Node_Id values.
1192 Insert_List_Before
(N
, L
);
1194 -- The insertion does not change the Id's of any of the nodes in
1195 -- the list, and they are still linked, so we can simply loop from
1196 -- the original first node until we meet the node before which the
1197 -- insertion is occurring. Note that this properly handles the case
1198 -- where any of the analyzed nodes insert nodes after themselves,
1199 -- expecting them to get analyzed.
1201 while Node
/= N
loop
1203 Mark_Rewrite_Insertion
(Node
);
1207 end Insert_List_Before_And_Analyze
;
1209 -- Version with check(s) suppressed
1211 procedure Insert_List_Before_And_Analyze
1212 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1215 if Suppress
= All_Checks
then
1217 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1219 Scope_Suppress
.Suppress
:= (others => True);
1220 Insert_List_Before_And_Analyze
(N
, L
);
1221 Scope_Suppress
.Suppress
:= Svs
;
1226 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1228 Scope_Suppress
.Suppress
(Suppress
) := True;
1229 Insert_List_Before_And_Analyze
(N
, L
);
1230 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1233 end Insert_List_Before_And_Analyze
;
1241 Scope_Stack
.Locked
:= True;
1242 Scope_Stack
.Release
;
1249 procedure Preanalyze
(N
: Node_Id
) is
1250 Save_Full_Analysis
: constant Boolean := Full_Analysis
;
1253 Full_Analysis
:= False;
1254 Expander_Mode_Save_And_Set
(False);
1258 Expander_Mode_Restore
;
1259 Full_Analysis
:= Save_Full_Analysis
;
1262 --------------------------------------
1263 -- Push_Global_Suppress_Stack_Entry --
1264 --------------------------------------
1266 procedure Push_Global_Suppress_Stack_Entry
1267 (Entity
: Entity_Id
;
1272 Global_Suppress_Stack_Top
:=
1273 new Suppress_Stack_Entry
'
1276 Suppress => Suppress,
1277 Prev => Global_Suppress_Stack_Top,
1278 Next => Suppress_Stack_Entries);
1279 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1281 end Push_Global_Suppress_Stack_Entry;
1283 -------------------------------------
1284 -- Push_Local_Suppress_Stack_Entry --
1285 -------------------------------------
1287 procedure Push_Local_Suppress_Stack_Entry
1288 (Entity : Entity_Id;
1293 Local_Suppress_Stack_Top :=
1294 new Suppress_Stack_Entry'
1297 Suppress
=> Suppress
,
1298 Prev
=> Local_Suppress_Stack_Top
,
1299 Next
=> Suppress_Stack_Entries
);
1300 Suppress_Stack_Entries
:= Local_Suppress_Stack_Top
;
1303 end Push_Local_Suppress_Stack_Entry
;
1309 procedure Semantics
(Comp_Unit
: Node_Id
) is
1310 procedure Do_Analyze
;
1311 -- Perform the analysis of the compilation unit
1317 procedure Do_Analyze
is
1318 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1320 -- Generally style checks are preserved across compilations, with
1321 -- one exception: s-oscons.ads, which allows arbitrary long lines
1322 -- unconditionally, and has no restore mechanism, because it is
1323 -- intended as a lowest-level Pure package.
1325 Save_Max_Line
: constant Int
:= Style_Max_Line_Length
;
1330 List
:= Save_Scope_Stack
;
1331 Push_Scope
(Standard_Standard
);
1333 -- Set up a clean environment before analyzing
1336 Outer_Generic_Scope
:= Empty
;
1337 Scope_Suppress
:= Suppress_Options
;
1339 (Scope_Stack
.Last
).Component_Alignment_Default
:= Calign_Default
;
1341 (Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
1343 -- Now analyze the top level compilation unit node
1345 Analyze
(Comp_Unit
);
1347 -- Check for scope mismatch on exit from compilation
1349 pragma Assert
(Current_Scope
= Standard_Standard
1350 or else Comp_Unit
= Cunit
(Main_Unit
));
1352 -- Then pop entry for Standard, and pop implicit types
1355 Restore_Scope_Stack
(List
);
1356 Ghost_Mode
:= Save_Ghost_Mode
;
1357 Style_Max_Line_Length
:= Save_Max_Line
;
1362 -- The following locations save the corresponding global flags and
1363 -- variables so that they can be restored on completion. This is needed
1364 -- so that calls to Rtsfind start with the proper default values for
1365 -- these variables, and also that such calls do not disturb the settings
1366 -- for units being analyzed at a higher level.
1368 S_Current_Sem_Unit
: constant Unit_Number_Type
:= Current_Sem_Unit
;
1369 S_Full_Analysis
: constant Boolean := Full_Analysis
;
1370 S_GNAT_Mode
: constant Boolean := GNAT_Mode
;
1371 S_Global_Dis_Names
: constant Boolean := Global_Discard_Names
;
1372 S_In_Assertion_Expr
: constant Nat
:= In_Assertion_Expr
;
1373 S_In_Default_Expr
: constant Boolean := In_Default_Expr
;
1374 S_In_Spec_Expr
: constant Boolean := In_Spec_Expression
;
1375 S_Inside_A_Generic
: constant Boolean := Inside_A_Generic
;
1376 S_Outer_Gen_Scope
: constant Entity_Id
:= Outer_Generic_Scope
;
1377 S_Style_Check
: constant Boolean := Style_Check
;
1379 Already_Analyzed
: constant Boolean := Analyzed
(Comp_Unit
);
1381 Curunit
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(Comp_Unit
);
1382 -- New value of Current_Sem_Unit
1384 Generic_Main
: constant Boolean :=
1385 Nkind
(Unit
(Cunit
(Main_Unit
))) in N_Generic_Declaration
;
1386 -- If the main unit is generic, every compiled unit, including its
1387 -- context, is compiled with expansion disabled.
1389 Is_Main_Unit_Or_Main_Unit_Spec
: constant Boolean :=
1392 (Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
1393 and then Library_Unit
(Cunit
(Main_Unit
)) = Cunit
(Curunit
));
1394 -- Configuration flags have special settings when compiling a predefined
1395 -- file as a main unit. This applies to its spec as well.
1397 Ext_Main_Source_Unit
: constant Boolean :=
1398 In_Extended_Main_Source_Unit
(Comp_Unit
);
1399 -- Determine if unit is in extended main source unit
1401 Save_Config_Switches
: Config_Switches_Type
;
1402 -- Variable used to save values of config switches while we analyze the
1403 -- new unit, to be restored on exit for proper recursive behavior.
1405 Save_Cunit_Restrictions
: Save_Cunit_Boolean_Restrictions
;
1406 -- Used to save non-partition wide restrictions before processing new
1407 -- unit. All with'ed units are analyzed with config restrictions reset
1408 -- and we need to restore these saved values at the end.
1410 -- Start of processing for Semantics
1413 if Debug_Unit_Walk
then
1414 if Already_Analyzed
then
1415 Write_Str
("(done)");
1419 (Get_Cunit_Unit_Number
(Comp_Unit
),
1425 Compiler_State
:= Analyzing
;
1426 Current_Sem_Unit
:= Curunit
;
1428 -- Compile predefined units with GNAT_Mode set to True, to properly
1429 -- process the categorization stuff. However, do not set GNAT_Mode
1430 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1431 -- Sequential_IO) as this would prevent pragma Extend_System from being
1432 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1434 if Is_Predefined_File_Name
1435 (Unit_File_Name
(Current_Sem_Unit
), Renamings_Included
=> False)
1440 -- For generic main, never do expansion
1442 if Generic_Main
then
1443 Expander_Mode_Save_And_Set
(False);
1448 Expander_Mode_Save_And_Set
1450 -- Turn on expansion if generating code
1452 (Operating_Mode
= Generate_Code
1454 -- Or if special debug flag -gnatdx is set
1456 or else Debug_Flag_X
1458 -- Or if in configuration run-time mode. We do this so we get
1459 -- error messages about missing entities in the run-time even
1460 -- if we are compiling in -gnatc (no code generation) mode.
1461 -- Similar processing applies to No_Run_Time_Mode. However,
1462 -- don't do this if debug flag -gnatd.Z is set or when we are
1463 -- compiling a separate unit (this is to handle a situation
1464 -- where this new processing causes trouble).
1466 or else ((Configurable_Run_Time_Mode
or No_Run_Time_Mode
)
1467 and not Debug_Flag_Dot_ZZ
1468 and Nkind
(Unit
(Cunit
(Main_Unit
))) /= N_Subunit
));
1471 Full_Analysis
:= True;
1472 Inside_A_Generic
:= False;
1473 In_Assertion_Expr
:= 0;
1474 In_Default_Expr
:= False;
1475 In_Spec_Expression
:= False;
1476 Set_Comes_From_Source_Default
(False);
1478 -- Save current config switches and reset then appropriately
1480 Save_Opt_Config_Switches
(Save_Config_Switches
);
1481 Set_Opt_Config_Switches
1482 (Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
)),
1483 Is_Main_Unit_Or_Main_Unit_Spec
);
1485 -- Save current non-partition-wide restrictions
1487 Save_Cunit_Restrictions
:= Cunit_Boolean_Restrictions_Save
;
1489 -- For unit in main extended unit, we reset the configuration values
1490 -- for the non-partition-wide restrictions. For other units reset them.
1492 if Ext_Main_Source_Unit
then
1493 Restore_Config_Cunit_Boolean_Restrictions
;
1495 Reset_Cunit_Boolean_Restrictions
;
1498 -- Turn off style checks for unit that is not in the extended main
1499 -- source unit. This improves processing efficiency for such units
1500 -- (for which we don't want style checks anyway, and where they will
1501 -- get suppressed), and is definitely needed to stop some style checks
1502 -- from invading the run-time units (e.g. overriding checks).
1504 if not Ext_Main_Source_Unit
then
1505 Style_Check
:= False;
1507 -- If this is part of the extended main source unit, set style check
1508 -- mode to match the style check mode of the main source unit itself.
1511 Style_Check
:= Style_Check_Main
;
1514 -- Only do analysis of unit that has not already been analyzed
1516 if not Analyzed
(Comp_Unit
) then
1517 Initialize_Version
(Current_Sem_Unit
);
1519 -- Do analysis, and then append the compilation unit onto the
1520 -- Comp_Unit_List, if appropriate. This is done after analysis,
1521 -- so if this unit depends on some others, they have already been
1522 -- appended. We ignore bodies, except for the main unit itself, and
1523 -- for subprogram bodies that act as specs. We have also to guard
1524 -- against ill-formed subunits that have an improper context.
1528 if Present
(Comp_Unit
)
1529 and then Nkind
(Unit
(Comp_Unit
)) in N_Proper_Body
1530 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Subprogram_Body
1531 or else not Acts_As_Spec
(Comp_Unit
))
1532 and then not In_Extended_Main_Source_Unit
(Comp_Unit
)
1537 Append_New_Elmt
(Comp_Unit
, To
=> Comp_Unit_List
);
1539 if Debug_Unit_Walk
then
1540 Write_Str
("Appending ");
1542 (Get_Cunit_Unit_Number
(Comp_Unit
), Unit
(Comp_Unit
));
1547 -- Save indication of dynamic elaboration checks for ALI file
1549 Set_Dynamic_Elab
(Current_Sem_Unit
, Dynamic_Elaboration_Checks
);
1551 -- Restore settings of saved switches to entry values
1553 Current_Sem_Unit
:= S_Current_Sem_Unit
;
1554 Full_Analysis
:= S_Full_Analysis
;
1555 Global_Discard_Names
:= S_Global_Dis_Names
;
1556 GNAT_Mode
:= S_GNAT_Mode
;
1557 In_Assertion_Expr
:= S_In_Assertion_Expr
;
1558 In_Default_Expr
:= S_In_Default_Expr
;
1559 In_Spec_Expression
:= S_In_Spec_Expr
;
1560 Inside_A_Generic
:= S_Inside_A_Generic
;
1561 Outer_Generic_Scope
:= S_Outer_Gen_Scope
;
1562 Style_Check
:= S_Style_Check
;
1564 Restore_Opt_Config_Switches
(Save_Config_Switches
);
1566 -- Deal with restore of restrictions
1568 Cunit_Boolean_Restrictions_Restore
(Save_Cunit_Restrictions
);
1570 Expander_Mode_Restore
;
1572 if Debug_Unit_Walk
then
1575 if Already_Analyzed
then
1576 Write_Str
("(done)");
1580 (Get_Cunit_Unit_Number
(Comp_Unit
),
1590 function ss
(Index
: Int
) return Scope_Stack_Entry
is
1592 return Scope_Stack
.Table
(Index
);
1599 function sst
return Scope_Stack_Entry
is
1601 return ss
(Scope_Stack
.Last
);
1604 ------------------------
1605 -- Walk_Library_Items --
1606 ------------------------
1608 procedure Walk_Library_Items
is
1609 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
1610 pragma Pack
(Unit_Number_Set
);
1612 Main_CU
: constant Node_Id
:= Cunit
(Main_Unit
);
1614 Seen
, Done
: Unit_Number_Set
:= (others => False);
1615 -- Seen (X) is True after we have seen unit X in the walk. This is used
1616 -- to prevent processing the same unit more than once. Done (X) is True
1617 -- after we have fully processed X, and is used only for debugging
1618 -- printouts and assertions.
1620 Do_Main
: Boolean := False;
1621 -- Flag to delay processing the main body until after all other units.
1622 -- This is needed because the spec of the main unit may appear in the
1623 -- context of some other unit. We do not want this to force processing
1624 -- of the main body before all other units have been processed.
1626 -- Another circularity pattern occurs when the main unit is a child unit
1627 -- and the body of an ancestor has a with-clause of the main unit or on
1628 -- one of its children. In both cases the body in question has a with-
1629 -- clause on the main unit, and must be excluded from the traversal. In
1630 -- some convoluted cases this may lead to a CodePeer error because the
1631 -- spec of a subprogram declared in an instance within the parent will
1632 -- not be seen in the main unit.
1634 function Depends_On_Main
(CU
: Node_Id
) return Boolean;
1635 -- The body of a unit that is withed by the spec of the main unit may in
1636 -- turn have a with_clause on that spec. In that case do not traverse
1637 -- the body, to prevent loops. It can also happen that the main body has
1638 -- a with_clause on a child, which of course has an implicit with on its
1639 -- parent. It's OK to traverse the child body if the main spec has been
1640 -- processed, otherwise we also have a circularity to avoid.
1642 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
);
1643 -- Calls Action, with some validity checks
1645 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
);
1646 -- Calls Do_Action, first on the units with'ed by this one, then on
1647 -- this unit. If it's an instance body, do the spec first. If it is
1648 -- an instance spec, do the body last.
1650 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
);
1651 -- Apply Do_Unit_And_Dependents to a unit in a context clause
1653 procedure Process_Bodies_In_Context
(Comp
: Node_Id
);
1654 -- The main unit and its spec may depend on bodies that contain generics
1655 -- that are instantiated in them. Iterate through the corresponding
1656 -- contexts before processing main (spec/body) itself, to process bodies
1657 -- that may be present, together with their context. The spec of main
1658 -- is processed wherever it appears in the list of units, while the body
1659 -- is processed as the last unit in the list.
1661 ---------------------
1662 -- Depends_On_Main --
1663 ---------------------
1665 function Depends_On_Main
(CU
: Node_Id
) return Boolean is
1667 MCU
: constant Node_Id
:= Unit
(Main_CU
);
1670 CL
:= First
(Context_Items
(CU
));
1672 -- Problem does not arise with main subprograms
1675 not Nkind_In
(MCU
, N_Package_Body
, N_Package_Declaration
)
1680 while Present
(CL
) loop
1681 if Nkind
(CL
) = N_With_Clause
1682 and then Library_Unit
(CL
) = Main_CU
1683 and then not Done
(Get_Cunit_Unit_Number
(Library_Unit
(CL
)))
1692 end Depends_On_Main
;
1698 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
) is
1700 -- This calls Action at the end. All the preceding code is just
1701 -- assertions and debugging output.
1703 pragma Assert
(No
(CU
) or else Nkind
(CU
) = N_Compilation_Unit
);
1705 case Nkind
(Item
) is
1706 when N_Generic_Subprogram_Declaration |
1707 N_Generic_Package_Declaration |
1708 N_Package_Declaration |
1709 N_Subprogram_Declaration |
1710 N_Subprogram_Renaming_Declaration |
1711 N_Package_Renaming_Declaration |
1712 N_Generic_Function_Renaming_Declaration |
1713 N_Generic_Package_Renaming_Declaration |
1714 N_Generic_Procedure_Renaming_Declaration
=>
1720 when N_Package_Body
=>
1722 -- Package bodies are processed separately if the main unit
1727 when N_Subprogram_Body
=>
1729 -- A subprogram body must be the main unit
1731 pragma Assert
(Acts_As_Spec
(CU
)
1732 or else CU
= Cunit
(Main_Unit
));
1735 when N_Function_Instantiation |
1736 N_Procedure_Instantiation |
1737 N_Package_Instantiation
=>
1739 -- Can only happen if some generic body (needed for gnat2scil
1740 -- traversal, but not by GNAT) is not available, ignore.
1744 -- All other cases cannot happen
1747 pragma Assert
(False, "subunit");
1751 pragma Assert
(False);
1755 if Present
(CU
) then
1756 pragma Assert
(Item
/= Stand
.Standard_Package_Node
);
1757 pragma Assert
(Item
= Unit
(CU
));
1760 Unit_Num
: constant Unit_Number_Type
:=
1761 Get_Cunit_Unit_Number
(CU
);
1763 procedure Assert_Done
(Withed_Unit
: Node_Id
);
1764 -- Assert Withed_Unit is already Done, unless it's a body. It
1765 -- might seem strange for a with_clause to refer to a body, but
1766 -- this happens in the case of a generic instantiation, which
1767 -- gets transformed into the instance body (and the instance
1768 -- spec is also created). With clauses pointing to the
1769 -- instantiation end up pointing to the instance body.
1775 procedure Assert_Done
(Withed_Unit
: Node_Id
) is
1777 if not Done
(Get_Cunit_Unit_Number
(Withed_Unit
)) then
1779 (Unit
(Withed_Unit
),
1780 N_Generic_Package_Declaration
,
1782 N_Package_Renaming_Declaration
,
1786 (Unit_Name
(Get_Cunit_Unit_Number
(Withed_Unit
)));
1787 Write_Str
(" not yet walked!");
1789 if Get_Cunit_Unit_Number
(Withed_Unit
) = Unit_Num
then
1790 Write_Str
(" (self-ref)");
1795 pragma Assert
(False);
1800 procedure Assert_Withed_Units_Done
is
1801 new Walk_Withs
(Assert_Done
);
1804 if Debug_Unit_Walk
then
1805 Write_Unit_Info
(Unit_Num
, Item
, Withs
=> True);
1808 -- Main unit should come last, except in the case where we
1809 -- skipped System_Aux_Id, in which case we missed the things it
1810 -- depends on, and in the case of parent bodies if present.
1813 (not Done
(Main_Unit
)
1814 or else Present
(System_Aux_Id
)
1815 or else Nkind
(Item
) = N_Package_Body
);
1817 -- We shouldn't do the same thing twice
1819 pragma Assert
(not Done
(Unit_Num
));
1821 -- Everything we depend upon should already be done
1824 (Assert_Withed_Units_Done
(CU
, Include_Limited
=> False));
1828 -- Must be Standard, which has no entry in the units table
1830 pragma Assert
(Item
= Stand
.Standard_Package_Node
);
1832 if Debug_Unit_Walk
then
1833 Write_Line
("Standard");
1840 --------------------
1841 -- Do_Withed_Unit --
1842 --------------------
1844 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
) is
1846 Do_Unit_And_Dependents
(Withed_Unit
, Unit
(Withed_Unit
));
1848 -- If the unit in the with_clause is a generic instance, the clause
1849 -- now denotes the instance body. Traverse the corresponding spec
1850 -- because there may be no other dependence that will force the
1851 -- traversal of its own context.
1853 if Nkind
(Unit
(Withed_Unit
)) = N_Package_Body
1854 and then Is_Generic_Instance
1855 (Defining_Entity
(Unit
(Library_Unit
(Withed_Unit
))))
1857 Do_Withed_Unit
(Library_Unit
(Withed_Unit
));
1861 ----------------------------
1862 -- Do_Unit_And_Dependents --
1863 ----------------------------
1865 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
) is
1866 Unit_Num
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(CU
);
1868 Body_U
: Unit_Number_Type
;
1869 Parent_CU
: Node_Id
;
1871 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
1874 if not Seen
(Unit_Num
) then
1876 -- Process the with clauses
1878 Do_Withed_Units
(CU
, Include_Limited
=> False);
1880 -- Process the unit if it is a spec or the main unit, if it
1881 -- has no previous spec or we have done all other units.
1883 if not Nkind_In
(Item
, N_Package_Body
, N_Subprogram_Body
)
1884 or else Acts_As_Spec
(CU
)
1886 if CU
= Cunit
(Main_Unit
)
1887 and then not Do_Main
1889 Seen
(Unit_Num
) := False;
1892 Seen
(Unit_Num
) := True;
1894 if CU
= Library_Unit
(Main_CU
) then
1895 Process_Bodies_In_Context
(CU
);
1897 -- If main is a child unit, examine parent unit contexts
1898 -- to see if they include instantiated units. Also, if
1899 -- the parent itself is an instance, process its body
1900 -- because it may contain subprograms that are called
1901 -- in the main unit.
1903 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
1904 Child
:= Cunit_Entity
(Main_Unit
);
1905 while Is_Child_Unit
(Child
) loop
1908 (Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
1909 Process_Bodies_In_Context
(Parent_CU
);
1911 if Nkind
(Unit
(Parent_CU
)) = N_Package_Body
1913 Nkind
(Original_Node
(Unit
(Parent_CU
)))
1914 = N_Package_Instantiation
1916 not Seen
(Get_Cunit_Unit_Number
(Parent_CU
))
1918 Body_U
:= Get_Cunit_Unit_Number
(Parent_CU
);
1919 Seen
(Body_U
) := True;
1920 Do_Action
(Parent_CU
, Unit
(Parent_CU
));
1921 Done
(Body_U
) := True;
1924 Child
:= Scope
(Child
);
1929 Do_Action
(CU
, Item
);
1930 Done
(Unit_Num
) := True;
1934 end Do_Unit_And_Dependents
;
1936 -------------------------------
1937 -- Process_Bodies_In_Context --
1938 -------------------------------
1940 procedure Process_Bodies_In_Context
(Comp
: Node_Id
) is
1942 Body_U
: Unit_Number_Type
;
1946 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
1948 -- Start of processing for Process_Bodies_In_Context
1951 Clause
:= First
(Context_Items
(Comp
));
1952 while Present
(Clause
) loop
1953 if Nkind
(Clause
) = N_With_Clause
then
1954 Spec
:= Library_Unit
(Clause
);
1955 Body_CU
:= Library_Unit
(Spec
);
1957 -- If we are processing the spec of the main unit, load bodies
1958 -- only if the with_clause indicates that it forced the loading
1959 -- of the body for a generic instantiation. Note that bodies of
1960 -- parents that are instances have been loaded already.
1962 if Present
(Body_CU
)
1963 and then Body_CU
/= Cunit
(Main_Unit
)
1964 and then Nkind
(Unit
(Body_CU
)) /= N_Subprogram_Body
1965 and then (Nkind
(Unit
(Comp
)) /= N_Package_Declaration
1966 or else Present
(Withed_Body
(Clause
)))
1968 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
1970 if not Seen
(Body_U
)
1971 and then not Depends_On_Main
(Body_CU
)
1973 Seen
(Body_U
) := True;
1974 Do_Withed_Units
(Body_CU
, Include_Limited
=> False);
1975 Do_Action
(Body_CU
, Unit
(Body_CU
));
1976 Done
(Body_U
) := True;
1983 end Process_Bodies_In_Context
;
1985 -- Local Declarations
1989 -- Start of processing for Walk_Library_Items
1992 if Debug_Unit_Walk
then
1993 Write_Line
("Walk_Library_Items:");
1997 -- Do Standard first, then walk the Comp_Unit_List
1999 Do_Action
(Empty
, Standard_Package_Node
);
2001 -- First place the context of all instance bodies on the corresponding
2002 -- spec, because it may be needed to analyze the code at the place of
2003 -- the instantiation.
2005 Cur
:= First_Elmt
(Comp_Unit_List
);
2006 while Present
(Cur
) loop
2008 CU
: constant Node_Id
:= Node
(Cur
);
2009 N
: constant Node_Id
:= Unit
(CU
);
2012 if Nkind
(N
) = N_Package_Body
2013 and then Is_Generic_Instance
(Defining_Entity
(N
))
2016 (Context_Items
(CU
), Context_Items
(Library_Unit
(CU
)));
2023 -- Now traverse compilation units (specs) in order
2025 Cur
:= First_Elmt
(Comp_Unit_List
);
2026 while Present
(Cur
) loop
2028 CU
: constant Node_Id
:= Node
(Cur
);
2029 N
: constant Node_Id
:= Unit
(CU
);
2033 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2037 -- If it is a subprogram body, process it if it has no
2040 -- If it's a package body, ignore it, unless it is a body
2041 -- created for an instance that is the main unit. In the case
2042 -- of subprograms, the body is the wrapper package. In case of
2043 -- a package, the original file carries the body, and the spec
2044 -- appears as a later entry in the units list.
2046 -- Otherwise bodies appear in the list only because of inlining
2047 -- or instantiations, and they are processed only if relevant.
2048 -- The flag Withed_Body on a context clause indicates that a
2049 -- unit contains an instantiation that may be needed later,
2050 -- and therefore the body that contains the generic body (and
2051 -- its context) must be traversed immediately after the
2052 -- corresponding spec (see Do_Unit_And_Dependents).
2054 -- The main unit itself is processed separately after all other
2055 -- specs, and relevant bodies are examined in Process_Main.
2057 when N_Subprogram_Body
=>
2058 if Acts_As_Spec
(N
) then
2059 Do_Unit_And_Dependents
(CU
, N
);
2062 when N_Package_Body
=>
2064 and then Nkind
(Original_Node
(Unit
(Main_CU
))) in
2065 N_Generic_Instantiation
2066 and then Present
(Library_Unit
(Main_CU
))
2068 Do_Unit_And_Dependents
2069 (Library_Unit
(Main_CU
),
2070 Unit
(Library_Unit
(Main_CU
)));
2073 -- It's a spec, process it, and the units it depends on,
2074 -- unless it is a descendant of the main unit. This can
2075 -- happen when the body of a parent depends on some other
2079 Par
:= Scope
(Defining_Entity
(Unit
(CU
)));
2081 if Is_Child_Unit
(Defining_Entity
(Unit
(CU
))) then
2083 and then Par
/= Standard_Standard
2084 and then Par
/= Cunit_Entity
(Main_Unit
)
2090 if Par
/= Cunit_Entity
(Main_Unit
) then
2091 Do_Unit_And_Dependents
(CU
, N
);
2099 -- Now process package bodies on which main depends, followed by bodies
2100 -- of parents, if present, and finally main itself.
2102 if not Done
(Main_Unit
) then
2105 Process_Main
: declare
2106 Parent_CU
: Node_Id
;
2108 Body_U
: Unit_Number_Type
;
2111 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean;
2112 -- If the main unit has subunits, their context may include
2113 -- bodies that are needed in the body of main. We must examine
2114 -- the context of the subunits, which are otherwise not made
2115 -- explicit in the main unit.
2117 ------------------------
2118 -- Is_Subunit_Of_Main --
2119 ------------------------
2121 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean is
2127 Lib
:= Library_Unit
(U
);
2128 return Nkind
(Unit
(U
)) = N_Subunit
2130 (Lib
= Cunit
(Main_Unit
)
2131 or else Is_Subunit_Of_Main
(Lib
));
2133 end Is_Subunit_Of_Main
;
2135 -- Start of processing for Process_Main
2138 Process_Bodies_In_Context
(Main_CU
);
2140 for Unit_Num
in Done
'Range loop
2141 if Is_Subunit_Of_Main
(Cunit
(Unit_Num
)) then
2142 Process_Bodies_In_Context
(Cunit
(Unit_Num
));
2146 -- If the main unit is a child unit, parent bodies may be present
2147 -- because they export instances or inlined subprograms. Check for
2148 -- presence of these, which are not present in context clauses.
2149 -- Note that if the parents are instances, their bodies have been
2150 -- processed before the main spec, because they may be needed
2151 -- therein, so the following loop only affects non-instances.
2153 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
2154 Child
:= Cunit_Entity
(Main_Unit
);
2155 while Is_Child_Unit
(Child
) loop
2157 Cunit
(Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
2158 Body_CU
:= Library_Unit
(Parent_CU
);
2160 if Present
(Body_CU
)
2161 and then not Seen
(Get_Cunit_Unit_Number
(Body_CU
))
2162 and then not Depends_On_Main
(Body_CU
)
2164 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
2165 Seen
(Body_U
) := True;
2166 Do_Action
(Body_CU
, Unit
(Body_CU
));
2167 Done
(Body_U
) := True;
2170 Child
:= Scope
(Child
);
2174 Do_Action
(Main_CU
, Unit
(Main_CU
));
2175 Done
(Main_Unit
) := True;
2179 if Debug_Unit_Walk
then
2180 if Done
/= (Done
'Range => True) then
2182 Write_Line
("Ignored units:");
2186 for Unit_Num
in Done
'Range loop
2187 if not Done
(Unit_Num
) then
2189 (Unit_Num
, Unit
(Cunit
(Unit_Num
)), Withs
=> True);
2197 pragma Assert
(Done
(Main_Unit
));
2199 if Debug_Unit_Walk
then
2201 Write_Line
("end Walk_Library_Items.");
2203 end Walk_Library_Items
;
2209 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean) is
2210 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2211 pragma Assert
(Nkind
(Unit
(CU
)) /= N_Subunit
);
2213 procedure Walk_Immediate
is new Walk_Withs_Immediate
(Action
);
2216 -- First walk the withs immediately on the library item
2218 Walk_Immediate
(CU
, Include_Limited
);
2220 -- For a body, we must also check for any subunits which belong to it
2221 -- and which have context clauses of their own, since these with'ed
2222 -- units are part of its own dependencies.
2224 if Nkind
(Unit
(CU
)) in N_Unit_Body
then
2225 for S
in Main_Unit
.. Last_Unit
loop
2227 -- We are only interested in subunits. For preproc. data and def.
2228 -- files, Cunit is Empty, so we need to test that first.
2230 if Cunit
(S
) /= Empty
2231 and then Nkind
(Unit
(Cunit
(S
))) = N_Subunit
2237 Pnode
:= Library_Unit
(Cunit
(S
));
2239 -- In -gnatc mode, the errors in the subunits will not have
2240 -- been recorded, but the analysis of the subunit may have
2241 -- failed, so just quit.
2247 -- Find ultimate parent of the subunit
2249 while Nkind
(Unit
(Pnode
)) = N_Subunit
loop
2250 Pnode
:= Library_Unit
(Pnode
);
2253 -- See if it belongs to current unit, and if so, include its
2254 -- with_clauses. Do not process main unit prematurely.
2256 if Pnode
= CU
and then CU
/= Cunit
(Main_Unit
) then
2257 Walk_Immediate
(Cunit
(S
), Include_Limited
);
2265 --------------------------
2266 -- Walk_Withs_Immediate --
2267 --------------------------
2269 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean) is
2270 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2272 Context_Item
: Node_Id
;
2277 Context_Item
:= First
(Context_Items
(CU
));
2278 while Present
(Context_Item
) loop
2279 if Nkind
(Context_Item
) = N_With_Clause
2280 and then (Include_Limited
2281 or else not Limited_Present
(Context_Item
))
2283 Lib_Unit
:= Library_Unit
(Context_Item
);
2286 -- If the context item indicates that a package body is needed
2287 -- because of an instantiation in CU, traverse the body now, even
2288 -- if CU is not related to the main unit. If the generic itself
2289 -- appears in a package body, the context item is this body, and
2290 -- it already appears in the traversal order, so we only need to
2291 -- examine the case of a context item being a package declaration.
2293 if Present
(Withed_Body
(Context_Item
))
2294 and then Nkind
(Unit
(Lib_Unit
)) = N_Package_Declaration
2295 and then Present
(Corresponding_Body
(Unit
(Lib_Unit
)))
2299 (Unit_Declaration_Node
2300 (Corresponding_Body
(Unit
(Lib_Unit
))));
2302 -- A body may have an implicit with on its own spec, in which
2303 -- case we must ignore this context item to prevent looping.
2305 if Unit
(CU
) /= Unit
(Body_CU
) then
2311 Context_Item
:= Next
(Context_Item
);
2313 end Walk_Withs_Immediate
;