1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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
;
33 with Lib
.Load
; use Lib
.Load
;
34 with Nlists
; use Nlists
;
35 with Output
; use Output
;
36 with Restrict
; use Restrict
;
37 with Sem_Attr
; use Sem_Attr
;
38 with Sem_Aux
; use Sem_Aux
;
39 with Sem_Ch2
; use Sem_Ch2
;
40 with Sem_Ch3
; use Sem_Ch3
;
41 with Sem_Ch4
; use Sem_Ch4
;
42 with Sem_Ch5
; use Sem_Ch5
;
43 with Sem_Ch6
; use Sem_Ch6
;
44 with Sem_Ch7
; use Sem_Ch7
;
45 with Sem_Ch8
; use Sem_Ch8
;
46 with Sem_Ch9
; use Sem_Ch9
;
47 with Sem_Ch10
; use Sem_Ch10
;
48 with Sem_Ch11
; use Sem_Ch11
;
49 with Sem_Ch12
; use Sem_Ch12
;
50 with Sem_Ch13
; use Sem_Ch13
;
51 with Sem_Prag
; use Sem_Prag
;
52 with Sem_Util
; use Sem_Util
;
53 with Sinfo
; use Sinfo
;
54 with Stand
; use Stand
;
55 with Uintp
; use Uintp
;
56 with Uname
; use Uname
;
58 with Unchecked_Deallocation
;
60 pragma Warnings
(Off
, Sem_Util
);
61 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
65 Debug_Unit_Walk
: Boolean renames Debug_Flag_Dot_WW
;
66 -- Controls debugging printouts for Walk_Library_Items
68 Outer_Generic_Scope
: Entity_Id
:= Empty
;
69 -- Global reference to the outer scope that is generic. In a non-generic
70 -- context, it is empty. At the moment, it is only used for avoiding
71 -- freezing of external references in generics.
73 Comp_Unit_List
: Elist_Id
:= No_Elist
;
74 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
75 -- processed by Semantics, in an appropriate order. Initialized to
76 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
77 -- to New_Elmt_List on first use.
80 with procedure Action
(Withed_Unit
: Node_Id
);
81 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean);
82 -- Walk all the with clauses of CU, and call Action for the with'ed unit.
83 -- Ignore limited withs, unless Include_Limited is True. CU must be an
84 -- N_Compilation_Unit.
87 with procedure Action
(Withed_Unit
: Node_Id
);
88 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean);
89 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
90 -- of this unit, since they count as dependences on their parent library
91 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
97 procedure Analyze
(N
: Node_Id
) is
99 Debug_A_Entry
("analyzing ", N
);
101 -- Immediate return if already analyzed
104 Debug_A_Exit
("analyzing ", N
, " (done, analyzed already)");
108 -- Otherwise processing depends on the node kind
112 when N_Abort_Statement
=>
113 Analyze_Abort_Statement
(N
);
115 when N_Abstract_Subprogram_Declaration
=>
116 Analyze_Abstract_Subprogram_Declaration
(N
);
118 when N_Accept_Alternative
=>
119 Analyze_Accept_Alternative
(N
);
121 when N_Accept_Statement
=>
122 Analyze_Accept_Statement
(N
);
125 Analyze_Aggregate
(N
);
128 Analyze_Allocator
(N
);
131 Analyze_Short_Circuit
(N
);
133 when N_Assignment_Statement
=>
134 Analyze_Assignment
(N
);
136 when N_Asynchronous_Select
=>
137 Analyze_Asynchronous_Select
(N
);
140 Analyze_At_Clause
(N
);
142 when N_Attribute_Reference
=>
143 Analyze_Attribute
(N
);
145 when N_Attribute_Definition_Clause
=>
146 Analyze_Attribute_Definition_Clause
(N
);
148 when N_Block_Statement
=>
149 Analyze_Block_Statement
(N
);
151 when N_Case_Expression
=>
152 Analyze_Case_Expression
(N
);
154 when N_Case_Statement
=>
155 Analyze_Case_Statement
(N
);
157 when N_Character_Literal
=>
158 Analyze_Character_Literal
(N
);
160 when N_Code_Statement
=>
161 Analyze_Code_Statement
(N
);
163 when N_Compilation_Unit
=>
164 Analyze_Compilation_Unit
(N
);
166 when N_Component_Declaration
=>
167 Analyze_Component_Declaration
(N
);
169 when N_Conditional_Entry_Call
=>
170 Analyze_Conditional_Entry_Call
(N
);
172 when N_Delay_Alternative
=>
173 Analyze_Delay_Alternative
(N
);
175 when N_Delay_Relative_Statement
=>
176 Analyze_Delay_Relative
(N
);
178 when N_Delay_Until_Statement
=>
179 Analyze_Delay_Until
(N
);
182 Analyze_Entry_Body
(N
);
184 when N_Entry_Body_Formal_Part
=>
185 Analyze_Entry_Body_Formal_Part
(N
);
187 when N_Entry_Call_Alternative
=>
188 Analyze_Entry_Call_Alternative
(N
);
190 when N_Entry_Declaration
=>
191 Analyze_Entry_Declaration
(N
);
193 when N_Entry_Index_Specification
=>
194 Analyze_Entry_Index_Specification
(N
);
196 when N_Enumeration_Representation_Clause
=>
197 Analyze_Enumeration_Representation_Clause
(N
);
199 when N_Exception_Declaration
=>
200 Analyze_Exception_Declaration
(N
);
202 when N_Exception_Renaming_Declaration
=>
203 Analyze_Exception_Renaming
(N
);
205 when N_Exit_Statement
=>
206 Analyze_Exit_Statement
(N
);
208 when N_Expanded_Name
=>
209 Analyze_Expanded_Name
(N
);
211 when N_Explicit_Dereference
=>
212 Analyze_Explicit_Dereference
(N
);
214 when N_Expression_Function
=>
215 Analyze_Expression_Function
(N
);
217 when N_Expression_With_Actions
=>
218 Analyze_Expression_With_Actions
(N
);
220 when N_Extended_Return_Statement
=>
221 Analyze_Extended_Return_Statement
(N
);
223 when N_Extension_Aggregate
=>
224 Analyze_Aggregate
(N
);
226 when N_Formal_Object_Declaration
=>
227 Analyze_Formal_Object_Declaration
(N
);
229 when N_Formal_Package_Declaration
=>
230 Analyze_Formal_Package_Declaration
(N
);
232 when N_Formal_Subprogram_Declaration
=>
233 Analyze_Formal_Subprogram_Declaration
(N
);
235 when N_Formal_Type_Declaration
=>
236 Analyze_Formal_Type_Declaration
(N
);
238 when N_Free_Statement
=>
239 Analyze_Free_Statement
(N
);
241 when N_Freeze_Entity
=>
242 Analyze_Freeze_Entity
(N
);
244 when N_Freeze_Generic_Entity
=>
245 Analyze_Freeze_Generic_Entity
(N
);
247 when N_Full_Type_Declaration
=>
248 Analyze_Full_Type_Declaration
(N
);
250 when N_Function_Call
=>
251 Analyze_Function_Call
(N
);
253 when N_Function_Instantiation
=>
254 Analyze_Function_Instantiation
(N
);
256 when N_Generic_Function_Renaming_Declaration
=>
257 Analyze_Generic_Function_Renaming
(N
);
259 when N_Generic_Package_Declaration
=>
260 Analyze_Generic_Package_Declaration
(N
);
262 when N_Generic_Package_Renaming_Declaration
=>
263 Analyze_Generic_Package_Renaming
(N
);
265 when N_Generic_Procedure_Renaming_Declaration
=>
266 Analyze_Generic_Procedure_Renaming
(N
);
268 when N_Generic_Subprogram_Declaration
=>
269 Analyze_Generic_Subprogram_Declaration
(N
);
271 when N_Goto_Statement
=>
272 Analyze_Goto_Statement
(N
);
274 when N_Handled_Sequence_Of_Statements
=>
275 Analyze_Handled_Statements
(N
);
278 Analyze_Identifier
(N
);
280 when N_If_Expression
=>
281 Analyze_If_Expression
(N
);
283 when N_If_Statement
=>
284 Analyze_If_Statement
(N
);
286 when N_Implicit_Label_Declaration
=>
287 Analyze_Implicit_Label_Declaration
(N
);
290 Analyze_Membership_Op
(N
);
292 when N_Incomplete_Type_Declaration
=>
293 Analyze_Incomplete_Type_Decl
(N
);
295 when N_Indexed_Component
=>
296 Analyze_Indexed_Component_Form
(N
);
298 when N_Integer_Literal
=>
299 Analyze_Integer_Literal
(N
);
301 when N_Iterator_Specification
=>
302 Analyze_Iterator_Specification
(N
);
304 when N_Itype_Reference
=>
305 Analyze_Itype_Reference
(N
);
310 when N_Loop_Parameter_Specification
=>
311 Analyze_Loop_Parameter_Specification
(N
);
313 when N_Loop_Statement
=>
314 Analyze_Loop_Statement
(N
);
317 Analyze_Membership_Op
(N
);
322 when N_Null_Statement
=>
323 Analyze_Null_Statement
(N
);
325 when N_Number_Declaration
=>
326 Analyze_Number_Declaration
(N
);
328 when N_Object_Declaration
=>
329 Analyze_Object_Declaration
(N
);
331 when N_Object_Renaming_Declaration
=>
332 Analyze_Object_Renaming
(N
);
334 when N_Operator_Symbol
=>
335 Analyze_Operator_Symbol
(N
);
338 Analyze_Unary_Op
(N
);
341 Analyze_Arithmetic_Op
(N
);
344 Analyze_Logical_Op
(N
);
347 Analyze_Concatenation
(N
);
350 Analyze_Arithmetic_Op
(N
);
353 Analyze_Equality_Op
(N
);
356 Analyze_Arithmetic_Op
(N
);
359 Analyze_Comparison_Op
(N
);
362 Analyze_Comparison_Op
(N
);
365 Analyze_Comparison_Op
(N
);
368 Analyze_Comparison_Op
(N
);
371 Analyze_Unary_Op
(N
);
376 when N_Op_Multiply
=>
377 Analyze_Arithmetic_Op
(N
);
380 Analyze_Equality_Op
(N
);
383 Analyze_Negation
(N
);
386 Analyze_Logical_Op
(N
);
389 Analyze_Unary_Op
(N
);
392 Analyze_Arithmetic_Op
(N
);
394 when N_Op_Rotate_Left
=>
395 Analyze_Arithmetic_Op
(N
);
397 when N_Op_Rotate_Right
=>
398 Analyze_Arithmetic_Op
(N
);
400 when N_Op_Shift_Left
=>
401 Analyze_Arithmetic_Op
(N
);
403 when N_Op_Shift_Right
=>
404 Analyze_Arithmetic_Op
(N
);
406 when N_Op_Shift_Right_Arithmetic
=>
407 Analyze_Arithmetic_Op
(N
);
409 when N_Op_Subtract
=>
410 Analyze_Arithmetic_Op
(N
);
413 Analyze_Logical_Op
(N
);
416 Analyze_Short_Circuit
(N
);
418 when N_Others_Choice
=>
419 Analyze_Others_Choice
(N
);
421 when N_Package_Body
=>
422 Analyze_Package_Body
(N
);
424 when N_Package_Body_Stub
=>
425 Analyze_Package_Body_Stub
(N
);
427 when N_Package_Declaration
=>
428 Analyze_Package_Declaration
(N
);
430 when N_Package_Instantiation
=>
431 Analyze_Package_Instantiation
(N
);
433 when N_Package_Renaming_Declaration
=>
434 Analyze_Package_Renaming
(N
);
436 when N_Package_Specification
=>
437 Analyze_Package_Specification
(N
);
439 when N_Parameter_Association
=>
440 Analyze_Parameter_Association
(N
);
445 when N_Private_Extension_Declaration
=>
446 Analyze_Private_Extension_Declaration
(N
);
448 when N_Private_Type_Declaration
=>
449 Analyze_Private_Type_Declaration
(N
);
451 when N_Procedure_Call_Statement
=>
452 Analyze_Procedure_Call
(N
);
454 when N_Procedure_Instantiation
=>
455 Analyze_Procedure_Instantiation
(N
);
457 when N_Protected_Body
=>
458 Analyze_Protected_Body
(N
);
460 when N_Protected_Body_Stub
=>
461 Analyze_Protected_Body_Stub
(N
);
463 when N_Protected_Definition
=>
464 Analyze_Protected_Definition
(N
);
466 when N_Protected_Type_Declaration
=>
467 Analyze_Protected_Type_Declaration
(N
);
469 when N_Qualified_Expression
=>
470 Analyze_Qualified_Expression
(N
);
472 when N_Quantified_Expression
=>
473 Analyze_Quantified_Expression
(N
);
475 when N_Raise_Expression
=>
476 Analyze_Raise_Expression
(N
);
478 when N_Raise_Statement
=>
479 Analyze_Raise_Statement
(N
);
481 when N_Raise_xxx_Error
=>
482 Analyze_Raise_xxx_Error
(N
);
487 when N_Range_Constraint
=>
488 Analyze_Range
(Range_Expression
(N
));
490 when N_Real_Literal
=>
491 Analyze_Real_Literal
(N
);
493 when N_Record_Representation_Clause
=>
494 Analyze_Record_Representation_Clause
(N
);
497 Analyze_Reference
(N
);
499 when N_Requeue_Statement
=>
502 when N_Simple_Return_Statement
=>
503 Analyze_Simple_Return_Statement
(N
);
505 when N_Selected_Component
=>
506 Find_Selected_Component
(N
);
507 -- ??? why not Analyze_Selected_Component, needs comments
509 when N_Selective_Accept
=>
510 Analyze_Selective_Accept
(N
);
512 when N_Single_Protected_Declaration
=>
513 Analyze_Single_Protected_Declaration
(N
);
515 when N_Single_Task_Declaration
=>
516 Analyze_Single_Task_Declaration
(N
);
521 when N_String_Literal
=>
522 Analyze_String_Literal
(N
);
524 when N_Subprogram_Body
=>
525 Analyze_Subprogram_Body
(N
);
527 when N_Subprogram_Body_Stub
=>
528 Analyze_Subprogram_Body_Stub
(N
);
530 when N_Subprogram_Declaration
=>
531 Analyze_Subprogram_Declaration
(N
);
533 when N_Subprogram_Renaming_Declaration
=>
534 Analyze_Subprogram_Renaming
(N
);
536 when N_Subtype_Declaration
=>
537 Analyze_Subtype_Declaration
(N
);
539 when N_Subtype_Indication
=>
540 Analyze_Subtype_Indication
(N
);
546 Analyze_Task_Body
(N
);
548 when N_Task_Body_Stub
=>
549 Analyze_Task_Body_Stub
(N
);
551 when N_Task_Definition
=>
552 Analyze_Task_Definition
(N
);
554 when N_Task_Type_Declaration
=>
555 Analyze_Task_Type_Declaration
(N
);
557 when N_Terminate_Alternative
=>
558 Analyze_Terminate_Alternative
(N
);
560 when N_Timed_Entry_Call
=>
561 Analyze_Timed_Entry_Call
(N
);
563 when N_Triggering_Alternative
=>
564 Analyze_Triggering_Alternative
(N
);
566 when N_Type_Conversion
=>
567 Analyze_Type_Conversion
(N
);
569 when N_Unchecked_Expression
=>
570 Analyze_Unchecked_Expression
(N
);
572 when N_Unchecked_Type_Conversion
=>
573 Analyze_Unchecked_Type_Conversion
(N
);
575 when N_Use_Package_Clause
=>
576 Analyze_Use_Package
(N
);
578 when N_Use_Type_Clause
=>
579 Analyze_Use_Type
(N
);
581 when N_Validate_Unchecked_Conversion
=>
584 when N_Variant_Part
=>
585 Analyze_Variant_Part
(N
);
587 when N_With_Clause
=>
588 Analyze_With_Clause
(N
);
590 -- A call to analyze the Empty node is an error, but most likely it
591 -- is an error caused by an attempt to analyze a malformed piece of
592 -- tree caused by some other error, so if there have been any other
593 -- errors, we just ignore it, otherwise it is a real internal error
594 -- which we complain about.
596 -- We must also consider the case of call to a runtime function that
597 -- is not available in the configurable runtime.
600 pragma Assert
(Serious_Errors_Detected
/= 0
601 or else Configurable_Run_Time_Violations
/= 0);
604 -- A call to analyze the error node is simply ignored, to avoid
605 -- causing cascaded errors (happens of course only in error cases)
610 -- Push/Pop nodes normally don't come through an analyze call. An
611 -- exception is the dummy ones bracketing a subprogram body. In any
612 -- case there is nothing to be done to analyze such nodes.
614 when N_Push_Pop_xxx_Label
=>
617 -- SCIL nodes don't need analysis because they are decorated when
618 -- they are built. They are added to the tree by Insert_Actions and
619 -- the call to analyze them is generated when the full list is
623 N_SCIL_Dispatch_Table_Tag_Init |
624 N_SCIL_Dispatching_Call |
625 N_SCIL_Membership_Test
=>
628 -- For the remaining node types, we generate compiler abort, because
629 -- these nodes are always analyzed within the Sem_Chn routines and
630 -- there should never be a case of making a call to the main Analyze
631 -- routine for these node kinds. For example, an N_Access_Definition
632 -- node appears only in the context of a type declaration, and is
633 -- processed by the analyze routine for type declarations.
637 N_Access_Definition |
638 N_Access_Function_Definition |
639 N_Access_Procedure_Definition |
640 N_Access_To_Object_Definition |
641 N_Aspect_Specification |
642 N_Case_Expression_Alternative |
643 N_Case_Statement_Alternative |
644 N_Compilation_Unit_Aux |
645 N_Component_Association |
647 N_Component_Definition |
649 N_Constrained_Array_Definition |
651 N_Decimal_Fixed_Point_Definition |
652 N_Defining_Character_Literal |
653 N_Defining_Identifier |
654 N_Defining_Operator_Symbol |
655 N_Defining_Program_Unit_Name |
657 N_Derived_Type_Definition |
659 N_Digits_Constraint |
660 N_Discriminant_Association |
661 N_Discriminant_Specification |
663 N_Entry_Call_Statement |
664 N_Enumeration_Type_Definition |
665 N_Exception_Handler |
666 N_Floating_Point_Definition |
667 N_Formal_Decimal_Fixed_Point_Definition |
668 N_Formal_Derived_Type_Definition |
669 N_Formal_Discrete_Type_Definition |
670 N_Formal_Floating_Point_Definition |
671 N_Formal_Modular_Type_Definition |
672 N_Formal_Ordinary_Fixed_Point_Definition |
673 N_Formal_Private_Type_Definition |
674 N_Formal_Incomplete_Type_Definition |
675 N_Formal_Signed_Integer_Type_Definition |
676 N_Function_Specification |
677 N_Generic_Association |
678 N_Index_Or_Discriminant_Constraint |
681 N_Modular_Type_Definition |
682 N_Ordinary_Fixed_Point_Definition |
683 N_Parameter_Specification |
684 N_Pragma_Argument_Association |
685 N_Procedure_Specification |
686 N_Real_Range_Specification |
687 N_Record_Definition |
688 N_Signed_Integer_Type_Definition |
689 N_Unconstrained_Array_Definition |
697 Debug_A_Exit
("analyzing ", N
, " (done)");
699 -- Now that we have analyzed the node, we call the expander to perform
700 -- possible expansion. We skip this for subexpressions, because we don't
701 -- have the type yet, and the expander will need to know the type before
702 -- it can do its job. For subexpression nodes, the call to the expander
703 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
704 -- which can appear in a statement context, and needs expanding now in
705 -- the case (distinguished by Etype, as documented in Sinfo).
707 -- The Analyzed flag is also set at this point for non-subexpression
708 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
709 -- since resolution and expansion have not yet been completed). Note
710 -- that for N_Raise_xxx_Error we have to distinguish the expression
711 -- case from the statement case.
713 if Nkind
(N
) not in N_Subexpr
714 or else (Nkind
(N
) in N_Raise_xxx_Error
715 and then Etype
(N
) = Standard_Void_Type
)
721 -- Version with check(s) suppressed
723 procedure Analyze
(N
: Node_Id
; Suppress
: Check_Id
) is
725 if Suppress
= All_Checks
then
727 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
729 Scope_Suppress
.Suppress
:= (others => True);
731 Scope_Suppress
.Suppress
:= Svs
;
734 elsif Suppress
= Overflow_Check
then
736 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
738 Scope_Suppress
.Suppress
(Suppress
) := True;
740 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
749 procedure Analyze_List
(L
: List_Id
) is
754 while Present
(Node
) loop
760 -- Version with check(s) suppressed
762 procedure Analyze_List
(L
: List_Id
; Suppress
: Check_Id
) is
764 if Suppress
= All_Checks
then
766 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
768 Scope_Suppress
.Suppress
:= (others => True);
770 Scope_Suppress
.Suppress
:= Svs
;
775 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
777 Scope_Suppress
.Suppress
(Suppress
) := True;
779 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
784 --------------------------
785 -- Copy_Suppress_Status --
786 --------------------------
788 procedure Copy_Suppress_Status
794 pragma Warnings
(Off
, Found
);
796 procedure Search_Stack
797 (Top
: Suppress_Stack_Entry_Ptr
;
798 Found
: out Boolean);
799 -- Search given suppress stack for matching entry for entity. If found
800 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
801 -- entry for To onto the local suppress stack.
807 procedure Search_Stack
808 (Top
: Suppress_Stack_Entry_Ptr
;
811 Ptr
: Suppress_Stack_Entry_Ptr
;
815 while Ptr
/= null loop
817 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
820 Set_Checks_May_Be_Suppressed
(To
, True);
821 Push_Local_Suppress_Stack_Entry
837 -- Start of processing for Copy_Suppress_Status
840 if not Checks_May_Be_Suppressed
(From
) then
844 -- First 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
(Global_Suppress_Stack_Top
, Found
);
854 -- Now search the local entity suppress stack, we search this in
855 -- reverse order so that we get the innermost entry that applies to
856 -- this case if there are nested entries. Note that for the purpose
857 -- of this procedure we are ONLY looking for entries corresponding
858 -- to a two-argument Suppress, where the second argument matches From.
860 Search_Stack
(Local_Suppress_Stack_Top
, Found
);
861 end Copy_Suppress_Status
;
863 -------------------------
864 -- Enter_Generic_Scope --
865 -------------------------
867 procedure Enter_Generic_Scope
(S
: Entity_Id
) is
869 if No
(Outer_Generic_Scope
) then
870 Outer_Generic_Scope
:= S
;
872 end Enter_Generic_Scope
;
874 ------------------------
875 -- Exit_Generic_Scope --
876 ------------------------
878 procedure Exit_Generic_Scope
(S
: Entity_Id
) is
880 if S
= Outer_Generic_Scope
then
881 Outer_Generic_Scope
:= Empty
;
883 end Exit_Generic_Scope
;
885 -----------------------
886 -- Explicit_Suppress --
887 -----------------------
889 function Explicit_Suppress
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
890 Ptr
: Suppress_Stack_Entry_Ptr
;
893 if not Checks_May_Be_Suppressed
(E
) then
897 Ptr
:= Global_Suppress_Stack_Top
;
898 while Ptr
/= null loop
900 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
910 end Explicit_Suppress
;
912 -----------------------------
913 -- External_Ref_In_Generic --
914 -----------------------------
916 function External_Ref_In_Generic
(E
: Entity_Id
) return Boolean is
920 -- Entity is global if defined outside of current outer_generic_scope:
921 -- Either the entity has a smaller depth that the outer generic, or it
922 -- is in a different compilation unit, or it is defined within a unit
923 -- in the same compilation, that is not within the outer_generic.
925 if No
(Outer_Generic_Scope
) then
928 elsif Scope_Depth
(Scope
(E
)) < Scope_Depth
(Outer_Generic_Scope
)
929 or else not In_Same_Source_Unit
(E
, Outer_Generic_Scope
)
935 while Present
(Scop
) loop
936 if Scop
= Outer_Generic_Scope
then
938 elsif Scope_Depth
(Scop
) < Scope_Depth
(Outer_Generic_Scope
) then
941 Scop
:= Scope
(Scop
);
947 end External_Ref_In_Generic
;
953 procedure Initialize
is
954 Next
: Suppress_Stack_Entry_Ptr
;
956 procedure Free
is new Unchecked_Deallocation
957 (Suppress_Stack_Entry
, Suppress_Stack_Entry_Ptr
);
960 -- Free any global suppress stack entries from a previous invocation
961 -- of the compiler (in the normal case this loop does nothing).
963 while Suppress_Stack_Entries
/= null loop
964 Next
:= Suppress_Stack_Entries
.Next
;
965 Free
(Suppress_Stack_Entries
);
966 Suppress_Stack_Entries
:= Next
;
969 Local_Suppress_Stack_Top
:= null;
970 Global_Suppress_Stack_Top
:= null;
972 -- Clear scope stack, and reset global variables
975 Unloaded_Subunits
:= False;
978 ------------------------------
979 -- Insert_After_And_Analyze --
980 ------------------------------
982 procedure Insert_After_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
988 -- If we are not at the end of the list, then the easiest
989 -- coding is simply to insert before our successor
991 if Present
(Next
(N
)) then
992 Insert_Before_And_Analyze
(Next
(N
), M
);
994 -- Case of inserting at the end of the list
997 -- Capture the Node_Id of the node to be inserted. This Node_Id
998 -- will still be the same after the insert operation.
1001 Insert_After
(N
, M
);
1003 -- Now just analyze from the inserted node to the end of
1004 -- the new list (note that this properly handles the case
1005 -- where any of the analyze calls result in the insertion of
1006 -- nodes after the analyzed node, expecting analysis).
1008 while Present
(Node
) loop
1010 Mark_Rewrite_Insertion
(Node
);
1015 end Insert_After_And_Analyze
;
1017 -- Version with check(s) suppressed
1019 procedure Insert_After_And_Analyze
1022 Suppress
: Check_Id
)
1025 if Suppress
= All_Checks
then
1027 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1029 Scope_Suppress
.Suppress
:= (others => True);
1030 Insert_After_And_Analyze
(N
, M
);
1031 Scope_Suppress
.Suppress
:= Svs
;
1036 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1038 Scope_Suppress
.Suppress
(Suppress
) := True;
1039 Insert_After_And_Analyze
(N
, M
);
1040 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1043 end Insert_After_And_Analyze
;
1045 -------------------------------
1046 -- Insert_Before_And_Analyze --
1047 -------------------------------
1049 procedure Insert_Before_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
1055 -- Capture the Node_Id of the first list node to be inserted.
1056 -- This will still be the first node after the insert operation,
1057 -- since Insert_List_After does not modify the Node_Id values.
1060 Insert_Before
(N
, M
);
1062 -- The insertion does not change the Id's of any of the nodes in
1063 -- the list, and they are still linked, so we can simply loop from
1064 -- the original first node until we meet the node before which the
1065 -- insertion is occurring. Note that this properly handles the case
1066 -- where any of the analyzed nodes insert nodes after themselves,
1067 -- expecting them to get analyzed.
1069 while Node
/= N
loop
1071 Mark_Rewrite_Insertion
(Node
);
1075 end Insert_Before_And_Analyze
;
1077 -- Version with check(s) suppressed
1079 procedure Insert_Before_And_Analyze
1082 Suppress
: Check_Id
)
1085 if Suppress
= All_Checks
then
1087 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1089 Scope_Suppress
.Suppress
:= (others => True);
1090 Insert_Before_And_Analyze
(N
, M
);
1091 Scope_Suppress
.Suppress
:= Svs
;
1096 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1098 Scope_Suppress
.Suppress
(Suppress
) := True;
1099 Insert_Before_And_Analyze
(N
, M
);
1100 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1103 end Insert_Before_And_Analyze
;
1105 -----------------------------------
1106 -- Insert_List_After_And_Analyze --
1107 -----------------------------------
1109 procedure Insert_List_After_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1110 After
: constant Node_Id
:= Next
(N
);
1114 if Is_Non_Empty_List
(L
) then
1116 -- Capture the Node_Id of the first list node to be inserted.
1117 -- This will still be the first node after the insert operation,
1118 -- since Insert_List_After does not modify the Node_Id values.
1121 Insert_List_After
(N
, L
);
1123 -- Now just analyze from the original first node until we get to the
1124 -- successor of the original insertion point (which may be Empty if
1125 -- the insertion point was at the end of the list). Note that this
1126 -- properly handles the case where any of the analyze calls result in
1127 -- the insertion of nodes after the analyzed node (possibly calling
1128 -- this routine recursively).
1130 while Node
/= After
loop
1132 Mark_Rewrite_Insertion
(Node
);
1136 end Insert_List_After_And_Analyze
;
1138 -- Version with check(s) suppressed
1140 procedure Insert_List_After_And_Analyze
1141 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1144 if Suppress
= All_Checks
then
1146 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1148 Scope_Suppress
.Suppress
:= (others => True);
1149 Insert_List_After_And_Analyze
(N
, L
);
1150 Scope_Suppress
.Suppress
:= Svs
;
1155 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1157 Scope_Suppress
.Suppress
(Suppress
) := True;
1158 Insert_List_After_And_Analyze
(N
, L
);
1159 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1162 end Insert_List_After_And_Analyze
;
1164 ------------------------------------
1165 -- Insert_List_Before_And_Analyze --
1166 ------------------------------------
1168 procedure Insert_List_Before_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1172 if Is_Non_Empty_List
(L
) then
1174 -- Capture the Node_Id of the first list node to be inserted. This
1175 -- will still be the first node after the insert operation, since
1176 -- Insert_List_After does not modify the Node_Id values.
1179 Insert_List_Before
(N
, L
);
1181 -- The insertion does not change the Id's of any of the nodes in
1182 -- the list, and they are still linked, so we can simply loop from
1183 -- the original first node until we meet the node before which the
1184 -- insertion is occurring. Note that this properly handles the case
1185 -- where any of the analyzed nodes insert nodes after themselves,
1186 -- expecting them to get analyzed.
1188 while Node
/= N
loop
1190 Mark_Rewrite_Insertion
(Node
);
1194 end Insert_List_Before_And_Analyze
;
1196 -- Version with check(s) suppressed
1198 procedure Insert_List_Before_And_Analyze
1199 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1202 if Suppress
= All_Checks
then
1204 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1206 Scope_Suppress
.Suppress
:= (others => True);
1207 Insert_List_Before_And_Analyze
(N
, L
);
1208 Scope_Suppress
.Suppress
:= Svs
;
1213 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1215 Scope_Suppress
.Suppress
(Suppress
) := True;
1216 Insert_List_Before_And_Analyze
(N
, L
);
1217 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1220 end Insert_List_Before_And_Analyze
;
1228 Scope_Stack
.Locked
:= True;
1229 Scope_Stack
.Release
;
1236 procedure Preanalyze
(N
: Node_Id
) is
1237 Save_Full_Analysis
: constant Boolean := Full_Analysis
;
1240 Full_Analysis
:= False;
1241 Expander_Mode_Save_And_Set
(False);
1245 Expander_Mode_Restore
;
1246 Full_Analysis
:= Save_Full_Analysis
;
1249 --------------------------------------
1250 -- Push_Global_Suppress_Stack_Entry --
1251 --------------------------------------
1253 procedure Push_Global_Suppress_Stack_Entry
1254 (Entity
: Entity_Id
;
1259 Global_Suppress_Stack_Top
:=
1260 new Suppress_Stack_Entry
'
1263 Suppress => Suppress,
1264 Prev => Global_Suppress_Stack_Top,
1265 Next => Suppress_Stack_Entries);
1266 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1269 end Push_Global_Suppress_Stack_Entry;
1271 -------------------------------------
1272 -- Push_Local_Suppress_Stack_Entry --
1273 -------------------------------------
1275 procedure Push_Local_Suppress_Stack_Entry
1276 (Entity : Entity_Id;
1281 Local_Suppress_Stack_Top :=
1282 new Suppress_Stack_Entry'
1285 Suppress
=> Suppress
,
1286 Prev
=> Local_Suppress_Stack_Top
,
1287 Next
=> Suppress_Stack_Entries
);
1288 Suppress_Stack_Entries
:= Local_Suppress_Stack_Top
;
1291 end Push_Local_Suppress_Stack_Entry
;
1297 procedure Semantics
(Comp_Unit
: Node_Id
) is
1299 -- The following locations save the corresponding global flags and
1300 -- variables so that they can be restored on completion. This is needed
1301 -- so that calls to Rtsfind start with the proper default values for
1302 -- these variables, and also that such calls do not disturb the settings
1303 -- for units being analyzed at a higher level.
1305 S_Current_Sem_Unit
: constant Unit_Number_Type
:= Current_Sem_Unit
;
1306 S_Full_Analysis
: constant Boolean := Full_Analysis
;
1307 S_GNAT_Mode
: constant Boolean := GNAT_Mode
;
1308 S_Global_Dis_Names
: constant Boolean := Global_Discard_Names
;
1309 S_In_Assertion_Expr
: constant Nat
:= In_Assertion_Expr
;
1310 S_In_Spec_Expr
: constant Boolean := In_Spec_Expression
;
1311 S_Inside_A_Generic
: constant Boolean := Inside_A_Generic
;
1312 S_Outer_Gen_Scope
: constant Entity_Id
:= Outer_Generic_Scope
;
1313 S_Style_Check
: constant Boolean := Style_Check
;
1315 Curunit
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(Comp_Unit
);
1316 -- New value of Current_Sem_Unit
1318 Generic_Main
: constant Boolean :=
1319 Nkind
(Unit
(Cunit
(Main_Unit
))) in N_Generic_Declaration
;
1320 -- If the main unit is generic, every compiled unit, including its
1321 -- context, is compiled with expansion disabled.
1323 Is_Main_Unit_Or_Main_Unit_Spec
: constant Boolean :=
1326 (Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
1327 and then Library_Unit
(Cunit
(Main_Unit
)) = Cunit
(Curunit
));
1328 -- Configuration flags have special settings when compiling a predefined
1329 -- file as a main unit. This applies to its spec as well.
1331 Ext_Main_Source_Unit
: constant Boolean :=
1332 In_Extended_Main_Source_Unit
(Comp_Unit
);
1333 -- Determine if unit is in extended main source unit
1335 Save_Config_Switches
: Config_Switches_Type
;
1336 -- Variable used to save values of config switches while we analyze the
1337 -- new unit, to be restored on exit for proper recursive behavior.
1339 Save_Cunit_Restrictions
: Save_Cunit_Boolean_Restrictions
;
1340 -- Used to save non-partition wide restrictions before processing new
1341 -- unit. All with'ed units are analyzed with config restrictions reset
1342 -- and we need to restore these saved values at the end.
1344 procedure Do_Analyze
;
1345 -- Procedure to analyze the compilation unit
1351 procedure Do_Analyze
is
1355 List
:= Save_Scope_Stack
;
1356 Push_Scope
(Standard_Standard
);
1357 Scope_Suppress
:= Suppress_Options
;
1359 (Scope_Stack
.Last
).Component_Alignment_Default
:= Calign_Default
;
1361 (Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
1362 Outer_Generic_Scope
:= Empty
;
1364 -- Now analyze the top level compilation unit node
1366 Analyze
(Comp_Unit
);
1368 -- Check for scope mismatch on exit from compilation
1370 pragma Assert
(Current_Scope
= Standard_Standard
1371 or else Comp_Unit
= Cunit
(Main_Unit
));
1373 -- Then pop entry for Standard, and pop implicit types
1376 Restore_Scope_Stack
(List
);
1379 Already_Analyzed
: constant Boolean := Analyzed
(Comp_Unit
);
1381 -- Start of processing for Semantics
1384 if Debug_Unit_Walk
then
1385 if Already_Analyzed
then
1386 Write_Str
("(done)");
1390 (Get_Cunit_Unit_Number
(Comp_Unit
),
1396 Compiler_State
:= Analyzing
;
1397 Current_Sem_Unit
:= Curunit
;
1399 -- Compile predefined units with GNAT_Mode set to True, to properly
1400 -- process the categorization stuff. However, do not set GNAT_Mode
1401 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1402 -- Sequential_IO) as this would prevent pragma Extend_System from being
1403 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1405 if Is_Predefined_File_Name
1406 (Unit_File_Name
(Current_Sem_Unit
), Renamings_Included
=> False)
1411 if Generic_Main
then
1412 Expander_Mode_Save_And_Set
(False);
1414 Expander_Mode_Save_And_Set
1415 (Operating_Mode
= Generate_Code
or Debug_Flag_X
);
1418 Full_Analysis
:= True;
1419 Inside_A_Generic
:= False;
1420 In_Assertion_Expr
:= 0;
1421 In_Spec_Expression
:= False;
1422 Set_Comes_From_Source_Default
(False);
1424 -- Save current config switches and reset then appropriately
1426 Save_Opt_Config_Switches
(Save_Config_Switches
);
1427 Set_Opt_Config_Switches
1428 (Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
)),
1429 Is_Main_Unit_Or_Main_Unit_Spec
);
1431 -- Save current non-partition-wide restrictions
1433 Save_Cunit_Restrictions
:= Cunit_Boolean_Restrictions_Save
;
1435 -- For unit in main extended unit, we reset the configuration values
1436 -- for the non-partition-wide restrictions. For other units reset them.
1438 if Ext_Main_Source_Unit
then
1439 Restore_Config_Cunit_Boolean_Restrictions
;
1441 Reset_Cunit_Boolean_Restrictions
;
1444 -- Turn off style checks for unit that is not in the extended main
1445 -- source unit. This improves processing efficiency for such units
1446 -- (for which we don't want style checks anyway, and where they will
1447 -- get suppressed), and is definitely needed to stop some style checks
1448 -- from invading the run-time units (e.g. overriding checks).
1450 if not Ext_Main_Source_Unit
then
1451 Style_Check
:= False;
1453 -- If this is part of the extended main source unit, set style check
1454 -- mode to match the style check mode of the main source unit itself.
1457 Style_Check
:= Style_Check_Main
;
1460 -- Only do analysis of unit that has not already been analyzed
1462 if not Analyzed
(Comp_Unit
) then
1463 Initialize_Version
(Current_Sem_Unit
);
1465 -- Do analysis, and then append the compilation unit onto the
1466 -- Comp_Unit_List, if appropriate. This is done after analysis,
1467 -- so if this unit depends on some others, they have already been
1468 -- appended. We ignore bodies, except for the main unit itself, and
1469 -- for subprogram bodies that act as specs. We have also to guard
1470 -- against ill-formed subunits that have an improper context.
1474 if Present
(Comp_Unit
)
1475 and then Nkind
(Unit
(Comp_Unit
)) in N_Proper_Body
1476 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Subprogram_Body
1477 or else not Acts_As_Spec
(Comp_Unit
))
1478 and then not In_Extended_Main_Source_Unit
(Comp_Unit
)
1483 -- Initialize if first time
1485 if No
(Comp_Unit_List
) then
1486 Comp_Unit_List
:= New_Elmt_List
;
1489 Append_Elmt
(Comp_Unit
, Comp_Unit_List
);
1491 if Debug_Unit_Walk
then
1492 Write_Str
("Appending ");
1494 (Get_Cunit_Unit_Number
(Comp_Unit
), Unit
(Comp_Unit
));
1499 -- Save indication of dynamic elaboration checks for ALI file
1501 Set_Dynamic_Elab
(Current_Sem_Unit
, Dynamic_Elaboration_Checks
);
1503 -- Restore settings of saved switches to entry values
1505 Current_Sem_Unit
:= S_Current_Sem_Unit
;
1506 Full_Analysis
:= S_Full_Analysis
;
1507 Global_Discard_Names
:= S_Global_Dis_Names
;
1508 GNAT_Mode
:= S_GNAT_Mode
;
1509 In_Assertion_Expr
:= S_In_Assertion_Expr
;
1510 In_Spec_Expression
:= S_In_Spec_Expr
;
1511 Inside_A_Generic
:= S_Inside_A_Generic
;
1512 Outer_Generic_Scope
:= S_Outer_Gen_Scope
;
1513 Style_Check
:= S_Style_Check
;
1515 Restore_Opt_Config_Switches
(Save_Config_Switches
);
1517 -- Deal with restore of restrictions
1519 Cunit_Boolean_Restrictions_Restore
(Save_Cunit_Restrictions
);
1521 Expander_Mode_Restore
;
1523 if Debug_Unit_Walk
then
1526 if Already_Analyzed
then
1527 Write_Str
("(done)");
1531 (Get_Cunit_Unit_Number
(Comp_Unit
),
1541 function ss
(Index
: Int
) return Scope_Stack_Entry
is
1543 return Scope_Stack
.Table
(Index
);
1550 function sst
return Scope_Stack_Entry
is
1552 return ss
(Scope_Stack
.Last
);
1555 ------------------------
1556 -- Walk_Library_Items --
1557 ------------------------
1559 procedure Walk_Library_Items
is
1560 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
1561 pragma Pack
(Unit_Number_Set
);
1563 Main_CU
: constant Node_Id
:= Cunit
(Main_Unit
);
1565 Seen
, Done
: Unit_Number_Set
:= (others => False);
1566 -- Seen (X) is True after we have seen unit X in the walk. This is used
1567 -- to prevent processing the same unit more than once. Done (X) is True
1568 -- after we have fully processed X, and is used only for debugging
1569 -- printouts and assertions.
1571 Do_Main
: Boolean := False;
1572 -- Flag to delay processing the main body until after all other units.
1573 -- This is needed because the spec of the main unit may appear in the
1574 -- context of some other unit. We do not want this to force processing
1575 -- of the main body before all other units have been processed.
1577 -- Another circularity pattern occurs when the main unit is a child unit
1578 -- and the body of an ancestor has a with-clause of the main unit or on
1579 -- one of its children. In both cases the body in question has a with-
1580 -- clause on the main unit, and must be excluded from the traversal. In
1581 -- some convoluted cases this may lead to a CodePeer error because the
1582 -- spec of a subprogram declared in an instance within the parent will
1583 -- not be seen in the main unit.
1585 function Depends_On_Main
(CU
: Node_Id
) return Boolean;
1586 -- The body of a unit that is withed by the spec of the main unit may in
1587 -- turn have a with_clause on that spec. In that case do not traverse
1588 -- the body, to prevent loops. It can also happen that the main body has
1589 -- a with_clause on a child, which of course has an implicit with on its
1590 -- parent. It's OK to traverse the child body if the main spec has been
1591 -- processed, otherwise we also have a circularity to avoid.
1593 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
);
1594 -- Calls Action, with some validity checks
1596 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
);
1597 -- Calls Do_Action, first on the units with'ed by this one, then on
1598 -- this unit. If it's an instance body, do the spec first. If it is
1599 -- an instance spec, do the body last.
1601 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
);
1602 -- Apply Do_Unit_And_Dependents to a unit in a context clause
1604 procedure Process_Bodies_In_Context
(Comp
: Node_Id
);
1605 -- The main unit and its spec may depend on bodies that contain generics
1606 -- that are instantiated in them. Iterate through the corresponding
1607 -- contexts before processing main (spec/body) itself, to process bodies
1608 -- that may be present, together with their context. The spec of main
1609 -- is processed wherever it appears in the list of units, while the body
1610 -- is processed as the last unit in the list.
1612 ---------------------
1613 -- Depends_On_Main --
1614 ---------------------
1616 function Depends_On_Main
(CU
: Node_Id
) return Boolean is
1618 MCU
: constant Node_Id
:= Unit
(Main_CU
);
1621 CL
:= First
(Context_Items
(CU
));
1623 -- Problem does not arise with main subprograms
1626 not Nkind_In
(MCU
, N_Package_Body
, N_Package_Declaration
)
1631 while Present
(CL
) loop
1632 if Nkind
(CL
) = N_With_Clause
1633 and then Library_Unit
(CL
) = Main_CU
1634 and then not Done
(Get_Cunit_Unit_Number
(Library_Unit
(CL
)))
1643 end Depends_On_Main
;
1649 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
) is
1651 -- This calls Action at the end. All the preceding code is just
1652 -- assertions and debugging output.
1654 pragma Assert
(No
(CU
) or else Nkind
(CU
) = N_Compilation_Unit
);
1656 case Nkind
(Item
) is
1657 when N_Generic_Subprogram_Declaration |
1658 N_Generic_Package_Declaration |
1659 N_Package_Declaration |
1660 N_Subprogram_Declaration |
1661 N_Subprogram_Renaming_Declaration |
1662 N_Package_Renaming_Declaration |
1663 N_Generic_Function_Renaming_Declaration |
1664 N_Generic_Package_Renaming_Declaration |
1665 N_Generic_Procedure_Renaming_Declaration
=>
1671 when N_Package_Body
=>
1673 -- Package bodies are processed separately if the main unit
1678 when N_Subprogram_Body
=>
1680 -- A subprogram body must be the main unit
1682 pragma Assert
(Acts_As_Spec
(CU
)
1683 or else CU
= Cunit
(Main_Unit
));
1686 when N_Function_Instantiation |
1687 N_Procedure_Instantiation |
1688 N_Package_Instantiation
=>
1690 -- Can only happen if some generic body (needed for gnat2scil
1691 -- traversal, but not by GNAT) is not available, ignore.
1695 -- All other cases cannot happen
1698 pragma Assert
(False, "subunit");
1702 pragma Assert
(False);
1706 if Present
(CU
) then
1707 pragma Assert
(Item
/= Stand
.Standard_Package_Node
);
1708 pragma Assert
(Item
= Unit
(CU
));
1711 Unit_Num
: constant Unit_Number_Type
:=
1712 Get_Cunit_Unit_Number
(CU
);
1714 procedure Assert_Done
(Withed_Unit
: Node_Id
);
1715 -- Assert Withed_Unit is already Done, unless it's a body. It
1716 -- might seem strange for a with_clause to refer to a body, but
1717 -- this happens in the case of a generic instantiation, which
1718 -- gets transformed into the instance body (and the instance
1719 -- spec is also created). With clauses pointing to the
1720 -- instantiation end up pointing to the instance body.
1726 procedure Assert_Done
(Withed_Unit
: Node_Id
) is
1728 if not Done
(Get_Cunit_Unit_Number
(Withed_Unit
)) then
1730 (Unit
(Withed_Unit
),
1731 N_Generic_Package_Declaration
,
1733 N_Package_Renaming_Declaration
,
1737 (Unit_Name
(Get_Cunit_Unit_Number
(Withed_Unit
)));
1738 Write_Str
(" not yet walked!");
1740 if Get_Cunit_Unit_Number
(Withed_Unit
) = Unit_Num
then
1741 Write_Str
(" (self-ref)");
1746 pragma Assert
(False);
1751 procedure Assert_Withed_Units_Done
is
1752 new Walk_Withs
(Assert_Done
);
1755 if Debug_Unit_Walk
then
1756 Write_Unit_Info
(Unit_Num
, Item
, Withs
=> True);
1759 -- Main unit should come last, except in the case where we
1760 -- skipped System_Aux_Id, in which case we missed the things it
1761 -- depends on, and in the case of parent bodies if present.
1764 (not Done
(Main_Unit
)
1765 or else Present
(System_Aux_Id
)
1766 or else Nkind
(Item
) = N_Package_Body
);
1768 -- We shouldn't do the same thing twice
1770 pragma Assert
(not Done
(Unit_Num
));
1772 -- Everything we depend upon should already be done
1775 (Assert_Withed_Units_Done
(CU
, Include_Limited
=> False));
1779 -- Must be Standard, which has no entry in the units table
1781 pragma Assert
(Item
= Stand
.Standard_Package_Node
);
1783 if Debug_Unit_Walk
then
1784 Write_Line
("Standard");
1791 --------------------
1792 -- Do_Withed_Unit --
1793 --------------------
1795 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
) is
1797 Do_Unit_And_Dependents
(Withed_Unit
, Unit
(Withed_Unit
));
1799 -- If the unit in the with_clause is a generic instance, the clause
1800 -- now denotes the instance body. Traverse the corresponding spec
1801 -- because there may be no other dependence that will force the
1802 -- traversal of its own context.
1804 if Nkind
(Unit
(Withed_Unit
)) = N_Package_Body
1805 and then Is_Generic_Instance
1806 (Defining_Entity
(Unit
(Library_Unit
(Withed_Unit
))))
1808 Do_Withed_Unit
(Library_Unit
(Withed_Unit
));
1812 ----------------------------
1813 -- Do_Unit_And_Dependents --
1814 ----------------------------
1816 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
) is
1817 Unit_Num
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(CU
);
1819 Body_U
: Unit_Number_Type
;
1820 Parent_CU
: Node_Id
;
1822 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
1825 if not Seen
(Unit_Num
) then
1827 -- Process the with clauses
1829 Do_Withed_Units
(CU
, Include_Limited
=> False);
1831 -- Process the unit if it is a spec or the main unit, if it
1832 -- has no previous spec or we have done all other units.
1834 if not Nkind_In
(Item
, N_Package_Body
, N_Subprogram_Body
)
1835 or else Acts_As_Spec
(CU
)
1837 if CU
= Cunit
(Main_Unit
)
1838 and then not Do_Main
1840 Seen
(Unit_Num
) := False;
1843 Seen
(Unit_Num
) := True;
1845 if CU
= Library_Unit
(Main_CU
) then
1846 Process_Bodies_In_Context
(CU
);
1848 -- If main is a child unit, examine parent unit contexts
1849 -- to see if they include instantiated units. Also, if
1850 -- the parent itself is an instance, process its body
1851 -- because it may contain subprograms that are called
1852 -- in the main unit.
1854 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
1855 Child
:= Cunit_Entity
(Main_Unit
);
1856 while Is_Child_Unit
(Child
) loop
1859 (Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
1860 Process_Bodies_In_Context
(Parent_CU
);
1862 if Nkind
(Unit
(Parent_CU
)) = N_Package_Body
1864 Nkind
(Original_Node
(Unit
(Parent_CU
)))
1865 = N_Package_Instantiation
1867 not Seen
(Get_Cunit_Unit_Number
(Parent_CU
))
1869 Body_U
:= Get_Cunit_Unit_Number
(Parent_CU
);
1870 Seen
(Body_U
) := True;
1871 Do_Action
(Parent_CU
, Unit
(Parent_CU
));
1872 Done
(Body_U
) := True;
1875 Child
:= Scope
(Child
);
1880 Do_Action
(CU
, Item
);
1881 Done
(Unit_Num
) := True;
1885 end Do_Unit_And_Dependents
;
1887 -------------------------------
1888 -- Process_Bodies_In_Context --
1889 -------------------------------
1891 procedure Process_Bodies_In_Context
(Comp
: Node_Id
) is
1893 Body_U
: Unit_Number_Type
;
1897 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
1899 -- Start of processing for Process_Bodies_In_Context
1902 Clause
:= First
(Context_Items
(Comp
));
1903 while Present
(Clause
) loop
1904 if Nkind
(Clause
) = N_With_Clause
then
1905 Spec
:= Library_Unit
(Clause
);
1906 Body_CU
:= Library_Unit
(Spec
);
1908 -- If we are processing the spec of the main unit, load bodies
1909 -- only if the with_clause indicates that it forced the loading
1910 -- of the body for a generic instantiation. Note that bodies of
1911 -- parents that are instances have been loaded already.
1913 if Present
(Body_CU
)
1914 and then Body_CU
/= Cunit
(Main_Unit
)
1915 and then Nkind
(Unit
(Body_CU
)) /= N_Subprogram_Body
1916 and then (Nkind
(Unit
(Comp
)) /= N_Package_Declaration
1917 or else Present
(Withed_Body
(Clause
)))
1919 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
1921 if not Seen
(Body_U
)
1922 and then not Depends_On_Main
(Body_CU
)
1924 Seen
(Body_U
) := True;
1925 Do_Withed_Units
(Body_CU
, Include_Limited
=> False);
1926 Do_Action
(Body_CU
, Unit
(Body_CU
));
1927 Done
(Body_U
) := True;
1934 end Process_Bodies_In_Context
;
1936 -- Local Declarations
1940 -- Start of processing for Walk_Library_Items
1943 if Debug_Unit_Walk
then
1944 Write_Line
("Walk_Library_Items:");
1948 -- Do Standard first, then walk the Comp_Unit_List
1950 Do_Action
(Empty
, Standard_Package_Node
);
1952 -- First place the context of all instance bodies on the corresponding
1953 -- spec, because it may be needed to analyze the code at the place of
1954 -- the instantiation.
1956 Cur
:= First_Elmt
(Comp_Unit_List
);
1957 while Present
(Cur
) loop
1959 CU
: constant Node_Id
:= Node
(Cur
);
1960 N
: constant Node_Id
:= Unit
(CU
);
1963 if Nkind
(N
) = N_Package_Body
1964 and then Is_Generic_Instance
(Defining_Entity
(N
))
1967 (Context_Items
(CU
), Context_Items
(Library_Unit
(CU
)));
1974 -- Now traverse compilation units (specs) in order
1976 Cur
:= First_Elmt
(Comp_Unit_List
);
1977 while Present
(Cur
) loop
1979 CU
: constant Node_Id
:= Node
(Cur
);
1980 N
: constant Node_Id
:= Unit
(CU
);
1984 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
1988 -- If it is a subprogram body, process it if it has no
1991 -- If it's a package body, ignore it, unless it is a body
1992 -- created for an instance that is the main unit. In the case
1993 -- of subprograms, the body is the wrapper package. In case of
1994 -- a package, the original file carries the body, and the spec
1995 -- appears as a later entry in the units list.
1997 -- Otherwise bodies appear in the list only because of inlining
1998 -- or instantiations, and they are processed only if relevant.
1999 -- The flag Withed_Body on a context clause indicates that a
2000 -- unit contains an instantiation that may be needed later,
2001 -- and therefore the body that contains the generic body (and
2002 -- its context) must be traversed immediately after the
2003 -- corresponding spec (see Do_Unit_And_Dependents).
2005 -- The main unit itself is processed separately after all other
2006 -- specs, and relevant bodies are examined in Process_Main.
2008 when N_Subprogram_Body
=>
2009 if Acts_As_Spec
(N
) then
2010 Do_Unit_And_Dependents
(CU
, N
);
2013 when N_Package_Body
=>
2015 and then Nkind
(Original_Node
(Unit
(Main_CU
))) in
2016 N_Generic_Instantiation
2017 and then Present
(Library_Unit
(Main_CU
))
2019 Do_Unit_And_Dependents
2020 (Library_Unit
(Main_CU
),
2021 Unit
(Library_Unit
(Main_CU
)));
2024 -- It's a spec, process it, and the units it depends on,
2025 -- unless it is a descendent of the main unit. This can
2026 -- happen when the body of a parent depends on some other
2030 Par
:= Scope
(Defining_Entity
(Unit
(CU
)));
2032 if Is_Child_Unit
(Defining_Entity
(Unit
(CU
))) then
2034 and then Par
/= Standard_Standard
2035 and then Par
/= Cunit_Entity
(Main_Unit
)
2041 if Par
/= Cunit_Entity
(Main_Unit
) then
2042 Do_Unit_And_Dependents
(CU
, N
);
2050 -- Now process package bodies on which main depends, followed by bodies
2051 -- of parents, if present, and finally main itself.
2053 if not Done
(Main_Unit
) then
2056 Process_Main
: declare
2057 Parent_CU
: Node_Id
;
2059 Body_U
: Unit_Number_Type
;
2062 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean;
2063 -- If the main unit has subunits, their context may include
2064 -- bodies that are needed in the body of main. We must examine
2065 -- the context of the subunits, which are otherwise not made
2066 -- explicit in the main unit.
2068 ------------------------
2069 -- Is_Subunit_Of_Main --
2070 ------------------------
2072 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean is
2078 Lib
:= Library_Unit
(U
);
2079 return Nkind
(Unit
(U
)) = N_Subunit
2081 (Lib
= Cunit
(Main_Unit
)
2082 or else Is_Subunit_Of_Main
(Lib
));
2084 end Is_Subunit_Of_Main
;
2086 -- Start of processing for Process_Main
2089 Process_Bodies_In_Context
(Main_CU
);
2091 for Unit_Num
in Done
'Range loop
2092 if Is_Subunit_Of_Main
(Cunit
(Unit_Num
)) then
2093 Process_Bodies_In_Context
(Cunit
(Unit_Num
));
2097 -- If the main unit is a child unit, parent bodies may be present
2098 -- because they export instances or inlined subprograms. Check for
2099 -- presence of these, which are not present in context clauses.
2100 -- Note that if the parents are instances, their bodies have been
2101 -- processed before the main spec, because they may be needed
2102 -- therein, so the following loop only affects non-instances.
2104 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
2105 Child
:= Cunit_Entity
(Main_Unit
);
2106 while Is_Child_Unit
(Child
) loop
2108 Cunit
(Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
2109 Body_CU
:= Library_Unit
(Parent_CU
);
2111 if Present
(Body_CU
)
2112 and then not Seen
(Get_Cunit_Unit_Number
(Body_CU
))
2113 and then not Depends_On_Main
(Body_CU
)
2115 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
2116 Seen
(Body_U
) := True;
2117 Do_Action
(Body_CU
, Unit
(Body_CU
));
2118 Done
(Body_U
) := True;
2121 Child
:= Scope
(Child
);
2125 Do_Action
(Main_CU
, Unit
(Main_CU
));
2126 Done
(Main_Unit
) := True;
2130 if Debug_Unit_Walk
then
2131 if Done
/= (Done
'Range => True) then
2133 Write_Line
("Ignored units:");
2137 for Unit_Num
in Done
'Range loop
2138 if not Done
(Unit_Num
) then
2140 (Unit_Num
, Unit
(Cunit
(Unit_Num
)), Withs
=> True);
2148 pragma Assert
(Done
(Main_Unit
));
2150 if Debug_Unit_Walk
then
2152 Write_Line
("end Walk_Library_Items.");
2154 end Walk_Library_Items
;
2160 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean) is
2161 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2162 pragma Assert
(Nkind
(Unit
(CU
)) /= N_Subunit
);
2164 procedure Walk_Immediate
is new Walk_Withs_Immediate
(Action
);
2167 -- First walk the withs immediately on the library item
2169 Walk_Immediate
(CU
, Include_Limited
);
2171 -- For a body, we must also check for any subunits which belong to it
2172 -- and which have context clauses of their own, since these with'ed
2173 -- units are part of its own dependencies.
2175 if Nkind
(Unit
(CU
)) in N_Unit_Body
then
2176 for S
in Main_Unit
.. Last_Unit
loop
2178 -- We are only interested in subunits. For preproc. data and def.
2179 -- files, Cunit is Empty, so we need to test that first.
2181 if Cunit
(S
) /= Empty
2182 and then Nkind
(Unit
(Cunit
(S
))) = N_Subunit
2188 Pnode
:= Library_Unit
(Cunit
(S
));
2190 -- In -gnatc mode, the errors in the subunits will not have
2191 -- been recorded, but the analysis of the subunit may have
2192 -- failed, so just quit.
2198 -- Find ultimate parent of the subunit
2200 while Nkind
(Unit
(Pnode
)) = N_Subunit
loop
2201 Pnode
:= Library_Unit
(Pnode
);
2204 -- See if it belongs to current unit, and if so, include its
2205 -- with_clauses. Do not process main unit prematurely.
2207 if Pnode
= CU
and then CU
/= Cunit
(Main_Unit
) then
2208 Walk_Immediate
(Cunit
(S
), Include_Limited
);
2216 --------------------------
2217 -- Walk_Withs_Immediate --
2218 --------------------------
2220 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean) is
2221 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2223 Context_Item
: Node_Id
;
2228 Context_Item
:= First
(Context_Items
(CU
));
2229 while Present
(Context_Item
) loop
2230 if Nkind
(Context_Item
) = N_With_Clause
2231 and then (Include_Limited
2232 or else not Limited_Present
(Context_Item
))
2234 Lib_Unit
:= Library_Unit
(Context_Item
);
2237 -- If the context item indicates that a package body is needed
2238 -- because of an instantiation in CU, traverse the body now, even
2239 -- if CU is not related to the main unit. If the generic itself
2240 -- appears in a package body, the context item is this body, and
2241 -- it already appears in the traversal order, so we only need to
2242 -- examine the case of a context item being a package declaration.
2244 if Present
(Withed_Body
(Context_Item
))
2245 and then Nkind
(Unit
(Lib_Unit
)) = N_Package_Declaration
2246 and then Present
(Corresponding_Body
(Unit
(Lib_Unit
)))
2250 (Unit_Declaration_Node
2251 (Corresponding_Body
(Unit
(Lib_Unit
))));
2253 -- A body may have an implicit with on its own spec, in which
2254 -- case we must ignore this context item to prevent looping.
2256 if Unit
(CU
) /= Unit
(Body_CU
) then
2262 Context_Item
:= Next
(Context_Item
);
2264 end Walk_Withs_Immediate
;