1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, 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. --
18 -- You should have received a copy of the GNU General Public License along --
19 -- with this program; see file COPYING3. If not see --
20 -- <http://www.gnu.org/licenses/>. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Debug_A
; use Debug_A
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Expander
; use Expander
;
33 with Fname
; use Fname
;
36 with Lib
.Load
; use Lib
.Load
;
37 with Nlists
; use Nlists
;
38 with Output
; use Output
;
39 with Sem_Attr
; use Sem_Attr
;
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 Uintp
; use Uintp
;
57 with Uname
; use Uname
;
59 with Unchecked_Deallocation
;
61 pragma Warnings
(Off
, Sem_Util
);
62 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
66 Debug_Unit_Walk
: Boolean renames Debug_Flag_Dot_WW
;
67 -- Controls debugging printouts for Walk_Library_Items
69 Outer_Generic_Scope
: Entity_Id
:= Empty
;
70 -- Global reference to the outer scope that is generic. In a non
71 -- generic context, it is empty. At the moment, it is only used
72 -- for avoiding freezing of external references in generics.
74 Comp_Unit_List
: Elist_Id
:= No_Elist
;
75 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
76 -- processed by Semantics, in an appropriate order. Initialized to
77 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
78 -- to New_Elmt_List on first use.
81 with procedure Action
(Withed_Unit
: Node_Id
);
82 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean);
83 -- Walk all the with clauses of CU, and call Action for the with'ed
84 -- unit. Ignore limited withs, unless Include_Limited is True.
85 -- CU must be an N_Compilation_Unit.
88 with procedure Action
(Withed_Unit
: Node_Id
);
89 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean);
90 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
91 -- of this unit, since they count as dependences on their parent library
92 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
94 procedure Write_Unit_Info
95 (Unit_Num
: Unit_Number_Type
;
97 Prefix
: String := "";
98 Withs
: Boolean := False);
99 -- Print out debugging information about the unit. Prefix precedes the rest
100 -- of the printout. If Withs is True, we print out units with'ed by this
101 -- unit (not counting limited withs).
107 procedure Analyze
(N
: Node_Id
) is
109 Debug_A_Entry
("analyzing ", N
);
111 -- Immediate return if already analyzed
114 Debug_A_Exit
("analyzing ", N
, " (done, analyzed already)");
118 -- Otherwise processing depends on the node kind
122 when N_Abort_Statement
=>
123 Analyze_Abort_Statement
(N
);
125 when N_Abstract_Subprogram_Declaration
=>
126 Analyze_Abstract_Subprogram_Declaration
(N
);
128 when N_Accept_Alternative
=>
129 Analyze_Accept_Alternative
(N
);
131 when N_Accept_Statement
=>
132 Analyze_Accept_Statement
(N
);
135 Analyze_Aggregate
(N
);
138 Analyze_Allocator
(N
);
141 Analyze_Short_Circuit
(N
);
143 when N_Assignment_Statement
=>
144 Analyze_Assignment
(N
);
146 when N_Asynchronous_Select
=>
147 Analyze_Asynchronous_Select
(N
);
150 Analyze_At_Clause
(N
);
152 when N_Attribute_Reference
=>
153 Analyze_Attribute
(N
);
155 when N_Attribute_Definition_Clause
=>
156 Analyze_Attribute_Definition_Clause
(N
);
158 when N_Block_Statement
=>
159 Analyze_Block_Statement
(N
);
161 when N_Case_Statement
=>
162 Analyze_Case_Statement
(N
);
164 when N_Character_Literal
=>
165 Analyze_Character_Literal
(N
);
167 when N_Code_Statement
=>
168 Analyze_Code_Statement
(N
);
170 when N_Compilation_Unit
=>
171 Analyze_Compilation_Unit
(N
);
173 when N_Component_Declaration
=>
174 Analyze_Component_Declaration
(N
);
176 when N_Conditional_Expression
=>
177 Analyze_Conditional_Expression
(N
);
179 when N_Conditional_Entry_Call
=>
180 Analyze_Conditional_Entry_Call
(N
);
182 when N_Delay_Alternative
=>
183 Analyze_Delay_Alternative
(N
);
185 when N_Delay_Relative_Statement
=>
186 Analyze_Delay_Relative
(N
);
188 when N_Delay_Until_Statement
=>
189 Analyze_Delay_Until
(N
);
192 Analyze_Entry_Body
(N
);
194 when N_Entry_Body_Formal_Part
=>
195 Analyze_Entry_Body_Formal_Part
(N
);
197 when N_Entry_Call_Alternative
=>
198 Analyze_Entry_Call_Alternative
(N
);
200 when N_Entry_Declaration
=>
201 Analyze_Entry_Declaration
(N
);
203 when N_Entry_Index_Specification
=>
204 Analyze_Entry_Index_Specification
(N
);
206 when N_Enumeration_Representation_Clause
=>
207 Analyze_Enumeration_Representation_Clause
(N
);
209 when N_Exception_Declaration
=>
210 Analyze_Exception_Declaration
(N
);
212 when N_Exception_Renaming_Declaration
=>
213 Analyze_Exception_Renaming
(N
);
215 when N_Exit_Statement
=>
216 Analyze_Exit_Statement
(N
);
218 when N_Expanded_Name
=>
219 Analyze_Expanded_Name
(N
);
221 when N_Explicit_Dereference
=>
222 Analyze_Explicit_Dereference
(N
);
224 when N_Extended_Return_Statement
=>
225 Analyze_Extended_Return_Statement
(N
);
227 when N_Extension_Aggregate
=>
228 Analyze_Aggregate
(N
);
230 when N_Formal_Object_Declaration
=>
231 Analyze_Formal_Object_Declaration
(N
);
233 when N_Formal_Package_Declaration
=>
234 Analyze_Formal_Package
(N
);
236 when N_Formal_Subprogram_Declaration
=>
237 Analyze_Formal_Subprogram
(N
);
239 when N_Formal_Type_Declaration
=>
240 Analyze_Formal_Type_Declaration
(N
);
242 when N_Free_Statement
=>
243 Analyze_Free_Statement
(N
);
245 when N_Freeze_Entity
=>
246 Analyze_Freeze_Entity
(N
);
248 when N_Full_Type_Declaration
=>
249 Analyze_Type_Declaration
(N
);
251 when N_Function_Call
=>
252 Analyze_Function_Call
(N
);
254 when N_Function_Instantiation
=>
255 Analyze_Function_Instantiation
(N
);
257 when N_Generic_Function_Renaming_Declaration
=>
258 Analyze_Generic_Function_Renaming
(N
);
260 when N_Generic_Package_Declaration
=>
261 Analyze_Generic_Package_Declaration
(N
);
263 when N_Generic_Package_Renaming_Declaration
=>
264 Analyze_Generic_Package_Renaming
(N
);
266 when N_Generic_Procedure_Renaming_Declaration
=>
267 Analyze_Generic_Procedure_Renaming
(N
);
269 when N_Generic_Subprogram_Declaration
=>
270 Analyze_Generic_Subprogram_Declaration
(N
);
272 when N_Goto_Statement
=>
273 Analyze_Goto_Statement
(N
);
275 when N_Handled_Sequence_Of_Statements
=>
276 Analyze_Handled_Statements
(N
);
279 Analyze_Identifier
(N
);
281 when N_If_Statement
=>
282 Analyze_If_Statement
(N
);
284 when N_Implicit_Label_Declaration
=>
285 Analyze_Implicit_Label_Declaration
(N
);
288 Analyze_Membership_Op
(N
);
290 when N_Incomplete_Type_Declaration
=>
291 Analyze_Incomplete_Type_Decl
(N
);
293 when N_Indexed_Component
=>
294 Analyze_Indexed_Component_Form
(N
);
296 when N_Integer_Literal
=>
297 Analyze_Integer_Literal
(N
);
299 when N_Itype_Reference
=>
300 Analyze_Itype_Reference
(N
);
305 when N_Loop_Statement
=>
306 Analyze_Loop_Statement
(N
);
309 Analyze_Membership_Op
(N
);
314 when N_Null_Statement
=>
315 Analyze_Null_Statement
(N
);
317 when N_Number_Declaration
=>
318 Analyze_Number_Declaration
(N
);
320 when N_Object_Declaration
=>
321 Analyze_Object_Declaration
(N
);
323 when N_Object_Renaming_Declaration
=>
324 Analyze_Object_Renaming
(N
);
326 when N_Operator_Symbol
=>
327 Analyze_Operator_Symbol
(N
);
330 Analyze_Unary_Op
(N
);
333 Analyze_Arithmetic_Op
(N
);
336 Analyze_Logical_Op
(N
);
339 Analyze_Concatenation
(N
);
342 Analyze_Arithmetic_Op
(N
);
345 Analyze_Equality_Op
(N
);
348 Analyze_Arithmetic_Op
(N
);
351 Analyze_Comparison_Op
(N
);
354 Analyze_Comparison_Op
(N
);
357 Analyze_Comparison_Op
(N
);
360 Analyze_Comparison_Op
(N
);
363 Analyze_Unary_Op
(N
);
366 Analyze_Arithmetic_Op
(N
);
368 when N_Op_Multiply
=>
369 Analyze_Arithmetic_Op
(N
);
372 Analyze_Equality_Op
(N
);
375 Analyze_Negation
(N
);
378 Analyze_Logical_Op
(N
);
381 Analyze_Unary_Op
(N
);
384 Analyze_Arithmetic_Op
(N
);
386 when N_Op_Rotate_Left
=>
387 Analyze_Arithmetic_Op
(N
);
389 when N_Op_Rotate_Right
=>
390 Analyze_Arithmetic_Op
(N
);
392 when N_Op_Shift_Left
=>
393 Analyze_Arithmetic_Op
(N
);
395 when N_Op_Shift_Right
=>
396 Analyze_Arithmetic_Op
(N
);
398 when N_Op_Shift_Right_Arithmetic
=>
399 Analyze_Arithmetic_Op
(N
);
401 when N_Op_Subtract
=>
402 Analyze_Arithmetic_Op
(N
);
405 Analyze_Logical_Op
(N
);
408 Analyze_Short_Circuit
(N
);
410 when N_Others_Choice
=>
411 Analyze_Others_Choice
(N
);
413 when N_Package_Body
=>
414 Analyze_Package_Body
(N
);
416 when N_Package_Body_Stub
=>
417 Analyze_Package_Body_Stub
(N
);
419 when N_Package_Declaration
=>
420 Analyze_Package_Declaration
(N
);
422 when N_Package_Instantiation
=>
423 Analyze_Package_Instantiation
(N
);
425 when N_Package_Renaming_Declaration
=>
426 Analyze_Package_Renaming
(N
);
428 when N_Package_Specification
=>
429 Analyze_Package_Specification
(N
);
431 when N_Parameter_Association
=>
432 Analyze_Parameter_Association
(N
);
437 when N_Private_Extension_Declaration
=>
438 Analyze_Private_Extension_Declaration
(N
);
440 when N_Private_Type_Declaration
=>
441 Analyze_Private_Type_Declaration
(N
);
443 when N_Procedure_Call_Statement
=>
444 Analyze_Procedure_Call
(N
);
446 when N_Procedure_Instantiation
=>
447 Analyze_Procedure_Instantiation
(N
);
449 when N_Protected_Body
=>
450 Analyze_Protected_Body
(N
);
452 when N_Protected_Body_Stub
=>
453 Analyze_Protected_Body_Stub
(N
);
455 when N_Protected_Definition
=>
456 Analyze_Protected_Definition
(N
);
458 when N_Protected_Type_Declaration
=>
459 Analyze_Protected_Type
(N
);
461 when N_Qualified_Expression
=>
462 Analyze_Qualified_Expression
(N
);
464 when N_Raise_Statement
=>
465 Analyze_Raise_Statement
(N
);
467 when N_Raise_xxx_Error
=>
468 Analyze_Raise_xxx_Error
(N
);
473 when N_Range_Constraint
=>
474 Analyze_Range
(Range_Expression
(N
));
476 when N_Real_Literal
=>
477 Analyze_Real_Literal
(N
);
479 when N_Record_Representation_Clause
=>
480 Analyze_Record_Representation_Clause
(N
);
483 Analyze_Reference
(N
);
485 when N_Requeue_Statement
=>
488 when N_Simple_Return_Statement
=>
489 Analyze_Simple_Return_Statement
(N
);
491 when N_Selected_Component
=>
492 Find_Selected_Component
(N
);
493 -- ??? why not Analyze_Selected_Component, needs comments
495 when N_Selective_Accept
=>
496 Analyze_Selective_Accept
(N
);
498 when N_Single_Protected_Declaration
=>
499 Analyze_Single_Protected
(N
);
501 when N_Single_Task_Declaration
=>
502 Analyze_Single_Task
(N
);
507 when N_String_Literal
=>
508 Analyze_String_Literal
(N
);
510 when N_Subprogram_Body
=>
511 Analyze_Subprogram_Body
(N
);
513 when N_Subprogram_Body_Stub
=>
514 Analyze_Subprogram_Body_Stub
(N
);
516 when N_Subprogram_Declaration
=>
517 Analyze_Subprogram_Declaration
(N
);
519 when N_Subprogram_Info
=>
520 Analyze_Subprogram_Info
(N
);
522 when N_Subprogram_Renaming_Declaration
=>
523 Analyze_Subprogram_Renaming
(N
);
525 when N_Subtype_Declaration
=>
526 Analyze_Subtype_Declaration
(N
);
528 when N_Subtype_Indication
=>
529 Analyze_Subtype_Indication
(N
);
535 Analyze_Task_Body
(N
);
537 when N_Task_Body_Stub
=>
538 Analyze_Task_Body_Stub
(N
);
540 when N_Task_Definition
=>
541 Analyze_Task_Definition
(N
);
543 when N_Task_Type_Declaration
=>
544 Analyze_Task_Type
(N
);
546 when N_Terminate_Alternative
=>
547 Analyze_Terminate_Alternative
(N
);
549 when N_Timed_Entry_Call
=>
550 Analyze_Timed_Entry_Call
(N
);
552 when N_Triggering_Alternative
=>
553 Analyze_Triggering_Alternative
(N
);
555 when N_Type_Conversion
=>
556 Analyze_Type_Conversion
(N
);
558 when N_Unchecked_Expression
=>
559 Analyze_Unchecked_Expression
(N
);
561 when N_Unchecked_Type_Conversion
=>
562 Analyze_Unchecked_Type_Conversion
(N
);
564 when N_Use_Package_Clause
=>
565 Analyze_Use_Package
(N
);
567 when N_Use_Type_Clause
=>
568 Analyze_Use_Type
(N
);
570 when N_Validate_Unchecked_Conversion
=>
573 when N_Variant_Part
=>
574 Analyze_Variant_Part
(N
);
576 when N_With_Clause
=>
577 Analyze_With_Clause
(N
);
579 -- A call to analyze the Empty node is an error, but most likely
580 -- it is an error caused by an attempt to analyze a malformed
581 -- piece of tree caused by some other error, so if there have
582 -- been any other errors, we just ignore it, otherwise it is
583 -- a real internal error which we complain about.
585 -- We must also consider the case of call to a runtime function
586 -- that is not available in the configurable runtime.
589 pragma Assert
(Serious_Errors_Detected
/= 0
590 or else Configurable_Run_Time_Violations
/= 0);
593 -- A call to analyze the error node is simply ignored, to avoid
594 -- causing cascaded errors (happens of course only in error cases)
599 -- Push/Pop nodes normally don't come through an analyze call. An
600 -- exception is the dummy ones bracketing a subprogram body. In any
601 -- case there is nothing to be done to analyze such nodes.
603 when N_Push_Pop_xxx_Label
=>
606 -- SCIL nodes don't need analysis because they are decorated when
607 -- they are built. They are added to the tree by Insert_Actions and
608 -- the call to analyze them is generated when the full list is
612 N_SCIL_Dispatch_Table_Object_Init |
613 N_SCIL_Dispatch_Table_Tag_Init |
614 N_SCIL_Dispatching_Call |
615 N_SCIL_Membership_Test |
619 -- For the remaining node types, we generate compiler abort, because
620 -- these nodes are always analyzed within the Sem_Chn routines and
621 -- there should never be a case of making a call to the main Analyze
622 -- routine for these node kinds. For example, an N_Access_Definition
623 -- node appears only in the context of a type declaration, and is
624 -- processed by the analyze routine for type declarations.
628 N_Access_Definition |
629 N_Access_Function_Definition |
630 N_Access_Procedure_Definition |
631 N_Access_To_Object_Definition |
632 N_Case_Statement_Alternative |
633 N_Compilation_Unit_Aux |
634 N_Component_Association |
636 N_Component_Definition |
638 N_Constrained_Array_Definition |
639 N_Decimal_Fixed_Point_Definition |
640 N_Defining_Character_Literal |
641 N_Defining_Identifier |
642 N_Defining_Operator_Symbol |
643 N_Defining_Program_Unit_Name |
645 N_Derived_Type_Definition |
647 N_Digits_Constraint |
648 N_Discriminant_Association |
649 N_Discriminant_Specification |
651 N_Entry_Call_Statement |
652 N_Enumeration_Type_Definition |
653 N_Exception_Handler |
654 N_Floating_Point_Definition |
655 N_Formal_Decimal_Fixed_Point_Definition |
656 N_Formal_Derived_Type_Definition |
657 N_Formal_Discrete_Type_Definition |
658 N_Formal_Floating_Point_Definition |
659 N_Formal_Modular_Type_Definition |
660 N_Formal_Ordinary_Fixed_Point_Definition |
661 N_Formal_Private_Type_Definition |
662 N_Formal_Signed_Integer_Type_Definition |
663 N_Function_Specification |
664 N_Generic_Association |
665 N_Index_Or_Discriminant_Constraint |
667 N_Loop_Parameter_Specification |
669 N_Modular_Type_Definition |
670 N_Ordinary_Fixed_Point_Definition |
671 N_Parameter_Specification |
672 N_Pragma_Argument_Association |
673 N_Procedure_Specification |
674 N_Real_Range_Specification |
675 N_Record_Definition |
676 N_Signed_Integer_Type_Definition |
677 N_Unconstrained_Array_Definition |
685 Debug_A_Exit
("analyzing ", N
, " (done)");
687 -- Now that we have analyzed the node, we call the expander to perform
688 -- possible expansion. We skip this for subexpressions, because we don't
689 -- have the type yet, and the expander will need to know the type before
690 -- it can do its job. For subexpression nodes, the call to the expander
691 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
692 -- which can appear in a statement context, and needs expanding now in
693 -- the case (distinguished by Etype, as documented in Sinfo).
695 -- The Analyzed flag is also set at this point for non-subexpression
696 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
697 -- since resolution and expansion have not yet been completed). Note
698 -- that for N_Raise_xxx_Error we have to distinguish the expression
699 -- case from the statement case.
701 if Nkind
(N
) not in N_Subexpr
702 or else (Nkind
(N
) in N_Raise_xxx_Error
703 and then Etype
(N
) = Standard_Void_Type
)
709 -- Version with check(s) suppressed
711 procedure Analyze
(N
: Node_Id
; Suppress
: Check_Id
) is
713 if Suppress
= All_Checks
then
715 Svg
: constant Suppress_Array
:= Scope_Suppress
;
717 Scope_Suppress
:= (others => True);
719 Scope_Suppress
:= Svg
;
724 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
726 Scope_Suppress
(Suppress
) := True;
728 Scope_Suppress
(Suppress
) := Svg
;
737 procedure Analyze_List
(L
: List_Id
) is
742 while Present
(Node
) loop
748 -- Version with check(s) suppressed
750 procedure Analyze_List
(L
: List_Id
; Suppress
: Check_Id
) is
752 if Suppress
= All_Checks
then
754 Svg
: constant Suppress_Array
:= Scope_Suppress
;
756 Scope_Suppress
:= (others => True);
758 Scope_Suppress
:= Svg
;
763 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
765 Scope_Suppress
(Suppress
) := True;
767 Scope_Suppress
(Suppress
) := Svg
;
772 --------------------------
773 -- Copy_Suppress_Status --
774 --------------------------
776 procedure Copy_Suppress_Status
782 pragma Warnings
(Off
, Found
);
784 procedure Search_Stack
785 (Top
: Suppress_Stack_Entry_Ptr
;
786 Found
: out Boolean);
787 -- Search given suppress stack for matching entry for entity. If found
788 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
789 -- entry for To onto the local suppress stack.
795 procedure Search_Stack
796 (Top
: Suppress_Stack_Entry_Ptr
;
799 Ptr
: Suppress_Stack_Entry_Ptr
;
803 while Ptr
/= null loop
805 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
808 Set_Checks_May_Be_Suppressed
(To
, True);
809 Push_Local_Suppress_Stack_Entry
825 -- Start of processing for Copy_Suppress_Status
828 if not Checks_May_Be_Suppressed
(From
) then
832 -- First search the local entity suppress stack, we search this in
833 -- reverse order so that we get the innermost entry that applies to
834 -- this case if there are nested entries. Note that for the purpose
835 -- of this procedure we are ONLY looking for entries corresponding
836 -- to a two-argument Suppress, where the second argument matches From.
838 Search_Stack
(Global_Suppress_Stack_Top
, Found
);
844 -- Now search the global entity suppress table for a matching entry
845 -- We also search this in reverse order so that if there are multiple
846 -- pragmas for the same entity, the last one applies.
848 Search_Stack
(Local_Suppress_Stack_Top
, Found
);
849 end Copy_Suppress_Status
;
851 -------------------------
852 -- Enter_Generic_Scope --
853 -------------------------
855 procedure Enter_Generic_Scope
(S
: Entity_Id
) is
857 if No
(Outer_Generic_Scope
) then
858 Outer_Generic_Scope
:= S
;
860 end Enter_Generic_Scope
;
862 ------------------------
863 -- Exit_Generic_Scope --
864 ------------------------
866 procedure Exit_Generic_Scope
(S
: Entity_Id
) is
868 if S
= Outer_Generic_Scope
then
869 Outer_Generic_Scope
:= Empty
;
871 end Exit_Generic_Scope
;
873 -----------------------
874 -- Explicit_Suppress --
875 -----------------------
877 function Explicit_Suppress
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
878 Ptr
: Suppress_Stack_Entry_Ptr
;
881 if not Checks_May_Be_Suppressed
(E
) then
885 Ptr
:= Global_Suppress_Stack_Top
;
886 while Ptr
/= null loop
888 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
898 end Explicit_Suppress
;
900 -----------------------------
901 -- External_Ref_In_Generic --
902 -----------------------------
904 function External_Ref_In_Generic
(E
: Entity_Id
) return Boolean is
908 -- Entity is global if defined outside of current outer_generic_scope:
909 -- Either the entity has a smaller depth that the outer generic, or it
910 -- is in a different compilation unit, or it is defined within a unit
911 -- in the same compilation, that is not within the outer_generic.
913 if No
(Outer_Generic_Scope
) then
916 elsif Scope_Depth
(Scope
(E
)) < Scope_Depth
(Outer_Generic_Scope
)
917 or else not In_Same_Source_Unit
(E
, Outer_Generic_Scope
)
924 while Present
(Scop
) loop
925 if Scop
= Outer_Generic_Scope
then
927 elsif Scope_Depth
(Scop
) < Scope_Depth
(Outer_Generic_Scope
) then
930 Scop
:= Scope
(Scop
);
936 end External_Ref_In_Generic
;
942 procedure Initialize
is
943 Next
: Suppress_Stack_Entry_Ptr
;
945 procedure Free
is new Unchecked_Deallocation
946 (Suppress_Stack_Entry
, Suppress_Stack_Entry_Ptr
);
949 -- Free any global suppress stack entries from a previous invocation
950 -- of the compiler (in the normal case this loop does nothing).
952 while Suppress_Stack_Entries
/= null loop
953 Next
:= Global_Suppress_Stack_Top
.Next
;
954 Free
(Suppress_Stack_Entries
);
955 Suppress_Stack_Entries
:= Next
;
958 Local_Suppress_Stack_Top
:= null;
959 Global_Suppress_Stack_Top
:= null;
961 -- Clear scope stack, and reset global variables
964 Unloaded_Subunits
:= False;
967 ------------------------------
968 -- Insert_After_And_Analyze --
969 ------------------------------
971 procedure Insert_After_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
977 -- If we are not at the end of the list, then the easiest
978 -- coding is simply to insert before our successor
980 if Present
(Next
(N
)) then
981 Insert_Before_And_Analyze
(Next
(N
), M
);
983 -- Case of inserting at the end of the list
986 -- Capture the Node_Id of the node to be inserted. This Node_Id
987 -- will still be the same after the insert operation.
992 -- Now just analyze from the inserted node to the end of
993 -- the new list (note that this properly handles the case
994 -- where any of the analyze calls result in the insertion of
995 -- nodes after the analyzed node, expecting analysis).
997 while Present
(Node
) loop
999 Mark_Rewrite_Insertion
(Node
);
1004 end Insert_After_And_Analyze
;
1006 -- Version with check(s) suppressed
1008 procedure Insert_After_And_Analyze
1011 Suppress
: Check_Id
)
1014 if Suppress
= All_Checks
then
1016 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1018 Scope_Suppress
:= (others => True);
1019 Insert_After_And_Analyze
(N
, M
);
1020 Scope_Suppress
:= Svg
;
1025 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1027 Scope_Suppress
(Suppress
) := True;
1028 Insert_After_And_Analyze
(N
, M
);
1029 Scope_Suppress
(Suppress
) := Svg
;
1032 end Insert_After_And_Analyze
;
1034 -------------------------------
1035 -- Insert_Before_And_Analyze --
1036 -------------------------------
1038 procedure Insert_Before_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
1044 -- Capture the Node_Id of the first list node to be inserted.
1045 -- This will still be the first node after the insert operation,
1046 -- since Insert_List_After does not modify the Node_Id values.
1049 Insert_Before
(N
, M
);
1051 -- The insertion does not change the Id's of any of the nodes in
1052 -- the list, and they are still linked, so we can simply loop from
1053 -- the original first node until we meet the node before which the
1054 -- insertion is occurring. Note that this properly handles the case
1055 -- where any of the analyzed nodes insert nodes after themselves,
1056 -- expecting them to get analyzed.
1058 while Node
/= N
loop
1060 Mark_Rewrite_Insertion
(Node
);
1064 end Insert_Before_And_Analyze
;
1066 -- Version with check(s) suppressed
1068 procedure Insert_Before_And_Analyze
1071 Suppress
: Check_Id
)
1074 if Suppress
= All_Checks
then
1076 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1078 Scope_Suppress
:= (others => True);
1079 Insert_Before_And_Analyze
(N
, M
);
1080 Scope_Suppress
:= Svg
;
1085 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1087 Scope_Suppress
(Suppress
) := True;
1088 Insert_Before_And_Analyze
(N
, M
);
1089 Scope_Suppress
(Suppress
) := Svg
;
1092 end Insert_Before_And_Analyze
;
1094 -----------------------------------
1095 -- Insert_List_After_And_Analyze --
1096 -----------------------------------
1098 procedure Insert_List_After_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1099 After
: constant Node_Id
:= Next
(N
);
1103 if Is_Non_Empty_List
(L
) then
1105 -- Capture the Node_Id of the first list node to be inserted.
1106 -- This will still be the first node after the insert operation,
1107 -- since Insert_List_After does not modify the Node_Id values.
1110 Insert_List_After
(N
, L
);
1112 -- Now just analyze from the original first node until we get to
1113 -- the successor of the original insertion point (which may be
1114 -- Empty if the insertion point was at the end of the list). Note
1115 -- that this properly handles the case where any of the analyze
1116 -- calls result in the insertion of nodes after the analyzed
1117 -- node (possibly calling this routine recursively).
1119 while Node
/= After
loop
1121 Mark_Rewrite_Insertion
(Node
);
1125 end Insert_List_After_And_Analyze
;
1127 -- Version with check(s) suppressed
1129 procedure Insert_List_After_And_Analyze
1130 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1133 if Suppress
= All_Checks
then
1135 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1137 Scope_Suppress
:= (others => True);
1138 Insert_List_After_And_Analyze
(N
, L
);
1139 Scope_Suppress
:= Svg
;
1144 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1146 Scope_Suppress
(Suppress
) := True;
1147 Insert_List_After_And_Analyze
(N
, L
);
1148 Scope_Suppress
(Suppress
) := Svg
;
1151 end Insert_List_After_And_Analyze
;
1153 ------------------------------------
1154 -- Insert_List_Before_And_Analyze --
1155 ------------------------------------
1157 procedure Insert_List_Before_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1161 if Is_Non_Empty_List
(L
) then
1163 -- Capture the Node_Id of the first list node to be inserted.
1164 -- This will still be the first node after the insert operation,
1165 -- since Insert_List_After does not modify the Node_Id values.
1168 Insert_List_Before
(N
, L
);
1170 -- The insertion does not change the Id's of any of the nodes in
1171 -- the list, and they are still linked, so we can simply loop from
1172 -- the original first node until we meet the node before which the
1173 -- insertion is occurring. Note that this properly handles the case
1174 -- where any of the analyzed nodes insert nodes after themselves,
1175 -- expecting them to get analyzed.
1177 while Node
/= N
loop
1179 Mark_Rewrite_Insertion
(Node
);
1183 end Insert_List_Before_And_Analyze
;
1185 -- Version with check(s) suppressed
1187 procedure Insert_List_Before_And_Analyze
1188 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1191 if Suppress
= All_Checks
then
1193 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1195 Scope_Suppress
:= (others => True);
1196 Insert_List_Before_And_Analyze
(N
, L
);
1197 Scope_Suppress
:= Svg
;
1202 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1204 Scope_Suppress
(Suppress
) := True;
1205 Insert_List_Before_And_Analyze
(N
, L
);
1206 Scope_Suppress
(Suppress
) := Svg
;
1209 end Insert_List_Before_And_Analyze
;
1211 -------------------------
1212 -- Is_Check_Suppressed --
1213 -------------------------
1215 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
1217 Ptr
: Suppress_Stack_Entry_Ptr
;
1220 -- First search the local entity suppress stack, we search this from the
1221 -- top of the stack down, so that we get the innermost entry that
1222 -- applies to this case if there are nested entries.
1224 Ptr
:= Local_Suppress_Stack_Top
;
1225 while Ptr
/= null loop
1226 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
1227 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
1229 return Ptr
.Suppress
;
1235 -- Now search the global entity suppress table for a matching entry
1236 -- We also search this from the top down so that if there are multiple
1237 -- pragmas for the same entity, the last one applies (not clear what
1238 -- or whether the RM specifies this handling, but it seems reasonable).
1240 Ptr
:= Global_Suppress_Stack_Top
;
1241 while Ptr
/= null loop
1242 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
1243 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
1245 return Ptr
.Suppress
;
1251 -- If we did not find a matching entry, then use the normal scope
1252 -- suppress value after all (actually this will be the global setting
1253 -- since it clearly was not overridden at any point). For a predefined
1254 -- check, we test the specific flag. For a user defined check, we check
1255 -- the All_Checks flag.
1257 if C
in Predefined_Check_Id
then
1258 return Scope_Suppress
(C
);
1260 return Scope_Suppress
(All_Checks
);
1262 end Is_Check_Suppressed
;
1270 Scope_Stack
.Locked
:= True;
1271 Scope_Stack
.Release
;
1274 --------------------------------------
1275 -- Push_Global_Suppress_Stack_Entry --
1276 --------------------------------------
1278 procedure Push_Global_Suppress_Stack_Entry
1279 (Entity
: Entity_Id
;
1284 Global_Suppress_Stack_Top
:=
1285 new Suppress_Stack_Entry
'
1288 Suppress => Suppress,
1289 Prev => Global_Suppress_Stack_Top,
1290 Next => Suppress_Stack_Entries);
1291 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1294 end Push_Global_Suppress_Stack_Entry;
1296 -------------------------------------
1297 -- Push_Local_Suppress_Stack_Entry --
1298 -------------------------------------
1300 procedure Push_Local_Suppress_Stack_Entry
1301 (Entity : Entity_Id;
1306 Local_Suppress_Stack_Top :=
1307 new Suppress_Stack_Entry'
1310 Suppress
=> Suppress
,
1311 Prev
=> Local_Suppress_Stack_Top
,
1312 Next
=> Suppress_Stack_Entries
);
1313 Suppress_Stack_Entries
:= Local_Suppress_Stack_Top
;
1316 end Push_Local_Suppress_Stack_Entry
;
1322 procedure Semantics
(Comp_Unit
: Node_Id
) is
1324 -- The following locations save the corresponding global flags and
1325 -- variables so that they can be restored on completion. This is
1326 -- needed so that calls to Rtsfind start with the proper default
1327 -- values for these variables, and also that such calls do not
1328 -- disturb the settings for units being analyzed at a higher level.
1330 S_Current_Sem_Unit
: constant Unit_Number_Type
:= Current_Sem_Unit
;
1331 S_Full_Analysis
: constant Boolean := Full_Analysis
;
1332 S_GNAT_Mode
: constant Boolean := GNAT_Mode
;
1333 S_Global_Dis_Names
: constant Boolean := Global_Discard_Names
;
1334 S_In_Spec_Expr
: constant Boolean := In_Spec_Expression
;
1335 S_Inside_A_Generic
: constant Boolean := Inside_A_Generic
;
1336 S_New_Nodes_OK
: constant Int
:= New_Nodes_OK
;
1337 S_Outer_Gen_Scope
: constant Entity_Id
:= Outer_Generic_Scope
;
1339 Generic_Main
: constant Boolean :=
1340 Nkind
(Unit
(Cunit
(Main_Unit
)))
1341 in N_Generic_Declaration
;
1342 -- If the main unit is generic, every compiled unit, including its
1343 -- context, is compiled with expansion disabled.
1345 Save_Config_Switches
: Config_Switches_Type
;
1346 -- Variable used to save values of config switches while we analyze
1347 -- the new unit, to be restored on exit for proper recursive behavior.
1349 procedure Do_Analyze
;
1350 -- Procedure to analyze the compilation unit. This is called more
1351 -- than once when the high level optimizer is activated.
1357 procedure Do_Analyze
is
1360 Push_Scope
(Standard_Standard
);
1361 Scope_Suppress
:= Suppress_Options
;
1363 (Scope_Stack
.Last
).Component_Alignment_Default
:= Calign_Default
;
1365 (Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
1366 Outer_Generic_Scope
:= Empty
;
1368 -- Now analyze the top level compilation unit node
1370 Analyze
(Comp_Unit
);
1372 -- Check for scope mismatch on exit from compilation
1374 pragma Assert
(Current_Scope
= Standard_Standard
1375 or else Comp_Unit
= Cunit
(Main_Unit
));
1377 -- Then pop entry for Standard, and pop implicit types
1380 Restore_Scope_Stack
;
1383 Already_Analyzed
: constant Boolean := Analyzed
(Comp_Unit
);
1385 -- Start of processing for Semantics
1388 if Debug_Unit_Walk
then
1389 if Already_Analyzed
then
1390 Write_Str
("(done)");
1394 (Get_Cunit_Unit_Number
(Comp_Unit
),
1400 Compiler_State
:= Analyzing
;
1401 Current_Sem_Unit
:= Get_Cunit_Unit_Number
(Comp_Unit
);
1403 -- Compile predefined units with GNAT_Mode set to True, to properly
1404 -- process the categorization stuff. However, do not set GNAT_Mode
1405 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1406 -- Sequential_IO) as this would prevent pragma Extend_System from being
1407 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1409 -- Cleaner might be to do the kludge at the point of excluding the
1410 -- pragma (do not exclude for renamings ???)
1412 if Is_Predefined_File_Name
1413 (Unit_File_Name
(Current_Sem_Unit
), Renamings_Included
=> False)
1418 if Generic_Main
then
1419 Expander_Mode_Save_And_Set
(False);
1421 Expander_Mode_Save_And_Set
1422 (Operating_Mode
= Generate_Code
or Debug_Flag_X
);
1425 Full_Analysis
:= True;
1426 Inside_A_Generic
:= False;
1427 In_Spec_Expression
:= False;
1429 Set_Comes_From_Source_Default
(False);
1430 Save_Opt_Config_Switches
(Save_Config_Switches
);
1431 Set_Opt_Config_Switches
1432 (Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
)),
1433 Current_Sem_Unit
= Main_Unit
);
1435 -- Only do analysis of unit that has not already been analyzed
1437 if not Analyzed
(Comp_Unit
) then
1438 Initialize_Version
(Current_Sem_Unit
);
1440 Expander_Mode_Save_And_Set
(False);
1443 Reset_Analyzed_Flags
(Comp_Unit
);
1444 Expander_Mode_Restore
;
1445 High_Level_Optimize
(Comp_Unit
);
1449 -- Do analysis, and then append the compilation unit onto the
1450 -- Comp_Unit_List, if appropriate. This is done after analysis, so
1451 -- if this unit depends on some others, they have already been
1452 -- appended. We ignore bodies, except for the main unit itself. We
1453 -- have also to guard against ill-formed subunits that have an
1454 -- improper context.
1458 if Present
(Comp_Unit
)
1459 and then Nkind
(Unit
(Comp_Unit
)) in N_Proper_Body
1460 and then not In_Extended_Main_Source_Unit
(Comp_Unit
)
1465 -- Initialize if first time
1467 if No
(Comp_Unit_List
) then
1468 Comp_Unit_List
:= New_Elmt_List
;
1471 Append_Elmt
(Comp_Unit
, Comp_Unit_List
);
1473 if Debug_Unit_Walk
then
1474 Write_Str
("Appending ");
1476 (Get_Cunit_Unit_Number
(Comp_Unit
), Unit
(Comp_Unit
));
1481 -- Save indication of dynamic elaboration checks for ALI file
1483 Set_Dynamic_Elab
(Current_Sem_Unit
, Dynamic_Elaboration_Checks
);
1485 -- Restore settings of saved switches to entry values
1487 Current_Sem_Unit
:= S_Current_Sem_Unit
;
1488 Full_Analysis
:= S_Full_Analysis
;
1489 Global_Discard_Names
:= S_Global_Dis_Names
;
1490 GNAT_Mode
:= S_GNAT_Mode
;
1491 In_Spec_Expression
:= S_In_Spec_Expr
;
1492 Inside_A_Generic
:= S_Inside_A_Generic
;
1493 New_Nodes_OK
:= S_New_Nodes_OK
;
1494 Outer_Generic_Scope
:= S_Outer_Gen_Scope
;
1496 Restore_Opt_Config_Switches
(Save_Config_Switches
);
1497 Expander_Mode_Restore
;
1499 if Debug_Unit_Walk
then
1502 if Already_Analyzed
then
1503 Write_Str
("(done)");
1507 (Get_Cunit_Unit_Number
(Comp_Unit
),
1513 ------------------------
1514 -- Walk_Library_Items --
1515 ------------------------
1517 procedure Walk_Library_Items
is
1518 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
1519 pragma Pack
(Unit_Number_Set
);
1520 Seen
, Done
: Unit_Number_Set
:= (others => False);
1521 -- Seen (X) is True after we have seen unit X in the walk. This is used
1522 -- to prevent processing the same unit more than once. Done (X) is True
1523 -- after we have fully processed X, and is used only for debugging
1524 -- printouts and assertions.
1526 Do_Main
: Boolean := False;
1527 -- Flag to delay processing the main body until after all other units.
1528 -- This is needed because the spec of the main unit may appear in the
1529 -- context of some other unit. We do not want this to force processing
1530 -- of the main body before all other units have been processed.
1532 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
);
1533 -- Calls Action, with some validity checks
1535 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
);
1536 -- Calls Do_Action, first on the units with'ed by this one, then on
1537 -- this unit. If it's an instance body, do the spec first. If it is
1538 -- an instance spec, do the body last.
1544 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
) is
1546 -- This calls Action at the end. All the preceding code is just
1547 -- assertions and debugging output.
1549 pragma Assert
(No
(CU
) or else Nkind
(CU
) = N_Compilation_Unit
);
1551 case Nkind
(Item
) is
1552 when N_Generic_Subprogram_Declaration |
1553 N_Generic_Package_Declaration |
1554 N_Package_Declaration |
1555 N_Subprogram_Declaration |
1556 N_Subprogram_Renaming_Declaration |
1557 N_Package_Renaming_Declaration |
1558 N_Generic_Function_Renaming_Declaration |
1559 N_Generic_Package_Renaming_Declaration |
1560 N_Generic_Procedure_Renaming_Declaration
=>
1566 when N_Package_Body
=>
1568 -- Package bodies are processed immediately after the
1569 -- corresponding spec.
1573 when N_Subprogram_Body
=>
1575 -- A subprogram body must be the main unit
1577 pragma Assert
(Acts_As_Spec
(CU
)
1578 or else CU
= Cunit
(Main_Unit
));
1581 -- All other cases cannot happen
1583 when N_Function_Instantiation |
1584 N_Procedure_Instantiation |
1585 N_Package_Instantiation
=>
1586 pragma Assert
(False, "instantiation");
1590 pragma Assert
(False, "subunit");
1594 pragma Assert
(False);
1598 if Present
(CU
) then
1599 pragma Assert
(Item
/= Stand
.Standard_Package_Node
);
1600 pragma Assert
(Item
= Unit
(CU
));
1603 Unit_Num
: constant Unit_Number_Type
:=
1604 Get_Cunit_Unit_Number
(CU
);
1606 procedure Assert_Done
(Withed_Unit
: Node_Id
);
1607 -- Assert Withed_Unit is already Done, unless it's a body. It
1608 -- might seem strange for a with_clause to refer to a body, but
1609 -- this happens in the case of a generic instantiation, which
1610 -- gets transformed into the instance body (and the instance
1611 -- spec is also created). With clauses pointing to the
1612 -- instantiation end up pointing to the instance body.
1618 procedure Assert_Done
(Withed_Unit
: Node_Id
) is
1620 if not Done
(Get_Cunit_Unit_Number
(Withed_Unit
)) then
1622 (Unit
(Withed_Unit
),
1623 N_Generic_Package_Declaration
,
1628 (Unit_Name
(Get_Cunit_Unit_Number
(Withed_Unit
)));
1629 Write_Str
(" not yet walked!");
1631 if Get_Cunit_Unit_Number
(Withed_Unit
) = Unit_Num
then
1632 Write_Str
(" (self-ref)");
1637 pragma Assert
(False);
1642 procedure Assert_Withed_Units_Done
is
1643 new Walk_Withs
(Assert_Done
);
1646 if Debug_Unit_Walk
then
1647 Write_Unit_Info
(Unit_Num
, Item
, Withs
=> True);
1650 -- Main unit should come last (except in the case where we
1651 -- skipped System_Aux_Id, in which case we missed the things it
1655 (not Done
(Main_Unit
) or else Present
(System_Aux_Id
));
1657 -- We shouldn't do the same thing twice
1659 pragma Assert
(not Done
(Unit_Num
));
1661 -- Everything we depend upon should already be done
1664 (Assert_Withed_Units_Done
(CU
, Include_Limited
=> False));
1668 -- Must be Standard, which has no entry in the units table
1670 pragma Assert
(Item
= Stand
.Standard_Package_Node
);
1672 if Debug_Unit_Walk
then
1673 Write_Line
("Standard");
1680 ----------------------------
1681 -- Do_Unit_And_Dependents --
1682 ----------------------------
1684 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
) is
1685 Unit_Num
: constant Unit_Number_Type
:=
1686 Get_Cunit_Unit_Number
(CU
);
1688 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
);
1689 -- Pass the buck to Do_Unit_And_Dependents
1691 --------------------
1692 -- Do_Withed_Unit --
1693 --------------------
1695 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
) is
1696 Save_Do_Main
: constant Boolean := Do_Main
;
1699 -- Do not process the main unit if coming from a with_clause,
1700 -- as would happen with a parent body that has a child spec
1704 Do_Unit_And_Dependents
(Withed_Unit
, Unit
(Withed_Unit
));
1705 Do_Main
:= Save_Do_Main
;
1708 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
1710 -- Start of processing for Do_Unit_And_Dependents
1713 if not Seen
(Unit_Num
) then
1715 -- Process the with clauses
1717 Do_Withed_Units
(CU
, Include_Limited
=> False);
1719 -- Process the unit if it is a spec. If it is the main unit,
1720 -- process it only if we have done all other units.
1722 if not Nkind_In
(Item
, N_Package_Body
, N_Subprogram_Body
)
1723 or else Acts_As_Spec
(CU
)
1725 if CU
= Cunit
(Main_Unit
) and then not Do_Main
then
1726 Seen
(Unit_Num
) := False;
1729 Seen
(Unit_Num
) := True;
1730 Do_Action
(CU
, Item
);
1731 Done
(Unit_Num
) := True;
1736 -- Process bodies. The spec, if present, has been processed already.
1737 -- A body appears if it is the main, or the body of a spec that is
1738 -- in the context of the main unit, and that is instantiated, or else
1739 -- contains a generic that is instantiated, or a subprogram that is
1740 -- or a subprogram that is inlined in the main unit.
1742 -- We exclude bodies that may appear in a circular dependency list,
1743 -- where spec A depends on spec B and body of B depends on spec A.
1744 -- This is not an elaboration issue, but body B must be excluded
1745 -- from the processing.
1748 Body_Unit
: Node_Id
:= Empty
;
1749 Body_Num
: Unit_Number_Type
;
1751 function Circular_Dependence
(B
: Node_Id
) return Boolean;
1752 -- Check whether this body depends on a spec that is pending,
1753 -- that is to say has been seen but not processed yet.
1755 -------------------------
1756 -- Circular_Dependence --
1757 -------------------------
1759 function Circular_Dependence
(B
: Node_Id
) return Boolean is
1761 UN
: Unit_Number_Type
;
1764 Item
:= First
(Context_Items
(B
));
1765 while Present
(Item
) loop
1766 if Nkind
(Item
) = N_With_Clause
then
1767 UN
:= Get_Cunit_Unit_Number
(Library_Unit
(Item
));
1770 and then not Done
(UN
)
1780 end Circular_Dependence
;
1783 if Nkind
(Item
) = N_Package_Declaration
then
1784 Body_Unit
:= Library_Unit
(CU
);
1786 elsif Nkind_In
(Item
, N_Package_Body
, N_Subprogram_Body
) then
1790 if Present
(Body_Unit
)
1792 -- Since specs and bodies are not done at the same time,
1793 -- guard against listing a body more than once. Bodies are
1794 -- only processed when the main unit is being processed,
1795 -- after all other units in the list. The DEC extension
1796 -- to System is excluded because of circularities.
1798 and then not Seen
(Get_Cunit_Unit_Number
(Body_Unit
))
1801 or else Unit_Num
/= Get_Source_Unit
(System_Aux_Id
))
1802 and then not Circular_Dependence
(Body_Unit
)
1805 Body_Num
:= Get_Cunit_Unit_Number
(Body_Unit
);
1806 Seen
(Body_Num
) := True;
1807 Do_Action
(Body_Unit
, Unit
(Body_Unit
));
1808 Done
(Body_Num
) := True;
1811 end Do_Unit_And_Dependents
;
1813 -- Local Declarations
1817 -- Start of processing for Walk_Library_Items
1820 if Debug_Unit_Walk
then
1821 Write_Line
("Walk_Library_Items:");
1825 -- Do Standard first, then walk the Comp_Unit_List
1827 Do_Action
(Empty
, Standard_Package_Node
);
1829 -- First place the context of all instance bodies on the corresponding
1830 -- spec, because it may be needed to analyze the code at the place of
1831 -- the instantiation.
1833 Cur
:= First_Elmt
(Comp_Unit_List
);
1834 while Present
(Cur
) loop
1836 CU
: constant Node_Id
:= Node
(Cur
);
1837 N
: constant Node_Id
:= Unit
(CU
);
1840 if Nkind
(N
) = N_Package_Body
1841 and then Is_Generic_Instance
(Defining_Entity
(N
))
1844 (Context_Items
(CU
), Context_Items
(Library_Unit
(CU
)));
1851 -- Now traverse compilation units in order
1853 Cur
:= First_Elmt
(Comp_Unit_List
);
1854 while Present
(Cur
) loop
1856 CU
: constant Node_Id
:= Node
(Cur
);
1857 N
: constant Node_Id
:= Unit
(CU
);
1860 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
1864 -- If it's a body, ignore it. Bodies appear in the list only
1865 -- because of inlining/instantiations, and they are processed
1866 -- immediately after the corresponding specs. The main unit is
1867 -- processed separately after all other units.
1869 when N_Package_Body | N_Subprogram_Body
=>
1872 -- It's a spec, so just do it
1875 Do_Unit_And_Dependents
(CU
, N
);
1882 if not Done
(Main_Unit
) then
1886 Main_CU
: constant Node_Id
:= Cunit
(Main_Unit
);
1889 -- If the main unit is an instantiation, the body appears before
1890 -- the instance spec, which is added later to the unit list. Do
1891 -- the spec if present, body will follow.
1893 if Nkind
(Original_Node
(Unit
(Main_CU
)))
1894 in N_Generic_Instantiation
1895 and then Present
(Library_Unit
(Main_CU
))
1897 Do_Unit_And_Dependents
1898 (Library_Unit
(Main_CU
), Unit
(Library_Unit
(Main_CU
)));
1900 Do_Unit_And_Dependents
(Main_CU
, Unit
(Main_CU
));
1905 if Debug_Unit_Walk
then
1906 if Done
/= (Done
'Range => True) then
1908 Write_Line
("Ignored units:");
1912 for Unit_Num
in Done
'Range loop
1913 if not Done
(Unit_Num
) then
1915 (Unit_Num
, Unit
(Cunit
(Unit_Num
)), Withs
=> True);
1923 pragma Assert
(Done
(Main_Unit
));
1925 if Debug_Unit_Walk
then
1927 Write_Line
("end Walk_Library_Items.");
1929 end Walk_Library_Items
;
1935 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean) is
1936 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
1937 pragma Assert
(Nkind
(Unit
(CU
)) /= N_Subunit
);
1939 procedure Walk_Immediate
is new Walk_Withs_Immediate
(Action
);
1942 -- First walk the withs immediately on the library item
1944 Walk_Immediate
(CU
, Include_Limited
);
1946 -- For a body, we must also check for any subunits which belong to it
1947 -- and which have context clauses of their own, since these with'ed
1948 -- units are part of its own dependencies.
1950 if Nkind
(Unit
(CU
)) in N_Unit_Body
then
1951 for S
in Main_Unit
.. Last_Unit
loop
1953 -- We are only interested in subunits. For preproc. data and def.
1954 -- files, Cunit is Empty, so we need to test that first.
1956 if Cunit
(S
) /= Empty
1957 and then Nkind
(Unit
(Cunit
(S
))) = N_Subunit
1963 Pnode
:= Library_Unit
(Cunit
(S
));
1965 -- In -gnatc mode, the errors in the subunits will not have
1966 -- been recorded, but the analysis of the subunit may have
1967 -- failed, so just quit.
1973 -- Find ultimate parent of the subunit
1975 while Nkind
(Unit
(Pnode
)) = N_Subunit
loop
1976 Pnode
:= Library_Unit
(Pnode
);
1979 -- See if it belongs to current unit, and if so, include its
1980 -- with_clauses. Do not process main unit prematurely.
1982 if Pnode
= CU
and then CU
/= Cunit
(Main_Unit
) then
1983 Walk_Immediate
(Cunit
(S
), Include_Limited
);
1991 --------------------------
1992 -- Walk_Withs_Immediate --
1993 --------------------------
1995 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean) is
1996 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
1998 Context_Item
: Node_Id
;
2001 Context_Item
:= First
(Context_Items
(CU
));
2002 while Present
(Context_Item
) loop
2003 if Nkind
(Context_Item
) = N_With_Clause
2004 and then (Include_Limited
2005 or else not Limited_Present
(Context_Item
))
2007 Action
(Library_Unit
(Context_Item
));
2010 Context_Item
:= Next
(Context_Item
);
2012 end Walk_Withs_Immediate
;
2014 ---------------------
2015 -- Write_Unit_Info --
2016 ---------------------
2018 procedure Write_Unit_Info
2019 (Unit_Num
: Unit_Number_Type
;
2021 Prefix
: String := "";
2022 Withs
: Boolean := False)
2026 Write_Unit_Name
(Unit_Name
(Unit_Num
));
2027 Write_Str
(", unit ");
2028 Write_Int
(Int
(Unit_Num
));
2030 Write_Int
(Int
(Item
));
2032 Write_Str
(Node_Kind
'Image (Nkind
(Item
)));
2034 if Item
/= Original_Node
(Item
) then
2035 Write_Str
(", orig = ");
2036 Write_Int
(Int
(Original_Node
(Item
)));
2038 Write_Str
(Node_Kind
'Image (Nkind
(Original_Node
(Item
))));
2043 -- Skip the rest if we're not supposed to print the withs
2050 Context_Item
: Node_Id
;
2053 Context_Item
:= First
(Context_Items
(Cunit
(Unit_Num
)));
2054 while Present
(Context_Item
)
2055 and then (Nkind
(Context_Item
) /= N_With_Clause
2056 or else Limited_Present
(Context_Item
))
2058 Context_Item
:= Next
(Context_Item
);
2061 if Present
(Context_Item
) then
2063 Write_Line
("withs:");
2066 while Present
(Context_Item
) loop
2067 if Nkind
(Context_Item
) = N_With_Clause
2068 and then not Limited_Present
(Context_Item
)
2070 pragma Assert
(Present
(Library_Unit
(Context_Item
)));
2073 (Get_Cunit_Unit_Number
(Library_Unit
(Context_Item
))));
2075 if Implicit_With
(Context_Item
) then
2076 Write_Str
(" -- implicit");
2082 Context_Item
:= Next
(Context_Item
);
2086 Write_Line
("end withs");
2090 end Write_Unit_Info
;