1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 Errout
; use Errout
;
31 with Expander
; use Expander
;
32 with Fname
; use Fname
;
34 with Lib
.Load
; use Lib
.Load
;
35 with Nlists
; use Nlists
;
36 with Output
; use Output
;
37 with Restrict
; use Restrict
;
38 with Sem_Attr
; use Sem_Attr
;
39 with Sem_Aux
; use Sem_Aux
;
40 with Sem_Ch2
; use Sem_Ch2
;
41 with Sem_Ch3
; use Sem_Ch3
;
42 with Sem_Ch4
; use Sem_Ch4
;
43 with Sem_Ch5
; use Sem_Ch5
;
44 with Sem_Ch6
; use Sem_Ch6
;
45 with Sem_Ch7
; use Sem_Ch7
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Ch9
; use Sem_Ch9
;
48 with Sem_Ch10
; use Sem_Ch10
;
49 with Sem_Ch11
; use Sem_Ch11
;
50 with Sem_Ch12
; use Sem_Ch12
;
51 with Sem_Ch13
; use Sem_Ch13
;
52 with Sem_Prag
; use Sem_Prag
;
53 with Sem_Util
; use Sem_Util
;
54 with Sinfo
; use Sinfo
;
55 with Stand
; use Stand
;
56 with 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-generic
71 -- context, it is empty. At the moment, it is only used for avoiding
72 -- 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 unit.
84 -- Ignore limited withs, unless Include_Limited is True. CU must be an
85 -- 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_Expression
=>
162 Analyze_Case_Expression
(N
);
164 when N_Case_Statement
=>
165 Analyze_Case_Statement
(N
);
167 when N_Character_Literal
=>
168 Analyze_Character_Literal
(N
);
170 when N_Code_Statement
=>
171 Analyze_Code_Statement
(N
);
173 when N_Compilation_Unit
=>
174 Analyze_Compilation_Unit
(N
);
176 when N_Component_Declaration
=>
177 Analyze_Component_Declaration
(N
);
179 when N_Conditional_Expression
=>
180 Analyze_Conditional_Expression
(N
);
182 when N_Conditional_Entry_Call
=>
183 Analyze_Conditional_Entry_Call
(N
);
185 when N_Delay_Alternative
=>
186 Analyze_Delay_Alternative
(N
);
188 when N_Delay_Relative_Statement
=>
189 Analyze_Delay_Relative
(N
);
191 when N_Delay_Until_Statement
=>
192 Analyze_Delay_Until
(N
);
195 Analyze_Entry_Body
(N
);
197 when N_Entry_Body_Formal_Part
=>
198 Analyze_Entry_Body_Formal_Part
(N
);
200 when N_Entry_Call_Alternative
=>
201 Analyze_Entry_Call_Alternative
(N
);
203 when N_Entry_Declaration
=>
204 Analyze_Entry_Declaration
(N
);
206 when N_Entry_Index_Specification
=>
207 Analyze_Entry_Index_Specification
(N
);
209 when N_Enumeration_Representation_Clause
=>
210 Analyze_Enumeration_Representation_Clause
(N
);
212 when N_Exception_Declaration
=>
213 Analyze_Exception_Declaration
(N
);
215 when N_Exception_Renaming_Declaration
=>
216 Analyze_Exception_Renaming
(N
);
218 when N_Exit_Statement
=>
219 Analyze_Exit_Statement
(N
);
221 when N_Expanded_Name
=>
222 Analyze_Expanded_Name
(N
);
224 when N_Explicit_Dereference
=>
225 Analyze_Explicit_Dereference
(N
);
227 when N_Expression_Function
=>
228 Analyze_Expression_Function
(N
);
230 when N_Expression_With_Actions
=>
231 Analyze_Expression_With_Actions
(N
);
233 when N_Extended_Return_Statement
=>
234 Analyze_Extended_Return_Statement
(N
);
236 when N_Extension_Aggregate
=>
237 Analyze_Aggregate
(N
);
239 when N_Formal_Object_Declaration
=>
240 Analyze_Formal_Object_Declaration
(N
);
242 when N_Formal_Package_Declaration
=>
243 Analyze_Formal_Package_Declaration
(N
);
245 when N_Formal_Subprogram_Declaration
=>
246 Analyze_Formal_Subprogram_Declaration
(N
);
248 when N_Formal_Type_Declaration
=>
249 Analyze_Formal_Type_Declaration
(N
);
251 when N_Free_Statement
=>
252 Analyze_Free_Statement
(N
);
254 when N_Freeze_Entity
=>
255 Analyze_Freeze_Entity
(N
);
257 when N_Full_Type_Declaration
=>
258 Analyze_Full_Type_Declaration
(N
);
260 when N_Function_Call
=>
261 Analyze_Function_Call
(N
);
263 when N_Function_Instantiation
=>
264 Analyze_Function_Instantiation
(N
);
266 when N_Generic_Function_Renaming_Declaration
=>
267 Analyze_Generic_Function_Renaming
(N
);
269 when N_Generic_Package_Declaration
=>
270 Analyze_Generic_Package_Declaration
(N
);
272 when N_Generic_Package_Renaming_Declaration
=>
273 Analyze_Generic_Package_Renaming
(N
);
275 when N_Generic_Procedure_Renaming_Declaration
=>
276 Analyze_Generic_Procedure_Renaming
(N
);
278 when N_Generic_Subprogram_Declaration
=>
279 Analyze_Generic_Subprogram_Declaration
(N
);
281 when N_Goto_Statement
=>
282 Analyze_Goto_Statement
(N
);
284 when N_Handled_Sequence_Of_Statements
=>
285 Analyze_Handled_Statements
(N
);
288 Analyze_Identifier
(N
);
290 when N_If_Statement
=>
291 Analyze_If_Statement
(N
);
293 when N_Implicit_Label_Declaration
=>
294 Analyze_Implicit_Label_Declaration
(N
);
297 Analyze_Membership_Op
(N
);
299 when N_Incomplete_Type_Declaration
=>
300 Analyze_Incomplete_Type_Decl
(N
);
302 when N_Indexed_Component
=>
303 Analyze_Indexed_Component_Form
(N
);
305 when N_Integer_Literal
=>
306 Analyze_Integer_Literal
(N
);
308 when N_Iterator_Specification
=>
309 Analyze_Iterator_Specification
(N
);
311 when N_Itype_Reference
=>
312 Analyze_Itype_Reference
(N
);
317 when N_Loop_Parameter_Specification
=>
318 Analyze_Loop_Parameter_Specification
(N
);
320 when N_Loop_Statement
=>
321 Analyze_Loop_Statement
(N
);
324 Analyze_Membership_Op
(N
);
329 when N_Null_Statement
=>
330 Analyze_Null_Statement
(N
);
332 when N_Number_Declaration
=>
333 Analyze_Number_Declaration
(N
);
335 when N_Object_Declaration
=>
336 Analyze_Object_Declaration
(N
);
338 when N_Object_Renaming_Declaration
=>
339 Analyze_Object_Renaming
(N
);
341 when N_Operator_Symbol
=>
342 Analyze_Operator_Symbol
(N
);
345 Analyze_Unary_Op
(N
);
348 Analyze_Arithmetic_Op
(N
);
351 Analyze_Logical_Op
(N
);
354 Analyze_Concatenation
(N
);
357 Analyze_Arithmetic_Op
(N
);
360 Analyze_Equality_Op
(N
);
363 Analyze_Arithmetic_Op
(N
);
366 Analyze_Comparison_Op
(N
);
369 Analyze_Comparison_Op
(N
);
372 Analyze_Comparison_Op
(N
);
375 Analyze_Comparison_Op
(N
);
378 Analyze_Unary_Op
(N
);
383 when N_Op_Multiply
=>
384 Analyze_Arithmetic_Op
(N
);
387 Analyze_Equality_Op
(N
);
390 Analyze_Negation
(N
);
393 Analyze_Logical_Op
(N
);
396 Analyze_Unary_Op
(N
);
399 Analyze_Arithmetic_Op
(N
);
401 when N_Op_Rotate_Left
=>
402 Analyze_Arithmetic_Op
(N
);
404 when N_Op_Rotate_Right
=>
405 Analyze_Arithmetic_Op
(N
);
407 when N_Op_Shift_Left
=>
408 Analyze_Arithmetic_Op
(N
);
410 when N_Op_Shift_Right
=>
411 Analyze_Arithmetic_Op
(N
);
413 when N_Op_Shift_Right_Arithmetic
=>
414 Analyze_Arithmetic_Op
(N
);
416 when N_Op_Subtract
=>
417 Analyze_Arithmetic_Op
(N
);
420 Analyze_Logical_Op
(N
);
423 Analyze_Short_Circuit
(N
);
425 when N_Others_Choice
=>
426 Analyze_Others_Choice
(N
);
428 when N_Package_Body
=>
429 Analyze_Package_Body
(N
);
431 when N_Package_Body_Stub
=>
432 Analyze_Package_Body_Stub
(N
);
434 when N_Package_Declaration
=>
435 Analyze_Package_Declaration
(N
);
437 when N_Package_Instantiation
=>
438 Analyze_Package_Instantiation
(N
);
440 when N_Package_Renaming_Declaration
=>
441 Analyze_Package_Renaming
(N
);
443 when N_Package_Specification
=>
444 Analyze_Package_Specification
(N
);
446 when N_Parameter_Association
=>
447 Analyze_Parameter_Association
(N
);
452 when N_Private_Extension_Declaration
=>
453 Analyze_Private_Extension_Declaration
(N
);
455 when N_Private_Type_Declaration
=>
456 Analyze_Private_Type_Declaration
(N
);
458 when N_Procedure_Call_Statement
=>
459 Analyze_Procedure_Call
(N
);
461 when N_Procedure_Instantiation
=>
462 Analyze_Procedure_Instantiation
(N
);
464 when N_Protected_Body
=>
465 Analyze_Protected_Body
(N
);
467 when N_Protected_Body_Stub
=>
468 Analyze_Protected_Body_Stub
(N
);
470 when N_Protected_Definition
=>
471 Analyze_Protected_Definition
(N
);
473 when N_Protected_Type_Declaration
=>
474 Analyze_Protected_Type_Declaration
(N
);
476 when N_Qualified_Expression
=>
477 Analyze_Qualified_Expression
(N
);
479 when N_Quantified_Expression
=>
480 Analyze_Quantified_Expression
(N
);
482 when N_Raise_Statement
=>
483 Analyze_Raise_Statement
(N
);
485 when N_Raise_xxx_Error
=>
486 Analyze_Raise_xxx_Error
(N
);
491 when N_Range_Constraint
=>
492 Analyze_Range
(Range_Expression
(N
));
494 when N_Real_Literal
=>
495 Analyze_Real_Literal
(N
);
497 when N_Record_Representation_Clause
=>
498 Analyze_Record_Representation_Clause
(N
);
501 Analyze_Reference
(N
);
503 when N_Requeue_Statement
=>
506 when N_Simple_Return_Statement
=>
507 Analyze_Simple_Return_Statement
(N
);
509 when N_Selected_Component
=>
510 Find_Selected_Component
(N
);
511 -- ??? why not Analyze_Selected_Component, needs comments
513 when N_Selective_Accept
=>
514 Analyze_Selective_Accept
(N
);
516 when N_Single_Protected_Declaration
=>
517 Analyze_Single_Protected_Declaration
(N
);
519 when N_Single_Task_Declaration
=>
520 Analyze_Single_Task_Declaration
(N
);
525 when N_String_Literal
=>
526 Analyze_String_Literal
(N
);
528 when N_Subprogram_Body
=>
529 Analyze_Subprogram_Body
(N
);
531 when N_Subprogram_Body_Stub
=>
532 Analyze_Subprogram_Body_Stub
(N
);
534 when N_Subprogram_Declaration
=>
535 Analyze_Subprogram_Declaration
(N
);
537 when N_Subprogram_Info
=>
538 Analyze_Subprogram_Info
(N
);
540 when N_Subprogram_Renaming_Declaration
=>
541 Analyze_Subprogram_Renaming
(N
);
543 when N_Subtype_Declaration
=>
544 Analyze_Subtype_Declaration
(N
);
546 when N_Subtype_Indication
=>
547 Analyze_Subtype_Indication
(N
);
553 Analyze_Task_Body
(N
);
555 when N_Task_Body_Stub
=>
556 Analyze_Task_Body_Stub
(N
);
558 when N_Task_Definition
=>
559 Analyze_Task_Definition
(N
);
561 when N_Task_Type_Declaration
=>
562 Analyze_Task_Type_Declaration
(N
);
564 when N_Terminate_Alternative
=>
565 Analyze_Terminate_Alternative
(N
);
567 when N_Timed_Entry_Call
=>
568 Analyze_Timed_Entry_Call
(N
);
570 when N_Triggering_Alternative
=>
571 Analyze_Triggering_Alternative
(N
);
573 when N_Type_Conversion
=>
574 Analyze_Type_Conversion
(N
);
576 when N_Unchecked_Expression
=>
577 Analyze_Unchecked_Expression
(N
);
579 when N_Unchecked_Type_Conversion
=>
580 Analyze_Unchecked_Type_Conversion
(N
);
582 when N_Use_Package_Clause
=>
583 Analyze_Use_Package
(N
);
585 when N_Use_Type_Clause
=>
586 Analyze_Use_Type
(N
);
588 when N_Validate_Unchecked_Conversion
=>
591 when N_Variant_Part
=>
592 Analyze_Variant_Part
(N
);
594 when N_With_Clause
=>
595 Analyze_With_Clause
(N
);
597 -- A call to analyze the Empty node is an error, but most likely it
598 -- is an error caused by an attempt to analyze a malformed piece of
599 -- tree caused by some other error, so if there have been any other
600 -- errors, we just ignore it, otherwise it is a real internal error
601 -- which we complain about.
603 -- We must also consider the case of call to a runtime function that
604 -- is not available in the configurable runtime.
607 pragma Assert
(Serious_Errors_Detected
/= 0
608 or else Configurable_Run_Time_Violations
/= 0);
611 -- A call to analyze the error node is simply ignored, to avoid
612 -- causing cascaded errors (happens of course only in error cases)
617 -- Push/Pop nodes normally don't come through an analyze call. An
618 -- exception is the dummy ones bracketing a subprogram body. In any
619 -- case there is nothing to be done to analyze such nodes.
621 when N_Push_Pop_xxx_Label
=>
624 -- SCIL nodes don't need analysis because they are decorated when
625 -- they are built. They are added to the tree by Insert_Actions and
626 -- the call to analyze them is generated when the full list is
630 N_SCIL_Dispatch_Table_Tag_Init |
631 N_SCIL_Dispatching_Call |
632 N_SCIL_Membership_Test
=>
635 -- For the remaining node types, we generate compiler abort, because
636 -- these nodes are always analyzed within the Sem_Chn routines and
637 -- there should never be a case of making a call to the main Analyze
638 -- routine for these node kinds. For example, an N_Access_Definition
639 -- node appears only in the context of a type declaration, and is
640 -- processed by the analyze routine for type declarations.
644 N_Access_Definition |
645 N_Access_Function_Definition |
646 N_Access_Procedure_Definition |
647 N_Access_To_Object_Definition |
648 N_Aspect_Specification |
649 N_Case_Expression_Alternative |
650 N_Case_Statement_Alternative |
651 N_Compilation_Unit_Aux |
652 N_Component_Association |
654 N_Component_Definition |
656 N_Constrained_Array_Definition |
658 N_Decimal_Fixed_Point_Definition |
659 N_Defining_Character_Literal |
660 N_Defining_Identifier |
661 N_Defining_Operator_Symbol |
662 N_Defining_Program_Unit_Name |
664 N_Derived_Type_Definition |
666 N_Digits_Constraint |
667 N_Discriminant_Association |
668 N_Discriminant_Specification |
670 N_Entry_Call_Statement |
671 N_Enumeration_Type_Definition |
672 N_Exception_Handler |
673 N_Floating_Point_Definition |
674 N_Formal_Decimal_Fixed_Point_Definition |
675 N_Formal_Derived_Type_Definition |
676 N_Formal_Discrete_Type_Definition |
677 N_Formal_Floating_Point_Definition |
678 N_Formal_Modular_Type_Definition |
679 N_Formal_Ordinary_Fixed_Point_Definition |
680 N_Formal_Private_Type_Definition |
681 N_Formal_Incomplete_Type_Definition |
682 N_Formal_Signed_Integer_Type_Definition |
683 N_Function_Specification |
684 N_Generic_Association |
685 N_Index_Or_Discriminant_Constraint |
688 N_Modular_Type_Definition |
689 N_Ordinary_Fixed_Point_Definition |
690 N_Parameter_Specification |
691 N_Pragma_Argument_Association |
692 N_Procedure_Specification |
693 N_Real_Range_Specification |
694 N_Record_Definition |
695 N_Signed_Integer_Type_Definition |
696 N_Unconstrained_Array_Definition |
704 Debug_A_Exit
("analyzing ", N
, " (done)");
706 -- Now that we have analyzed the node, we call the expander to perform
707 -- possible expansion. We skip this for subexpressions, because we don't
708 -- have the type yet, and the expander will need to know the type before
709 -- it can do its job. For subexpression nodes, the call to the expander
710 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
711 -- which can appear in a statement context, and needs expanding now in
712 -- the case (distinguished by Etype, as documented in Sinfo).
714 -- The Analyzed flag is also set at this point for non-subexpression
715 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
716 -- since resolution and expansion have not yet been completed). Note
717 -- that for N_Raise_xxx_Error we have to distinguish the expression
718 -- case from the statement case.
720 if Nkind
(N
) not in N_Subexpr
721 or else (Nkind
(N
) in N_Raise_xxx_Error
722 and then Etype
(N
) = Standard_Void_Type
)
728 -- Version with check(s) suppressed
730 procedure Analyze
(N
: Node_Id
; Suppress
: Check_Id
) is
732 if Suppress
= All_Checks
then
734 Svg
: constant Suppress_Array
:= Scope_Suppress
;
736 Scope_Suppress
:= (others => True);
738 Scope_Suppress
:= Svg
;
743 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
745 Scope_Suppress
(Suppress
) := True;
747 Scope_Suppress
(Suppress
) := Svg
;
756 procedure Analyze_List
(L
: List_Id
) is
761 while Present
(Node
) loop
767 -- Version with check(s) suppressed
769 procedure Analyze_List
(L
: List_Id
; Suppress
: Check_Id
) is
771 if Suppress
= All_Checks
then
773 Svg
: constant Suppress_Array
:= Scope_Suppress
;
775 Scope_Suppress
:= (others => True);
777 Scope_Suppress
:= Svg
;
782 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
784 Scope_Suppress
(Suppress
) := True;
786 Scope_Suppress
(Suppress
) := Svg
;
791 --------------------------
792 -- Copy_Suppress_Status --
793 --------------------------
795 procedure Copy_Suppress_Status
801 pragma Warnings
(Off
, Found
);
803 procedure Search_Stack
804 (Top
: Suppress_Stack_Entry_Ptr
;
805 Found
: out Boolean);
806 -- Search given suppress stack for matching entry for entity. If found
807 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
808 -- entry for To onto the local suppress stack.
814 procedure Search_Stack
815 (Top
: Suppress_Stack_Entry_Ptr
;
818 Ptr
: Suppress_Stack_Entry_Ptr
;
822 while Ptr
/= null loop
824 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
827 Set_Checks_May_Be_Suppressed
(To
, True);
828 Push_Local_Suppress_Stack_Entry
844 -- Start of processing for Copy_Suppress_Status
847 if not Checks_May_Be_Suppressed
(From
) then
851 -- First search the global entity suppress table for a matching entry.
852 -- We also search this in reverse order so that if there are multiple
853 -- pragmas for the same entity, the last one applies.
855 Search_Stack
(Global_Suppress_Stack_Top
, Found
);
861 -- Now search the local entity suppress stack, we search this in
862 -- reverse order so that we get the innermost entry that applies to
863 -- this case if there are nested entries. Note that for the purpose
864 -- of this procedure we are ONLY looking for entries corresponding
865 -- to a two-argument Suppress, where the second argument matches From.
867 Search_Stack
(Local_Suppress_Stack_Top
, Found
);
868 end Copy_Suppress_Status
;
870 -------------------------
871 -- Enter_Generic_Scope --
872 -------------------------
874 procedure Enter_Generic_Scope
(S
: Entity_Id
) is
876 if No
(Outer_Generic_Scope
) then
877 Outer_Generic_Scope
:= S
;
879 end Enter_Generic_Scope
;
881 ------------------------
882 -- Exit_Generic_Scope --
883 ------------------------
885 procedure Exit_Generic_Scope
(S
: Entity_Id
) is
887 if S
= Outer_Generic_Scope
then
888 Outer_Generic_Scope
:= Empty
;
890 end Exit_Generic_Scope
;
892 -----------------------
893 -- Explicit_Suppress --
894 -----------------------
896 function Explicit_Suppress
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
897 Ptr
: Suppress_Stack_Entry_Ptr
;
900 if not Checks_May_Be_Suppressed
(E
) then
904 Ptr
:= Global_Suppress_Stack_Top
;
905 while Ptr
/= null loop
907 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
917 end Explicit_Suppress
;
919 -----------------------------
920 -- External_Ref_In_Generic --
921 -----------------------------
923 function External_Ref_In_Generic
(E
: Entity_Id
) return Boolean is
927 -- Entity is global if defined outside of current outer_generic_scope:
928 -- Either the entity has a smaller depth that the outer generic, or it
929 -- is in a different compilation unit, or it is defined within a unit
930 -- in the same compilation, that is not within the outer_generic.
932 if No
(Outer_Generic_Scope
) then
935 elsif Scope_Depth
(Scope
(E
)) < Scope_Depth
(Outer_Generic_Scope
)
936 or else not In_Same_Source_Unit
(E
, Outer_Generic_Scope
)
942 while Present
(Scop
) loop
943 if Scop
= Outer_Generic_Scope
then
945 elsif Scope_Depth
(Scop
) < Scope_Depth
(Outer_Generic_Scope
) then
948 Scop
:= Scope
(Scop
);
954 end External_Ref_In_Generic
;
960 procedure Initialize
is
961 Next
: Suppress_Stack_Entry_Ptr
;
963 procedure Free
is new Unchecked_Deallocation
964 (Suppress_Stack_Entry
, Suppress_Stack_Entry_Ptr
);
967 -- Free any global suppress stack entries from a previous invocation
968 -- of the compiler (in the normal case this loop does nothing).
970 while Suppress_Stack_Entries
/= null loop
971 Next
:= Suppress_Stack_Entries
.Next
;
972 Free
(Suppress_Stack_Entries
);
973 Suppress_Stack_Entries
:= Next
;
976 Local_Suppress_Stack_Top
:= null;
977 Global_Suppress_Stack_Top
:= null;
979 -- Clear scope stack, and reset global variables
982 Unloaded_Subunits
:= False;
985 ------------------------------
986 -- Insert_After_And_Analyze --
987 ------------------------------
989 procedure Insert_After_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
995 -- If we are not at the end of the list, then the easiest
996 -- coding is simply to insert before our successor
998 if Present
(Next
(N
)) then
999 Insert_Before_And_Analyze
(Next
(N
), M
);
1001 -- Case of inserting at the end of the list
1004 -- Capture the Node_Id of the node to be inserted. This Node_Id
1005 -- will still be the same after the insert operation.
1008 Insert_After
(N
, M
);
1010 -- Now just analyze from the inserted node to the end of
1011 -- the new list (note that this properly handles the case
1012 -- where any of the analyze calls result in the insertion of
1013 -- nodes after the analyzed node, expecting analysis).
1015 while Present
(Node
) loop
1017 Mark_Rewrite_Insertion
(Node
);
1022 end Insert_After_And_Analyze
;
1024 -- Version with check(s) suppressed
1026 procedure Insert_After_And_Analyze
1029 Suppress
: Check_Id
)
1032 if Suppress
= All_Checks
then
1034 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1036 Scope_Suppress
:= (others => True);
1037 Insert_After_And_Analyze
(N
, M
);
1038 Scope_Suppress
:= Svg
;
1043 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1045 Scope_Suppress
(Suppress
) := True;
1046 Insert_After_And_Analyze
(N
, M
);
1047 Scope_Suppress
(Suppress
) := Svg
;
1050 end Insert_After_And_Analyze
;
1052 -------------------------------
1053 -- Insert_Before_And_Analyze --
1054 -------------------------------
1056 procedure Insert_Before_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
1062 -- Capture the Node_Id of the first list node to be inserted.
1063 -- This will still be the first node after the insert operation,
1064 -- since Insert_List_After does not modify the Node_Id values.
1067 Insert_Before
(N
, M
);
1069 -- The insertion does not change the Id's of any of the nodes in
1070 -- the list, and they are still linked, so we can simply loop from
1071 -- the original first node until we meet the node before which the
1072 -- insertion is occurring. Note that this properly handles the case
1073 -- where any of the analyzed nodes insert nodes after themselves,
1074 -- expecting them to get analyzed.
1076 while Node
/= N
loop
1078 Mark_Rewrite_Insertion
(Node
);
1082 end Insert_Before_And_Analyze
;
1084 -- Version with check(s) suppressed
1086 procedure Insert_Before_And_Analyze
1089 Suppress
: Check_Id
)
1092 if Suppress
= All_Checks
then
1094 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1096 Scope_Suppress
:= (others => True);
1097 Insert_Before_And_Analyze
(N
, M
);
1098 Scope_Suppress
:= Svg
;
1103 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1105 Scope_Suppress
(Suppress
) := True;
1106 Insert_Before_And_Analyze
(N
, M
);
1107 Scope_Suppress
(Suppress
) := Svg
;
1110 end Insert_Before_And_Analyze
;
1112 -----------------------------------
1113 -- Insert_List_After_And_Analyze --
1114 -----------------------------------
1116 procedure Insert_List_After_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1117 After
: constant Node_Id
:= Next
(N
);
1121 if Is_Non_Empty_List
(L
) then
1123 -- Capture the Node_Id of the first list node to be inserted.
1124 -- This will still be the first node after the insert operation,
1125 -- since Insert_List_After does not modify the Node_Id values.
1128 Insert_List_After
(N
, L
);
1130 -- Now just analyze from the original first node until we get to the
1131 -- successor of the original insertion point (which may be Empty if
1132 -- the insertion point was at the end of the list). Note that this
1133 -- properly handles the case where any of the analyze calls result in
1134 -- the insertion of nodes after the analyzed node (possibly calling
1135 -- this routine recursively).
1137 while Node
/= After
loop
1139 Mark_Rewrite_Insertion
(Node
);
1143 end Insert_List_After_And_Analyze
;
1145 -- Version with check(s) suppressed
1147 procedure Insert_List_After_And_Analyze
1148 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1151 if Suppress
= All_Checks
then
1153 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1155 Scope_Suppress
:= (others => True);
1156 Insert_List_After_And_Analyze
(N
, L
);
1157 Scope_Suppress
:= Svg
;
1162 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1164 Scope_Suppress
(Suppress
) := True;
1165 Insert_List_After_And_Analyze
(N
, L
);
1166 Scope_Suppress
(Suppress
) := Svg
;
1169 end Insert_List_After_And_Analyze
;
1171 ------------------------------------
1172 -- Insert_List_Before_And_Analyze --
1173 ------------------------------------
1175 procedure Insert_List_Before_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1179 if Is_Non_Empty_List
(L
) then
1181 -- Capture the Node_Id of the first list node to be inserted. This
1182 -- will still be the first node after the insert operation, since
1183 -- Insert_List_After does not modify the Node_Id values.
1186 Insert_List_Before
(N
, L
);
1188 -- The insertion does not change the Id's of any of the nodes in
1189 -- the list, and they are still linked, so we can simply loop from
1190 -- the original first node until we meet the node before which the
1191 -- insertion is occurring. Note that this properly handles the case
1192 -- where any of the analyzed nodes insert nodes after themselves,
1193 -- expecting them to get analyzed.
1195 while Node
/= N
loop
1197 Mark_Rewrite_Insertion
(Node
);
1201 end Insert_List_Before_And_Analyze
;
1203 -- Version with check(s) suppressed
1205 procedure Insert_List_Before_And_Analyze
1206 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1209 if Suppress
= All_Checks
then
1211 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1213 Scope_Suppress
:= (others => True);
1214 Insert_List_Before_And_Analyze
(N
, L
);
1215 Scope_Suppress
:= Svg
;
1220 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1222 Scope_Suppress
(Suppress
) := True;
1223 Insert_List_Before_And_Analyze
(N
, L
);
1224 Scope_Suppress
(Suppress
) := Svg
;
1227 end Insert_List_Before_And_Analyze
;
1229 -------------------------
1230 -- Is_Check_Suppressed --
1231 -------------------------
1233 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
1235 Ptr
: Suppress_Stack_Entry_Ptr
;
1238 -- First search the local entity suppress stack. We search this from the
1239 -- top of the stack down so that we get the innermost entry that applies
1240 -- to this case if there are nested entries.
1242 Ptr
:= Local_Suppress_Stack_Top
;
1243 while Ptr
/= null loop
1244 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
1245 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
1247 return Ptr
.Suppress
;
1253 -- Now search the global entity suppress table for a matching entry.
1254 -- We also search this from the top down so that if there are multiple
1255 -- pragmas for the same entity, the last one applies (not clear what
1256 -- or whether the RM specifies this handling, but it seems reasonable).
1258 Ptr
:= Global_Suppress_Stack_Top
;
1259 while Ptr
/= null loop
1260 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
1261 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
1263 return Ptr
.Suppress
;
1269 -- If we did not find a matching entry, then use the normal scope
1270 -- suppress value after all (actually this will be the global setting
1271 -- since it clearly was not overridden at any point). For a predefined
1272 -- check, we test the specific flag. For a user defined check, we check
1273 -- the All_Checks flag.
1275 if C
in Predefined_Check_Id
then
1276 return Scope_Suppress
(C
);
1278 return Scope_Suppress
(All_Checks
);
1280 end Is_Check_Suppressed
;
1288 Scope_Stack
.Locked
:= True;
1289 Scope_Stack
.Release
;
1296 procedure Preanalyze
(N
: Node_Id
) is
1297 Save_Full_Analysis
: constant Boolean := Full_Analysis
;
1300 Full_Analysis
:= False;
1301 Expander_Mode_Save_And_Set
(False);
1305 Expander_Mode_Restore
;
1306 Full_Analysis
:= Save_Full_Analysis
;
1309 --------------------------------------
1310 -- Push_Global_Suppress_Stack_Entry --
1311 --------------------------------------
1313 procedure Push_Global_Suppress_Stack_Entry
1314 (Entity
: Entity_Id
;
1319 Global_Suppress_Stack_Top
:=
1320 new Suppress_Stack_Entry
'
1323 Suppress => Suppress,
1324 Prev => Global_Suppress_Stack_Top,
1325 Next => Suppress_Stack_Entries);
1326 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1329 end Push_Global_Suppress_Stack_Entry;
1331 -------------------------------------
1332 -- Push_Local_Suppress_Stack_Entry --
1333 -------------------------------------
1335 procedure Push_Local_Suppress_Stack_Entry
1336 (Entity : Entity_Id;
1341 Local_Suppress_Stack_Top :=
1342 new Suppress_Stack_Entry'
1345 Suppress
=> Suppress
,
1346 Prev
=> Local_Suppress_Stack_Top
,
1347 Next
=> Suppress_Stack_Entries
);
1348 Suppress_Stack_Entries
:= Local_Suppress_Stack_Top
;
1351 end Push_Local_Suppress_Stack_Entry
;
1357 procedure Semantics
(Comp_Unit
: Node_Id
) is
1359 -- The following locations save the corresponding global flags and
1360 -- variables so that they can be restored on completion. This is needed
1361 -- so that calls to Rtsfind start with the proper default values for
1362 -- these variables, and also that such calls do not disturb the settings
1363 -- for units being analyzed at a higher level.
1365 S_Current_Sem_Unit
: constant Unit_Number_Type
:= Current_Sem_Unit
;
1366 S_Full_Analysis
: constant Boolean := Full_Analysis
;
1367 S_GNAT_Mode
: constant Boolean := GNAT_Mode
;
1368 S_Global_Dis_Names
: constant Boolean := Global_Discard_Names
;
1369 S_In_Spec_Expr
: constant Boolean := In_Spec_Expression
;
1370 S_Inside_A_Generic
: constant Boolean := Inside_A_Generic
;
1371 S_Outer_Gen_Scope
: constant Entity_Id
:= Outer_Generic_Scope
;
1373 Generic_Main
: constant Boolean :=
1374 Nkind
(Unit
(Cunit
(Main_Unit
)))
1375 in N_Generic_Declaration
;
1376 -- If the main unit is generic, every compiled unit, including its
1377 -- context, is compiled with expansion disabled.
1379 Save_Config_Switches
: Config_Switches_Type
;
1380 -- Variable used to save values of config switches while we analyze the
1381 -- new unit, to be restored on exit for proper recursive behavior.
1383 Save_Cunit_Restrictions
: Save_Cunit_Boolean_Restrictions
;
1384 -- Used to save non-partition wide restrictions before processing new
1385 -- unit. All with'ed units are analyzed with config restrictions reset
1386 -- and we need to restore these saved values at the end.
1388 procedure Do_Analyze
;
1389 -- Procedure to analyze the compilation unit
1395 procedure Do_Analyze
is
1398 Push_Scope
(Standard_Standard
);
1399 Scope_Suppress
:= Suppress_Options
;
1401 (Scope_Stack
.Last
).Component_Alignment_Default
:= Calign_Default
;
1403 (Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
1404 Outer_Generic_Scope
:= Empty
;
1406 -- Now analyze the top level compilation unit node
1408 Analyze
(Comp_Unit
);
1410 -- Check for scope mismatch on exit from compilation
1412 pragma Assert
(Current_Scope
= Standard_Standard
1413 or else Comp_Unit
= Cunit
(Main_Unit
));
1415 -- Then pop entry for Standard, and pop implicit types
1418 Restore_Scope_Stack
;
1421 Already_Analyzed
: constant Boolean := Analyzed
(Comp_Unit
);
1423 -- Start of processing for Semantics
1426 if Debug_Unit_Walk
then
1427 if Already_Analyzed
then
1428 Write_Str
("(done)");
1432 (Get_Cunit_Unit_Number
(Comp_Unit
),
1438 Compiler_State
:= Analyzing
;
1439 Current_Sem_Unit
:= Get_Cunit_Unit_Number
(Comp_Unit
);
1441 -- Compile predefined units with GNAT_Mode set to True, to properly
1442 -- process the categorization stuff. However, do not set GNAT_Mode
1443 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1444 -- Sequential_IO) as this would prevent pragma Extend_System from being
1445 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1447 -- Cleaner might be to do the kludge at the point of excluding the
1448 -- pragma (do not exclude for renamings ???)
1450 if Is_Predefined_File_Name
1451 (Unit_File_Name
(Current_Sem_Unit
), Renamings_Included
=> False)
1456 if Generic_Main
then
1457 Expander_Mode_Save_And_Set
(False);
1459 Expander_Mode_Save_And_Set
1460 (Operating_Mode
= Generate_Code
or Debug_Flag_X
);
1463 Full_Analysis
:= True;
1464 Inside_A_Generic
:= False;
1465 In_Spec_Expression
:= False;
1467 Set_Comes_From_Source_Default
(False);
1469 -- Save current config switches and reset then appropriately
1471 Save_Opt_Config_Switches
(Save_Config_Switches
);
1472 Set_Opt_Config_Switches
1473 (Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
)),
1474 Current_Sem_Unit
= Main_Unit
);
1476 -- Save current non-partition-wide restrictions
1478 Save_Cunit_Restrictions
:= Cunit_Boolean_Restrictions_Save
;
1480 -- For unit in main extended unit, we reset the configuration values
1481 -- for the non-partition-wide restrictions. For other units reset them.
1483 if In_Extended_Main_Source_Unit
(Comp_Unit
) then
1484 Restore_Config_Cunit_Boolean_Restrictions
;
1486 Reset_Cunit_Boolean_Restrictions
;
1489 -- Only do analysis of unit that has not already been analyzed
1491 if not Analyzed
(Comp_Unit
) then
1492 Initialize_Version
(Current_Sem_Unit
);
1494 -- Do analysis, and then append the compilation unit onto the
1495 -- Comp_Unit_List, if appropriate. This is done after analysis,
1496 -- so if this unit depends on some others, they have already been
1497 -- appended. We ignore bodies, except for the main unit itself, and
1498 -- for subprogram bodies that act as specs. We have also to guard
1499 -- against ill-formed subunits that have an improper context.
1503 if Present
(Comp_Unit
)
1504 and then Nkind
(Unit
(Comp_Unit
)) in N_Proper_Body
1505 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Subprogram_Body
1506 or else not Acts_As_Spec
(Comp_Unit
))
1507 and then not In_Extended_Main_Source_Unit
(Comp_Unit
)
1512 -- Initialize if first time
1514 if No
(Comp_Unit_List
) then
1515 Comp_Unit_List
:= New_Elmt_List
;
1518 Append_Elmt
(Comp_Unit
, Comp_Unit_List
);
1520 if Debug_Unit_Walk
then
1521 Write_Str
("Appending ");
1523 (Get_Cunit_Unit_Number
(Comp_Unit
), Unit
(Comp_Unit
));
1528 -- Save indication of dynamic elaboration checks for ALI file
1530 Set_Dynamic_Elab
(Current_Sem_Unit
, Dynamic_Elaboration_Checks
);
1532 -- Restore settings of saved switches to entry values
1534 Current_Sem_Unit
:= S_Current_Sem_Unit
;
1535 Full_Analysis
:= S_Full_Analysis
;
1536 Global_Discard_Names
:= S_Global_Dis_Names
;
1537 GNAT_Mode
:= S_GNAT_Mode
;
1538 In_Spec_Expression
:= S_In_Spec_Expr
;
1539 Inside_A_Generic
:= S_Inside_A_Generic
;
1540 Outer_Generic_Scope
:= S_Outer_Gen_Scope
;
1542 Restore_Opt_Config_Switches
(Save_Config_Switches
);
1544 -- Deal with restore of restrictions
1546 Cunit_Boolean_Restrictions_Restore
(Save_Cunit_Restrictions
);
1548 Expander_Mode_Restore
;
1550 if Debug_Unit_Walk
then
1553 if Already_Analyzed
then
1554 Write_Str
("(done)");
1558 (Get_Cunit_Unit_Number
(Comp_Unit
),
1568 function ss
(Index
: Int
) return Scope_Stack_Entry
is
1570 return Scope_Stack
.Table
(Index
);
1577 function sst
return Scope_Stack_Entry
is
1579 return ss
(Scope_Stack
.Last
);
1582 ------------------------
1583 -- Walk_Library_Items --
1584 ------------------------
1586 procedure Walk_Library_Items
is
1587 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
1588 pragma Pack
(Unit_Number_Set
);
1590 Main_CU
: constant Node_Id
:= Cunit
(Main_Unit
);
1592 Seen
, Done
: Unit_Number_Set
:= (others => False);
1593 -- Seen (X) is True after we have seen unit X in the walk. This is used
1594 -- to prevent processing the same unit more than once. Done (X) is True
1595 -- after we have fully processed X, and is used only for debugging
1596 -- printouts and assertions.
1598 Do_Main
: Boolean := False;
1599 -- Flag to delay processing the main body until after all other units.
1600 -- This is needed because the spec of the main unit may appear in the
1601 -- context of some other unit. We do not want this to force processing
1602 -- of the main body before all other units have been processed.
1604 -- Another circularity pattern occurs when the main unit is a child unit
1605 -- and the body of an ancestor has a with-clause of the main unit or on
1606 -- one of its children. In both cases the body in question has a with-
1607 -- clause on the main unit, and must be excluded from the traversal. In
1608 -- some convoluted cases this may lead to a CodePeer error because the
1609 -- spec of a subprogram declared in an instance within the parent will
1610 -- not be seen in the main unit.
1612 function Depends_On_Main
(CU
: Node_Id
) return Boolean;
1613 -- The body of a unit that is withed by the spec of the main unit may in
1614 -- turn have a with_clause on that spec. In that case do not traverse
1615 -- the body, to prevent loops. It can also happen that the main body has
1616 -- a with_clause on a child, which of course has an implicit with on its
1617 -- parent. It's OK to traverse the child body if the main spec has been
1618 -- processed, otherwise we also have a circularity to avoid.
1620 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
);
1621 -- Calls Action, with some validity checks
1623 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
);
1624 -- Calls Do_Action, first on the units with'ed by this one, then on
1625 -- this unit. If it's an instance body, do the spec first. If it is
1626 -- an instance spec, do the body last.
1628 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
);
1629 -- Apply Do_Unit_And_Dependents to a unit in a context clause
1631 procedure Process_Bodies_In_Context
(Comp
: Node_Id
);
1632 -- The main unit and its spec may depend on bodies that contain generics
1633 -- that are instantiated in them. Iterate through the corresponding
1634 -- contexts before processing main (spec/body) itself, to process bodies
1635 -- that may be present, together with their context. The spec of main
1636 -- is processed wherever it appears in the list of units, while the body
1637 -- is processed as the last unit in the list.
1639 ---------------------
1640 -- Depends_On_Main --
1641 ---------------------
1643 function Depends_On_Main
(CU
: Node_Id
) return Boolean is
1645 MCU
: constant Node_Id
:= Unit
(Main_CU
);
1648 CL
:= First
(Context_Items
(CU
));
1650 -- Problem does not arise with main subprograms
1653 not Nkind_In
(MCU
, N_Package_Body
, N_Package_Declaration
)
1658 while Present
(CL
) loop
1659 if Nkind
(CL
) = N_With_Clause
1660 and then Library_Unit
(CL
) = Main_CU
1661 and then not Done
(Get_Cunit_Unit_Number
(Library_Unit
(CL
)))
1670 end Depends_On_Main
;
1676 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
) is
1678 -- This calls Action at the end. All the preceding code is just
1679 -- assertions and debugging output.
1681 pragma Assert
(No
(CU
) or else Nkind
(CU
) = N_Compilation_Unit
);
1683 case Nkind
(Item
) is
1684 when N_Generic_Subprogram_Declaration |
1685 N_Generic_Package_Declaration |
1686 N_Package_Declaration |
1687 N_Subprogram_Declaration |
1688 N_Subprogram_Renaming_Declaration |
1689 N_Package_Renaming_Declaration |
1690 N_Generic_Function_Renaming_Declaration |
1691 N_Generic_Package_Renaming_Declaration |
1692 N_Generic_Procedure_Renaming_Declaration
=>
1698 when N_Package_Body
=>
1700 -- Package bodies are processed separately if the main unit
1705 when N_Subprogram_Body
=>
1707 -- A subprogram body must be the main unit
1709 pragma Assert
(Acts_As_Spec
(CU
)
1710 or else CU
= Cunit
(Main_Unit
));
1713 when N_Function_Instantiation |
1714 N_Procedure_Instantiation |
1715 N_Package_Instantiation
=>
1717 -- Can only happen if some generic body (needed for gnat2scil
1718 -- traversal, but not by GNAT) is not available, ignore.
1722 -- All other cases cannot happen
1725 pragma Assert
(False, "subunit");
1729 pragma Assert
(False);
1733 if Present
(CU
) then
1734 pragma Assert
(Item
/= Stand
.Standard_Package_Node
);
1735 pragma Assert
(Item
= Unit
(CU
));
1738 Unit_Num
: constant Unit_Number_Type
:=
1739 Get_Cunit_Unit_Number
(CU
);
1741 procedure Assert_Done
(Withed_Unit
: Node_Id
);
1742 -- Assert Withed_Unit is already Done, unless it's a body. It
1743 -- might seem strange for a with_clause to refer to a body, but
1744 -- this happens in the case of a generic instantiation, which
1745 -- gets transformed into the instance body (and the instance
1746 -- spec is also created). With clauses pointing to the
1747 -- instantiation end up pointing to the instance body.
1753 procedure Assert_Done
(Withed_Unit
: Node_Id
) is
1755 if not Done
(Get_Cunit_Unit_Number
(Withed_Unit
)) then
1757 (Unit
(Withed_Unit
),
1758 N_Generic_Package_Declaration
,
1760 N_Package_Renaming_Declaration
,
1764 (Unit_Name
(Get_Cunit_Unit_Number
(Withed_Unit
)));
1765 Write_Str
(" not yet walked!");
1767 if Get_Cunit_Unit_Number
(Withed_Unit
) = Unit_Num
then
1768 Write_Str
(" (self-ref)");
1773 pragma Assert
(False);
1778 procedure Assert_Withed_Units_Done
is
1779 new Walk_Withs
(Assert_Done
);
1782 if Debug_Unit_Walk
then
1783 Write_Unit_Info
(Unit_Num
, Item
, Withs
=> True);
1786 -- Main unit should come last, except in the case where we
1787 -- skipped System_Aux_Id, in which case we missed the things it
1788 -- depends on, and in the case of parent bodies if present.
1791 (not Done
(Main_Unit
)
1792 or else Present
(System_Aux_Id
)
1793 or else Nkind
(Item
) = N_Package_Body
);
1795 -- We shouldn't do the same thing twice
1797 pragma Assert
(not Done
(Unit_Num
));
1799 -- Everything we depend upon should already be done
1802 (Assert_Withed_Units_Done
(CU
, Include_Limited
=> False));
1806 -- Must be Standard, which has no entry in the units table
1808 pragma Assert
(Item
= Stand
.Standard_Package_Node
);
1810 if Debug_Unit_Walk
then
1811 Write_Line
("Standard");
1818 --------------------
1819 -- Do_Withed_Unit --
1820 --------------------
1822 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
) is
1824 Do_Unit_And_Dependents
(Withed_Unit
, Unit
(Withed_Unit
));
1826 -- If the unit in the with_clause is a generic instance, the clause
1827 -- now denotes the instance body. Traverse the corresponding spec
1828 -- because there may be no other dependence that will force the
1829 -- traversal of its own context.
1831 if Nkind
(Unit
(Withed_Unit
)) = N_Package_Body
1832 and then Is_Generic_Instance
1833 (Defining_Entity
(Unit
(Library_Unit
(Withed_Unit
))))
1835 Do_Withed_Unit
(Library_Unit
(Withed_Unit
));
1839 ----------------------------
1840 -- Do_Unit_And_Dependents --
1841 ----------------------------
1843 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
) is
1844 Unit_Num
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(CU
);
1846 Body_U
: Unit_Number_Type
;
1847 Parent_CU
: Node_Id
;
1849 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
1852 if not Seen
(Unit_Num
) then
1854 -- Process the with clauses
1856 Do_Withed_Units
(CU
, Include_Limited
=> False);
1858 -- Process the unit if it is a spec or the main unit, if it
1859 -- has no previous spec or we have done all other units.
1861 if not Nkind_In
(Item
, N_Package_Body
, N_Subprogram_Body
)
1862 or else Acts_As_Spec
(CU
)
1864 if CU
= Cunit
(Main_Unit
)
1865 and then not Do_Main
1867 Seen
(Unit_Num
) := False;
1870 Seen
(Unit_Num
) := True;
1872 if CU
= Library_Unit
(Main_CU
) then
1873 Process_Bodies_In_Context
(CU
);
1875 -- If main is a child unit, examine parent unit contexts
1876 -- to see if they include instantiated units. Also, if
1877 -- the parent itself is an instance, process its body
1878 -- because it may contain subprograms that are called
1879 -- in the main unit.
1881 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
1882 Child
:= Cunit_Entity
(Main_Unit
);
1883 while Is_Child_Unit
(Child
) loop
1886 (Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
1887 Process_Bodies_In_Context
(Parent_CU
);
1889 if Nkind
(Unit
(Parent_CU
)) = N_Package_Body
1891 Nkind
(Original_Node
(Unit
(Parent_CU
)))
1892 = N_Package_Instantiation
1894 not Seen
(Get_Cunit_Unit_Number
(Parent_CU
))
1896 Body_U
:= Get_Cunit_Unit_Number
(Parent_CU
);
1897 Seen
(Body_U
) := True;
1898 Do_Action
(Parent_CU
, Unit
(Parent_CU
));
1899 Done
(Body_U
) := True;
1902 Child
:= Scope
(Child
);
1907 Do_Action
(CU
, Item
);
1908 Done
(Unit_Num
) := True;
1912 end Do_Unit_And_Dependents
;
1914 -------------------------------
1915 -- Process_Bodies_In_Context --
1916 -------------------------------
1918 procedure Process_Bodies_In_Context
(Comp
: Node_Id
) is
1920 Body_U
: Unit_Number_Type
;
1924 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
1926 -- Start of processing for Process_Bodies_In_Context
1929 Clause
:= First
(Context_Items
(Comp
));
1930 while Present
(Clause
) loop
1931 if Nkind
(Clause
) = N_With_Clause
then
1932 Spec
:= Library_Unit
(Clause
);
1933 Body_CU
:= Library_Unit
(Spec
);
1935 -- If we are processing the spec of the main unit, load bodies
1936 -- only if the with_clause indicates that it forced the loading
1937 -- of the body for a generic instantiation. Note that bodies of
1938 -- parents that are instances have been loaded already.
1940 if Present
(Body_CU
)
1941 and then Body_CU
/= Cunit
(Main_Unit
)
1942 and then Nkind
(Unit
(Body_CU
)) /= N_Subprogram_Body
1943 and then (Nkind
(Unit
(Comp
)) /= N_Package_Declaration
1944 or else Present
(Withed_Body
(Clause
)))
1946 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
1948 if not Seen
(Body_U
)
1949 and then not Depends_On_Main
(Body_CU
)
1951 Seen
(Body_U
) := True;
1952 Do_Withed_Units
(Body_CU
, Include_Limited
=> False);
1953 Do_Action
(Body_CU
, Unit
(Body_CU
));
1954 Done
(Body_U
) := True;
1961 end Process_Bodies_In_Context
;
1963 -- Local Declarations
1967 -- Start of processing for Walk_Library_Items
1970 if Debug_Unit_Walk
then
1971 Write_Line
("Walk_Library_Items:");
1975 -- Do Standard first, then walk the Comp_Unit_List
1977 Do_Action
(Empty
, Standard_Package_Node
);
1979 -- First place the context of all instance bodies on the corresponding
1980 -- spec, because it may be needed to analyze the code at the place of
1981 -- the instantiation.
1983 Cur
:= First_Elmt
(Comp_Unit_List
);
1984 while Present
(Cur
) loop
1986 CU
: constant Node_Id
:= Node
(Cur
);
1987 N
: constant Node_Id
:= Unit
(CU
);
1990 if Nkind
(N
) = N_Package_Body
1991 and then Is_Generic_Instance
(Defining_Entity
(N
))
1994 (Context_Items
(CU
), Context_Items
(Library_Unit
(CU
)));
2001 -- Now traverse compilation units (specs) in order
2003 Cur
:= First_Elmt
(Comp_Unit_List
);
2004 while Present
(Cur
) loop
2006 CU
: constant Node_Id
:= Node
(Cur
);
2007 N
: constant Node_Id
:= Unit
(CU
);
2011 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2015 -- If it is a subprogram body, process it if it has no
2018 -- If it's a package body, ignore it, unless it is a body
2019 -- created for an instance that is the main unit. In the case
2020 -- of subprograms, the body is the wrapper package. In case of
2021 -- a package, the original file carries the body, and the spec
2022 -- appears as a later entry in the units list.
2024 -- Otherwise bodies appear in the list only because of inlining
2025 -- or instantiations, and they are processed only if relevant.
2026 -- The flag Withed_Body on a context clause indicates that a
2027 -- unit contains an instantiation that may be needed later,
2028 -- and therefore the body that contains the generic body (and
2029 -- its context) must be traversed immediately after the
2030 -- corresponding spec (see Do_Unit_And_Dependents).
2032 -- The main unit itself is processed separately after all other
2033 -- specs, and relevant bodies are examined in Process_Main.
2035 when N_Subprogram_Body
=>
2036 if Acts_As_Spec
(N
) then
2037 Do_Unit_And_Dependents
(CU
, N
);
2040 when N_Package_Body
=>
2042 and then Nkind
(Original_Node
(Unit
(Main_CU
))) in
2043 N_Generic_Instantiation
2044 and then Present
(Library_Unit
(Main_CU
))
2046 Do_Unit_And_Dependents
2047 (Library_Unit
(Main_CU
),
2048 Unit
(Library_Unit
(Main_CU
)));
2051 -- It's a spec, process it, and the units it depends on,
2052 -- unless it is a descendent of the main unit. This can
2053 -- happen when the body of a parent depends on some other
2057 Par
:= Scope
(Defining_Entity
(Unit
(CU
)));
2059 if Is_Child_Unit
(Defining_Entity
(Unit
(CU
))) then
2061 and then Par
/= Standard_Standard
2062 and then Par
/= Cunit_Entity
(Main_Unit
)
2068 if Par
/= Cunit_Entity
(Main_Unit
) then
2069 Do_Unit_And_Dependents
(CU
, N
);
2077 -- Now process package bodies on which main depends, followed by bodies
2078 -- of parents, if present, and finally main itself.
2080 if not Done
(Main_Unit
) then
2083 Process_Main
: declare
2084 Parent_CU
: Node_Id
;
2086 Body_U
: Unit_Number_Type
;
2089 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean;
2090 -- If the main unit has subunits, their context may include
2091 -- bodies that are needed in the body of main. We must examine
2092 -- the context of the subunits, which are otherwise not made
2093 -- explicit in the main unit.
2095 ------------------------
2096 -- Is_Subunit_Of_Main --
2097 ------------------------
2099 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean is
2105 Lib
:= Library_Unit
(U
);
2106 return Nkind
(Unit
(U
)) = N_Subunit
2108 (Lib
= Cunit
(Main_Unit
)
2109 or else Is_Subunit_Of_Main
(Lib
));
2111 end Is_Subunit_Of_Main
;
2113 -- Start of processing for Process_Main
2116 Process_Bodies_In_Context
(Main_CU
);
2118 for Unit_Num
in Done
'Range loop
2119 if Is_Subunit_Of_Main
(Cunit
(Unit_Num
)) then
2120 Process_Bodies_In_Context
(Cunit
(Unit_Num
));
2124 -- If the main unit is a child unit, parent bodies may be present
2125 -- because they export instances or inlined subprograms. Check for
2126 -- presence of these, which are not present in context clauses.
2127 -- Note that if the parents are instances, their bodies have been
2128 -- processed before the main spec, because they may be needed
2129 -- therein, so the following loop only affects non-instances.
2131 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
2132 Child
:= Cunit_Entity
(Main_Unit
);
2133 while Is_Child_Unit
(Child
) loop
2135 Cunit
(Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
2136 Body_CU
:= Library_Unit
(Parent_CU
);
2138 if Present
(Body_CU
)
2139 and then not Seen
(Get_Cunit_Unit_Number
(Body_CU
))
2140 and then not Depends_On_Main
(Body_CU
)
2142 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
2143 Seen
(Body_U
) := True;
2144 Do_Action
(Body_CU
, Unit
(Body_CU
));
2145 Done
(Body_U
) := True;
2148 Child
:= Scope
(Child
);
2152 Do_Action
(Main_CU
, Unit
(Main_CU
));
2153 Done
(Main_Unit
) := True;
2157 if Debug_Unit_Walk
then
2158 if Done
/= (Done
'Range => True) then
2160 Write_Line
("Ignored units:");
2164 for Unit_Num
in Done
'Range loop
2165 if not Done
(Unit_Num
) then
2167 (Unit_Num
, Unit
(Cunit
(Unit_Num
)), Withs
=> True);
2175 pragma Assert
(Done
(Main_Unit
));
2177 if Debug_Unit_Walk
then
2179 Write_Line
("end Walk_Library_Items.");
2181 end Walk_Library_Items
;
2187 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean) is
2188 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2189 pragma Assert
(Nkind
(Unit
(CU
)) /= N_Subunit
);
2191 procedure Walk_Immediate
is new Walk_Withs_Immediate
(Action
);
2194 -- First walk the withs immediately on the library item
2196 Walk_Immediate
(CU
, Include_Limited
);
2198 -- For a body, we must also check for any subunits which belong to it
2199 -- and which have context clauses of their own, since these with'ed
2200 -- units are part of its own dependencies.
2202 if Nkind
(Unit
(CU
)) in N_Unit_Body
then
2203 for S
in Main_Unit
.. Last_Unit
loop
2205 -- We are only interested in subunits. For preproc. data and def.
2206 -- files, Cunit is Empty, so we need to test that first.
2208 if Cunit
(S
) /= Empty
2209 and then Nkind
(Unit
(Cunit
(S
))) = N_Subunit
2215 Pnode
:= Library_Unit
(Cunit
(S
));
2217 -- In -gnatc mode, the errors in the subunits will not have
2218 -- been recorded, but the analysis of the subunit may have
2219 -- failed, so just quit.
2225 -- Find ultimate parent of the subunit
2227 while Nkind
(Unit
(Pnode
)) = N_Subunit
loop
2228 Pnode
:= Library_Unit
(Pnode
);
2231 -- See if it belongs to current unit, and if so, include its
2232 -- with_clauses. Do not process main unit prematurely.
2234 if Pnode
= CU
and then CU
/= Cunit
(Main_Unit
) then
2235 Walk_Immediate
(Cunit
(S
), Include_Limited
);
2243 --------------------------
2244 -- Walk_Withs_Immediate --
2245 --------------------------
2247 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean) is
2248 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2250 Context_Item
: Node_Id
;
2255 Context_Item
:= First
(Context_Items
(CU
));
2256 while Present
(Context_Item
) loop
2257 if Nkind
(Context_Item
) = N_With_Clause
2258 and then (Include_Limited
2259 or else not Limited_Present
(Context_Item
))
2261 Lib_Unit
:= Library_Unit
(Context_Item
);
2264 -- If the context item indicates that a package body is needed
2265 -- because of an instantiation in CU, traverse the body now, even
2266 -- if CU is not related to the main unit. If the generic itself
2267 -- appears in a package body, the context item is this body, and
2268 -- it already appears in the traversal order, so we only need to
2269 -- examine the case of a context item being a package declaration.
2271 if Present
(Withed_Body
(Context_Item
))
2272 and then Nkind
(Unit
(Lib_Unit
)) = N_Package_Declaration
2273 and then Present
(Corresponding_Body
(Unit
(Lib_Unit
)))
2277 (Unit_Declaration_Node
2278 (Corresponding_Body
(Unit
(Lib_Unit
))));
2280 -- A body may have an implicit with on its own spec, in which
2281 -- case we must ignore this context item to prevent looping.
2283 if Unit
(CU
) /= Unit
(Body_CU
) then
2289 Context_Item
:= Next
(Context_Item
);
2291 end Walk_Withs_Immediate
;
2293 ---------------------
2294 -- Write_Unit_Info --
2295 ---------------------
2297 procedure Write_Unit_Info
2298 (Unit_Num
: Unit_Number_Type
;
2300 Prefix
: String := "";
2301 Withs
: Boolean := False)
2305 Write_Unit_Name
(Unit_Name
(Unit_Num
));
2306 Write_Str
(", unit ");
2307 Write_Int
(Int
(Unit_Num
));
2309 Write_Int
(Int
(Item
));
2311 Write_Str
(Node_Kind
'Image (Nkind
(Item
)));
2313 if Item
/= Original_Node
(Item
) then
2314 Write_Str
(", orig = ");
2315 Write_Int
(Int
(Original_Node
(Item
)));
2317 Write_Str
(Node_Kind
'Image (Nkind
(Original_Node
(Item
))));
2322 -- Skip the rest if we're not supposed to print the withs
2329 Context_Item
: Node_Id
;
2332 Context_Item
:= First
(Context_Items
(Cunit
(Unit_Num
)));
2333 while Present
(Context_Item
)
2334 and then (Nkind
(Context_Item
) /= N_With_Clause
2335 or else Limited_Present
(Context_Item
))
2337 Context_Item
:= Next
(Context_Item
);
2340 if Present
(Context_Item
) then
2342 Write_Line
("withs:");
2345 while Present
(Context_Item
) loop
2346 if Nkind
(Context_Item
) = N_With_Clause
2347 and then not Limited_Present
(Context_Item
)
2349 pragma Assert
(Present
(Library_Unit
(Context_Item
)));
2352 (Get_Cunit_Unit_Number
(Library_Unit
(Context_Item
))));
2354 if Implicit_With
(Context_Item
) then
2355 Write_Str
(" -- implicit");
2361 Context_Item
:= Next
(Context_Item
);
2365 Write_Line
("end withs");
2369 end Write_Unit_Info
;