1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Debug; use Debug;
28 with Debug_A; use Debug_A;
29 with Elists; use Elists;
30 with Expander; use Expander;
31 with Fname; use Fname;
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
98 GM : constant Ghost_Mode_Type := Ghost_Mode;
99 -- Save the current Ghost mode in effect in case the construct sets a
103 Debug_A_Entry ("analyzing ", N);
105 -- Immediate return if already analyzed
108 Debug_A_Exit ("analyzing ", N, " (done, analyzed already)");
112 -- Otherwise processing depends on the node kind
115 when N_Abort_Statement =>
116 Analyze_Abort_Statement (N);
118 when N_Abstract_Subprogram_Declaration =>
119 Analyze_Abstract_Subprogram_Declaration (N);
121 when N_Accept_Alternative =>
122 Analyze_Accept_Alternative (N);
124 when N_Accept_Statement =>
125 Analyze_Accept_Statement (N);
128 Analyze_Aggregate (N);
131 Analyze_Allocator (N);
134 Analyze_Short_Circuit (N);
136 when N_Assignment_Statement =>
137 Analyze_Assignment (N);
139 when N_Asynchronous_Select =>
140 Analyze_Asynchronous_Select (N);
143 Analyze_At_Clause (N);
145 when N_Attribute_Reference =>
146 Analyze_Attribute (N);
148 when N_Attribute_Definition_Clause =>
149 Analyze_Attribute_Definition_Clause (N);
151 when N_Block_Statement =>
152 Analyze_Block_Statement (N);
154 when N_Case_Expression =>
155 Analyze_Case_Expression (N);
157 when N_Case_Statement =>
158 Analyze_Case_Statement (N);
160 when N_Character_Literal =>
161 Analyze_Character_Literal (N);
163 when N_Code_Statement =>
164 Analyze_Code_Statement (N);
166 when N_Compilation_Unit =>
167 Analyze_Compilation_Unit (N);
169 when N_Component_Declaration =>
170 Analyze_Component_Declaration (N);
172 when N_Compound_Statement =>
173 Analyze_Compound_Statement (N);
175 when N_Conditional_Entry_Call =>
176 Analyze_Conditional_Entry_Call (N);
178 when N_Delay_Alternative =>
179 Analyze_Delay_Alternative (N);
181 when N_Delay_Relative_Statement =>
182 Analyze_Delay_Relative (N);
184 when N_Delay_Until_Statement =>
185 Analyze_Delay_Until (N);
188 Analyze_Entry_Body (N);
190 when N_Entry_Body_Formal_Part =>
191 Analyze_Entry_Body_Formal_Part (N);
193 when N_Entry_Call_Alternative =>
194 Analyze_Entry_Call_Alternative (N);
196 when N_Entry_Declaration =>
197 Analyze_Entry_Declaration (N);
199 when N_Entry_Index_Specification =>
200 Analyze_Entry_Index_Specification (N);
202 when N_Enumeration_Representation_Clause =>
203 Analyze_Enumeration_Representation_Clause (N);
205 when N_Exception_Declaration =>
206 Analyze_Exception_Declaration (N);
208 when N_Exception_Renaming_Declaration =>
209 Analyze_Exception_Renaming (N);
211 when N_Exit_Statement =>
212 Analyze_Exit_Statement (N);
214 when N_Expanded_Name =>
215 Analyze_Expanded_Name (N);
217 when N_Explicit_Dereference =>
218 Analyze_Explicit_Dereference (N);
220 when N_Expression_Function =>
221 Analyze_Expression_Function (N);
223 when N_Expression_With_Actions =>
224 Analyze_Expression_With_Actions (N);
226 when N_Extended_Return_Statement =>
227 Analyze_Extended_Return_Statement (N);
229 when N_Extension_Aggregate =>
230 Analyze_Aggregate (N);
232 when N_Formal_Object_Declaration =>
233 Analyze_Formal_Object_Declaration (N);
235 when N_Formal_Package_Declaration =>
236 Analyze_Formal_Package_Declaration (N);
238 when N_Formal_Subprogram_Declaration =>
239 Analyze_Formal_Subprogram_Declaration (N);
241 when N_Formal_Type_Declaration =>
242 Analyze_Formal_Type_Declaration (N);
244 when N_Free_Statement =>
245 Analyze_Free_Statement (N);
247 when N_Freeze_Entity =>
248 Analyze_Freeze_Entity (N);
250 when N_Freeze_Generic_Entity =>
251 Analyze_Freeze_Generic_Entity (N);
253 when N_Full_Type_Declaration =>
254 Analyze_Full_Type_Declaration (N);
256 when N_Function_Call =>
257 Analyze_Function_Call (N);
259 when N_Function_Instantiation =>
260 Analyze_Function_Instantiation (N);
262 when N_Generic_Function_Renaming_Declaration =>
263 Analyze_Generic_Function_Renaming (N);
265 when N_Generic_Package_Declaration =>
266 Analyze_Generic_Package_Declaration (N);
268 when N_Generic_Package_Renaming_Declaration =>
269 Analyze_Generic_Package_Renaming (N);
271 when N_Generic_Procedure_Renaming_Declaration =>
272 Analyze_Generic_Procedure_Renaming (N);
274 when N_Generic_Subprogram_Declaration =>
275 Analyze_Generic_Subprogram_Declaration (N);
277 when N_Goto_Statement =>
278 Analyze_Goto_Statement (N);
280 when N_Handled_Sequence_Of_Statements =>
281 Analyze_Handled_Statements (N);
284 Analyze_Identifier (N);
286 when N_If_Expression =>
287 Analyze_If_Expression (N);
289 when N_If_Statement =>
290 Analyze_If_Statement (N);
292 when N_Implicit_Label_Declaration =>
293 Analyze_Implicit_Label_Declaration (N);
296 Analyze_Membership_Op (N);
298 when N_Incomplete_Type_Declaration =>
299 Analyze_Incomplete_Type_Decl (N);
301 when N_Indexed_Component =>
302 Analyze_Indexed_Component_Form (N);
304 when N_Integer_Literal =>
305 Analyze_Integer_Literal (N);
307 when N_Iterator_Specification =>
308 Analyze_Iterator_Specification (N);
310 when N_Itype_Reference =>
311 Analyze_Itype_Reference (N);
316 when N_Loop_Parameter_Specification =>
317 Analyze_Loop_Parameter_Specification (N);
319 when N_Loop_Statement =>
320 Analyze_Loop_Statement (N);
323 Analyze_Membership_Op (N);
328 when N_Null_Statement =>
329 Analyze_Null_Statement (N);
331 when N_Number_Declaration =>
332 Analyze_Number_Declaration (N);
334 when N_Object_Declaration =>
335 Analyze_Object_Declaration (N);
337 when N_Object_Renaming_Declaration =>
338 Analyze_Object_Renaming (N);
340 when N_Operator_Symbol =>
341 Analyze_Operator_Symbol (N);
344 Analyze_Unary_Op (N);
347 Analyze_Arithmetic_Op (N);
350 Analyze_Logical_Op (N);
353 Analyze_Concatenation (N);
356 Analyze_Arithmetic_Op (N);
359 Analyze_Equality_Op (N);
362 Analyze_Arithmetic_Op (N);
365 Analyze_Comparison_Op (N);
368 Analyze_Comparison_Op (N);
371 Analyze_Comparison_Op (N);
374 Analyze_Comparison_Op (N);
377 Analyze_Unary_Op (N);
382 when N_Op_Multiply =>
383 Analyze_Arithmetic_Op (N);
386 Analyze_Equality_Op (N);
389 Analyze_Negation (N);
392 Analyze_Logical_Op (N);
395 Analyze_Unary_Op (N);
398 Analyze_Arithmetic_Op (N);
400 when N_Op_Rotate_Left =>
401 Analyze_Arithmetic_Op (N);
403 when N_Op_Rotate_Right =>
404 Analyze_Arithmetic_Op (N);
406 when N_Op_Shift_Left =>
407 Analyze_Arithmetic_Op (N);
409 when N_Op_Shift_Right =>
410 Analyze_Arithmetic_Op (N);
412 when N_Op_Shift_Right_Arithmetic =>
413 Analyze_Arithmetic_Op (N);
415 when N_Op_Subtract =>
416 Analyze_Arithmetic_Op (N);
419 Analyze_Logical_Op (N);
422 Analyze_Short_Circuit (N);
424 when N_Others_Choice =>
425 Analyze_Others_Choice (N);
427 when N_Package_Body =>
428 Analyze_Package_Body (N);
430 when N_Package_Body_Stub =>
431 Analyze_Package_Body_Stub (N);
433 when N_Package_Declaration =>
434 Analyze_Package_Declaration (N);
436 when N_Package_Instantiation =>
437 Analyze_Package_Instantiation (N);
439 when N_Package_Renaming_Declaration =>
440 Analyze_Package_Renaming (N);
442 when N_Package_Specification =>
443 Analyze_Package_Specification (N);
445 when N_Parameter_Association =>
446 Analyze_Parameter_Association (N);
451 when N_Private_Extension_Declaration =>
452 Analyze_Private_Extension_Declaration (N);
454 when N_Private_Type_Declaration =>
455 Analyze_Private_Type_Declaration (N);
457 when N_Procedure_Call_Statement =>
458 Analyze_Procedure_Call (N);
460 when N_Procedure_Instantiation =>
461 Analyze_Procedure_Instantiation (N);
463 when N_Protected_Body =>
464 Analyze_Protected_Body (N);
466 when N_Protected_Body_Stub =>
467 Analyze_Protected_Body_Stub (N);
469 when N_Protected_Definition =>
470 Analyze_Protected_Definition (N);
472 when N_Protected_Type_Declaration =>
473 Analyze_Protected_Type_Declaration (N);
475 when N_Qualified_Expression =>
476 Analyze_Qualified_Expression (N);
478 when N_Quantified_Expression =>
479 Analyze_Quantified_Expression (N);
481 when N_Raise_Expression =>
482 Analyze_Raise_Expression (N);
484 when N_Raise_Statement =>
485 Analyze_Raise_Statement (N);
487 when N_Raise_xxx_Error =>
488 Analyze_Raise_xxx_Error (N);
493 when N_Range_Constraint =>
494 Analyze_Range (Range_Expression (N));
496 when N_Real_Literal =>
497 Analyze_Real_Literal (N);
499 when N_Record_Representation_Clause =>
500 Analyze_Record_Representation_Clause (N);
503 Analyze_Reference (N);
505 when N_Requeue_Statement =>
508 when N_Simple_Return_Statement =>
509 Analyze_Simple_Return_Statement (N);
511 when N_Selected_Component =>
512 Find_Selected_Component (N);
513 -- ??? why not Analyze_Selected_Component, needs comments
515 when N_Selective_Accept =>
516 Analyze_Selective_Accept (N);
518 when N_Single_Protected_Declaration =>
519 Analyze_Single_Protected_Declaration (N);
521 when N_Single_Task_Declaration =>
522 Analyze_Single_Task_Declaration (N);
527 when N_String_Literal =>
528 Analyze_String_Literal (N);
530 when N_Subprogram_Body =>
531 Analyze_Subprogram_Body (N);
533 when N_Subprogram_Body_Stub =>
534 Analyze_Subprogram_Body_Stub (N);
536 when N_Subprogram_Declaration =>
537 Analyze_Subprogram_Declaration (N);
539 when N_Subprogram_Renaming_Declaration =>
540 Analyze_Subprogram_Renaming (N);
542 when N_Subtype_Declaration =>
543 Analyze_Subtype_Declaration (N);
545 when N_Subtype_Indication =>
546 Analyze_Subtype_Indication (N);
552 Analyze_Task_Body (N);
554 when N_Task_Body_Stub =>
555 Analyze_Task_Body_Stub (N);
557 when N_Task_Definition =>
558 Analyze_Task_Definition (N);
560 when N_Task_Type_Declaration =>
561 Analyze_Task_Type_Declaration (N);
563 when N_Terminate_Alternative =>
564 Analyze_Terminate_Alternative (N);
566 when N_Timed_Entry_Call =>
567 Analyze_Timed_Entry_Call (N);
569 when N_Triggering_Alternative =>
570 Analyze_Triggering_Alternative (N);
572 when N_Type_Conversion =>
573 Analyze_Type_Conversion (N);
575 when N_Unchecked_Expression =>
576 Analyze_Unchecked_Expression (N);
578 when N_Unchecked_Type_Conversion =>
579 Analyze_Unchecked_Type_Conversion (N);
581 when N_Use_Package_Clause =>
582 Analyze_Use_Package (N);
584 when N_Use_Type_Clause =>
585 Analyze_Use_Type (N);
587 when N_Validate_Unchecked_Conversion =>
590 when N_Variant_Part =>
591 Analyze_Variant_Part (N);
593 when N_With_Clause =>
594 Analyze_With_Clause (N);
596 -- A call to analyze the Empty node is an error, but most likely it
597 -- is an error caused by an attempt to analyze a malformed piece of
598 -- tree caused by some other error, so if there have been any other
599 -- errors, we just ignore it, otherwise it is a real internal error
600 -- which we complain about.
602 -- We must also consider the case of call to a runtime function that
603 -- is not available in the configurable runtime.
606 pragma Assert (Serious_Errors_Detected /= 0
607 or else Configurable_Run_Time_Violations /= 0);
610 -- A call to analyze the error node is simply ignored, to avoid
611 -- causing cascaded errors (happens of course only in error cases)
616 -- Push/Pop nodes normally don't come through an analyze call. An
617 -- exception is the dummy ones bracketing a subprogram body. In any
618 -- case there is nothing to be done to analyze such nodes.
620 when N_Push_Pop_xxx_Label =>
623 -- SCIL nodes don't need analysis because they are decorated when
624 -- they are built. They are added to the tree by Insert_Actions and
625 -- the call to analyze them is generated when the full list is
628 when N_SCIL_Dispatch_Table_Tag_Init |
629 N_SCIL_Dispatching_Call |
630 N_SCIL_Membership_Test =>
633 -- For the remaining node types, we generate compiler abort, because
634 -- these nodes are always analyzed within the Sem_Chn routines and
635 -- there should never be a case of making a call to the main Analyze
636 -- routine for these node kinds. For example, an N_Access_Definition
637 -- node appears only in the context of a type declaration, and is
638 -- processed by the analyze routine for type declarations.
640 when N_Abortable_Part |
641 N_Access_Definition |
642 N_Access_Function_Definition |
643 N_Access_Procedure_Definition |
644 N_Access_To_Object_Definition |
645 N_Aspect_Specification |
646 N_Case_Expression_Alternative |
647 N_Case_Statement_Alternative |
648 N_Compilation_Unit_Aux |
649 N_Component_Association |
651 N_Component_Definition |
653 N_Constrained_Array_Definition |
655 N_Decimal_Fixed_Point_Definition |
656 N_Defining_Character_Literal |
657 N_Defining_Identifier |
658 N_Defining_Operator_Symbol |
659 N_Defining_Program_Unit_Name |
661 N_Derived_Type_Definition |
663 N_Digits_Constraint |
664 N_Discriminant_Association |
665 N_Discriminant_Specification |
667 N_Entry_Call_Statement |
668 N_Enumeration_Type_Definition |
669 N_Exception_Handler |
670 N_Floating_Point_Definition |
671 N_Formal_Decimal_Fixed_Point_Definition |
672 N_Formal_Derived_Type_Definition |
673 N_Formal_Discrete_Type_Definition |
674 N_Formal_Floating_Point_Definition |
675 N_Formal_Modular_Type_Definition |
676 N_Formal_Ordinary_Fixed_Point_Definition |
677 N_Formal_Private_Type_Definition |
678 N_Formal_Incomplete_Type_Definition |
679 N_Formal_Signed_Integer_Type_Definition |
680 N_Function_Specification |
681 N_Generic_Association |
682 N_Index_Or_Discriminant_Constraint |
685 N_Modular_Type_Definition |
686 N_Ordinary_Fixed_Point_Definition |
687 N_Parameter_Specification |
688 N_Pragma_Argument_Association |
689 N_Procedure_Specification |
690 N_Real_Range_Specification |
691 N_Record_Definition |
692 N_Signed_Integer_Type_Definition |
693 N_Unconstrained_Array_Definition |
700 Debug_A_Exit ("analyzing ", N, " (done)");
702 -- Now that we have analyzed the node, we call the expander to perform
703 -- possible expansion. We skip this for subexpressions, because we don't
704 -- have the type yet, and the expander will need to know the type before
705 -- it can do its job. For subexpression nodes, the call to the expander
706 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
707 -- which can appear in a statement context, and needs expanding now in
708 -- the case (distinguished by Etype, as documented in Sinfo).
710 -- The Analyzed flag is also set at this point for non-subexpression
711 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
712 -- since resolution and expansion have not yet been completed). Note
713 -- that for N_Raise_xxx_Error we have to distinguish the expression
714 -- case from the statement case.
716 if Nkind (N) not in N_Subexpr
717 or else (Nkind (N) in N_Raise_xxx_Error
718 and then Etype (N) = Standard_Void_Type)
723 -- Restore the original Ghost mode once analysis and expansion have
729 -- Version with check(s) suppressed
731 procedure Analyze (N : Node_Id; Suppress : Check_Id) is
733 if Suppress = All_Checks then
735 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
737 Scope_Suppress.Suppress := (others => True);
739 Scope_Suppress.Suppress := Svs;
742 elsif Suppress = Overflow_Check then
744 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
746 Scope_Suppress.Suppress (Suppress) := True;
748 Scope_Suppress.Suppress (Suppress) := Svg;
757 procedure Analyze_List (L : List_Id) is
762 while Present (Node) loop
768 -- Version with check(s) suppressed
770 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
772 if Suppress = All_Checks then
774 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
776 Scope_Suppress.Suppress := (others => True);
778 Scope_Suppress.Suppress := Svs;
783 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
785 Scope_Suppress.Suppress (Suppress) := True;
787 Scope_Suppress.Suppress (Suppress) := Svg;
792 --------------------------
793 -- Copy_Suppress_Status --
794 --------------------------
796 procedure Copy_Suppress_Status
802 pragma Warnings (Off, Found);
804 procedure Search_Stack
805 (Top : Suppress_Stack_Entry_Ptr;
806 Found : out Boolean);
807 -- Search given suppress stack for matching entry for entity. If found
808 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
809 -- entry for To onto the local suppress stack.
815 procedure Search_Stack
816 (Top : Suppress_Stack_Entry_Ptr;
819 Ptr : Suppress_Stack_Entry_Ptr;
823 while Ptr /= null loop
825 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
828 Set_Checks_May_Be_Suppressed (To, True);
829 Push_Local_Suppress_Stack_Entry
845 -- Start of processing for Copy_Suppress_Status
848 if not Checks_May_Be_Suppressed (From) then
852 -- First search the global entity suppress table for a matching entry.
853 -- We also search this in reverse order so that if there are multiple
854 -- pragmas for the same entity, the last one applies.
856 Search_Stack (Global_Suppress_Stack_Top, Found);
862 -- Now search the local entity suppress stack, we search this in
863 -- reverse order so that we get the innermost entry that applies to
864 -- this case if there are nested entries. Note that for the purpose
865 -- of this procedure we are ONLY looking for entries corresponding
866 -- to a two-argument Suppress, where the second argument matches From.
868 Search_Stack (Local_Suppress_Stack_Top, Found);
869 end Copy_Suppress_Status;
871 -------------------------
872 -- Enter_Generic_Scope --
873 -------------------------
875 procedure Enter_Generic_Scope (S : Entity_Id) is
877 if No (Outer_Generic_Scope) then
878 Outer_Generic_Scope := S;
880 end Enter_Generic_Scope;
882 ------------------------
883 -- Exit_Generic_Scope --
884 ------------------------
886 procedure Exit_Generic_Scope (S : Entity_Id) is
888 if S = Outer_Generic_Scope then
889 Outer_Generic_Scope := Empty;
891 end Exit_Generic_Scope;
893 -----------------------
894 -- Explicit_Suppress --
895 -----------------------
897 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
898 Ptr : Suppress_Stack_Entry_Ptr;
901 if not Checks_May_Be_Suppressed (E) then
905 Ptr := Global_Suppress_Stack_Top;
906 while Ptr /= null loop
908 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
918 end Explicit_Suppress;
920 -----------------------------
921 -- External_Ref_In_Generic --
922 -----------------------------
924 function External_Ref_In_Generic (E : Entity_Id) return Boolean is
928 -- Entity is global if defined outside of current outer_generic_scope:
929 -- Either the entity has a smaller depth that the outer generic, or it
930 -- is in a different compilation unit, or it is defined within a unit
931 -- in the same compilation, that is not within the outer_generic.
933 if No (Outer_Generic_Scope) then
936 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
937 or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
943 while Present (Scop) loop
944 if Scop = Outer_Generic_Scope then
946 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
949 Scop := Scope (Scop);
955 end External_Ref_In_Generic;
961 procedure Initialize is
962 Next : Suppress_Stack_Entry_Ptr;
964 procedure Free is new Unchecked_Deallocation
965 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
968 -- Free any global suppress stack entries from a previous invocation
969 -- of the compiler (in the normal case this loop does nothing).
971 while Suppress_Stack_Entries /= null loop
972 Next := Suppress_Stack_Entries.Next;
973 Free (Suppress_Stack_Entries);
974 Suppress_Stack_Entries := Next;
977 Local_Suppress_Stack_Top := null;
978 Global_Suppress_Stack_Top := null;
980 -- Clear scope stack, and reset global variables
983 Unloaded_Subunits := False;
986 ------------------------------
987 -- Insert_After_And_Analyze --
988 ------------------------------
990 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
996 -- If we are not at the end of the list, then the easiest
997 -- coding is simply to insert before our successor
999 if Present (Next (N)) then
1000 Insert_Before_And_Analyze (Next (N), M);
1002 -- Case of inserting at the end of the list
1005 -- Capture the Node_Id of the node to be inserted. This Node_Id
1006 -- will still be the same after the insert operation.
1009 Insert_After (N, M);
1011 -- Now just analyze from the inserted node to the end of
1012 -- the new list (note that this properly handles the case
1013 -- where any of the analyze calls result in the insertion of
1014 -- nodes after the analyzed node, expecting analysis).
1016 while Present (Node) loop
1018 Mark_Rewrite_Insertion (Node);
1023 end Insert_After_And_Analyze;
1025 -- Version with check(s) suppressed
1027 procedure Insert_After_And_Analyze
1030 Suppress : Check_Id)
1033 if Suppress = All_Checks then
1035 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1037 Scope_Suppress.Suppress := (others => True);
1038 Insert_After_And_Analyze (N, M);
1039 Scope_Suppress.Suppress := Svs;
1044 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1046 Scope_Suppress.Suppress (Suppress) := True;
1047 Insert_After_And_Analyze (N, M);
1048 Scope_Suppress.Suppress (Suppress) := Svg;
1051 end Insert_After_And_Analyze;
1053 -------------------------------
1054 -- Insert_Before_And_Analyze --
1055 -------------------------------
1057 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
1063 -- Capture the Node_Id of the first list node to be inserted.
1064 -- This will still be the first node after the insert operation,
1065 -- since Insert_List_After does not modify the Node_Id values.
1068 Insert_Before (N, M);
1070 -- The insertion does not change the Id's of any of the nodes in
1071 -- the list, and they are still linked, so we can simply loop from
1072 -- the original first node until we meet the node before which the
1073 -- insertion is occurring. Note that this properly handles the case
1074 -- where any of the analyzed nodes insert nodes after themselves,
1075 -- expecting them to get analyzed.
1077 while Node /= N loop
1079 Mark_Rewrite_Insertion (Node);
1083 end Insert_Before_And_Analyze;
1085 -- Version with check(s) suppressed
1087 procedure Insert_Before_And_Analyze
1090 Suppress : Check_Id)
1093 if Suppress = All_Checks then
1095 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1097 Scope_Suppress.Suppress := (others => True);
1098 Insert_Before_And_Analyze (N, M);
1099 Scope_Suppress.Suppress := Svs;
1104 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1106 Scope_Suppress.Suppress (Suppress) := True;
1107 Insert_Before_And_Analyze (N, M);
1108 Scope_Suppress.Suppress (Suppress) := Svg;
1111 end Insert_Before_And_Analyze;
1113 -----------------------------------
1114 -- Insert_List_After_And_Analyze --
1115 -----------------------------------
1117 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
1118 After : constant Node_Id := Next (N);
1122 if Is_Non_Empty_List (L) then
1124 -- Capture the Node_Id of the first list node to be inserted.
1125 -- This will still be the first node after the insert operation,
1126 -- since Insert_List_After does not modify the Node_Id values.
1129 Insert_List_After (N, L);
1131 -- Now just analyze from the original first node until we get to the
1132 -- successor of the original insertion point (which may be Empty if
1133 -- the insertion point was at the end of the list). Note that this
1134 -- properly handles the case where any of the analyze calls result in
1135 -- the insertion of nodes after the analyzed node (possibly calling
1136 -- this routine recursively).
1138 while Node /= After loop
1140 Mark_Rewrite_Insertion (Node);
1144 end Insert_List_After_And_Analyze;
1146 -- Version with check(s) suppressed
1148 procedure Insert_List_After_And_Analyze
1149 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1152 if Suppress = All_Checks then
1154 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1156 Scope_Suppress.Suppress := (others => True);
1157 Insert_List_After_And_Analyze (N, L);
1158 Scope_Suppress.Suppress := Svs;
1163 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1165 Scope_Suppress.Suppress (Suppress) := True;
1166 Insert_List_After_And_Analyze (N, L);
1167 Scope_Suppress.Suppress (Suppress) := Svg;
1170 end Insert_List_After_And_Analyze;
1172 ------------------------------------
1173 -- Insert_List_Before_And_Analyze --
1174 ------------------------------------
1176 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
1180 if Is_Non_Empty_List (L) then
1182 -- Capture the Node_Id of the first list node to be inserted. This
1183 -- will still be the first node after the insert operation, since
1184 -- Insert_List_After does not modify the Node_Id values.
1187 Insert_List_Before (N, L);
1189 -- The insertion does not change the Id's of any of the nodes in
1190 -- the list, and they are still linked, so we can simply loop from
1191 -- the original first node until we meet the node before which the
1192 -- insertion is occurring. Note that this properly handles the case
1193 -- where any of the analyzed nodes insert nodes after themselves,
1194 -- expecting them to get analyzed.
1196 while Node /= N loop
1198 Mark_Rewrite_Insertion (Node);
1202 end Insert_List_Before_And_Analyze;
1204 -- Version with check(s) suppressed
1206 procedure Insert_List_Before_And_Analyze
1207 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1210 if Suppress = All_Checks then
1212 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1214 Scope_Suppress.Suppress := (others => True);
1215 Insert_List_Before_And_Analyze (N, L);
1216 Scope_Suppress.Suppress := Svs;
1221 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1223 Scope_Suppress.Suppress (Suppress) := True;
1224 Insert_List_Before_And_Analyze (N, L);
1225 Scope_Suppress.Suppress (Suppress) := Svg;
1228 end Insert_List_Before_And_Analyze;
1236 Scope_Stack.Locked := True;
1237 Scope_Stack.Release;
1244 procedure Preanalyze (N : Node_Id) is
1245 Save_Full_Analysis : constant Boolean := Full_Analysis;
1248 Full_Analysis := False;
1249 Expander_Mode_Save_And_Set (False);
1253 Expander_Mode_Restore;
1254 Full_Analysis := Save_Full_Analysis;
1257 --------------------------------------
1258 -- Push_Global_Suppress_Stack_Entry --
1259 --------------------------------------
1261 procedure Push_Global_Suppress_Stack_Entry
1262 (Entity : Entity_Id;
1267 Global_Suppress_Stack_Top :=
1268 new Suppress_Stack_Entry'
1271 Suppress => Suppress,
1272 Prev => Global_Suppress_Stack_Top,
1273 Next => Suppress_Stack_Entries);
1274 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1276 end Push_Global_Suppress_Stack_Entry;
1278 -------------------------------------
1279 -- Push_Local_Suppress_Stack_Entry --
1280 -------------------------------------
1282 procedure Push_Local_Suppress_Stack_Entry
1283 (Entity : Entity_Id;
1288 Local_Suppress_Stack_Top :=
1289 new Suppress_Stack_Entry'
1292 Suppress => Suppress,
1293 Prev => Local_Suppress_Stack_Top,
1294 Next => Suppress_Stack_Entries);
1295 Suppress_Stack_Entries := Local_Suppress_Stack_Top;
1298 end Push_Local_Suppress_Stack_Entry;
1304 procedure Semantics (Comp_Unit : Node_Id) is
1305 procedure Do_Analyze;
1306 -- Perform the analysis of the compilation unit
1312 procedure Do_Analyze is
1313 GM : constant Ghost_Mode_Type := Ghost_Mode;
1314 -- Save the current Ghost mode in effect in case the compilation unit
1315 -- is withed from a unit with a different Ghost mode.
1320 List := Save_Scope_Stack;
1321 Push_Scope (Standard_Standard);
1323 -- Set up a clean environment before analyzing
1326 Outer_Generic_Scope := Empty;
1327 Scope_Suppress := Suppress_Options;
1329 (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
1331 (Scope_Stack.Last).Is_Active_Stack_Base := True;
1333 -- Now analyze the top level compilation unit node
1335 Analyze (Comp_Unit);
1337 -- Check for scope mismatch on exit from compilation
1339 pragma Assert (Current_Scope = Standard_Standard
1340 or else Comp_Unit = Cunit (Main_Unit));
1342 -- Then pop entry for Standard, and pop implicit types
1345 Restore_Scope_Stack (List);
1351 -- The following locations save the corresponding global flags and
1352 -- variables so that they can be restored on completion. This is needed
1353 -- so that calls to Rtsfind start with the proper default values for
1354 -- these variables, and also that such calls do not disturb the settings
1355 -- for units being analyzed at a higher level.
1357 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
1358 S_Full_Analysis : constant Boolean := Full_Analysis;
1359 S_GNAT_Mode : constant Boolean := GNAT_Mode;
1360 S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
1361 S_In_Assertion_Expr : constant Nat := In_Assertion_Expr;
1362 S_In_Default_Expr : constant Boolean := In_Default_Expr;
1363 S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
1364 S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
1365 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
1366 S_Style_Check : constant Boolean := Style_Check;
1368 Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
1370 Curunit : constant Unit_Number_Type := Get_Cunit_Unit_Number (Comp_Unit);
1371 -- New value of Current_Sem_Unit
1373 Generic_Main : constant Boolean :=
1374 Nkind (Unit (Cunit (Main_Unit))) in N_Generic_Declaration;
1375 -- If the main unit is generic, every compiled unit, including its
1376 -- context, is compiled with expansion disabled.
1378 Is_Main_Unit_Or_Main_Unit_Spec : constant Boolean :=
1381 (Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
1382 and then Library_Unit (Cunit (Main_Unit)) = Cunit (Curunit));
1383 -- Configuration flags have special settings when compiling a predefined
1384 -- file as a main unit. This applies to its spec as well.
1386 Ext_Main_Source_Unit : constant Boolean :=
1387 In_Extended_Main_Source_Unit (Comp_Unit);
1388 -- Determine if unit is in extended main source unit
1390 Save_Config_Switches : Config_Switches_Type;
1391 -- Variable used to save values of config switches while we analyze the
1392 -- new unit, to be restored on exit for proper recursive behavior.
1394 Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions;
1395 -- Used to save non-partition wide restrictions before processing new
1396 -- unit. All with'ed units are analyzed with config restrictions reset
1397 -- and we need to restore these saved values at the end.
1399 -- Start of processing for Semantics
1402 if Debug_Unit_Walk then
1403 if Already_Analyzed then
1404 Write_Str ("(done)");
1408 (Get_Cunit_Unit_Number (Comp_Unit),
1414 Compiler_State := Analyzing;
1415 Current_Sem_Unit := Curunit;
1417 -- Compile predefined units with GNAT_Mode set to True, to properly
1418 -- process the categorization stuff. However, do not set GNAT_Mode
1419 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1420 -- Sequential_IO) as this would prevent pragma Extend_System from being
1421 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1423 if Is_Predefined_File_Name
1424 (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
1429 -- For generic main, never do expansion
1431 if Generic_Main then
1432 Expander_Mode_Save_And_Set (False);
1437 Expander_Mode_Save_And_Set
1439 -- Turn on expansion if generating code
1441 (Operating_Mode = Generate_Code
1443 -- Or if special debug flag -gnatdx is set
1445 or else Debug_Flag_X
1447 -- Or if we are generating C code
1449 or else Generate_C_Code
1451 -- Or if in configuration run-time mode. We do this so we get
1452 -- error messages about missing entities in the run-time even
1453 -- if we are compiling in -gnatc (no code generation) mode.
1454 -- Similar processing applies to No_Run_Time_Mode. However,
1455 -- don't do this if debug flag -gnatd.Z is set or when we are
1456 -- compiling a separate unit (this is to handle a situation
1457 -- where this new processing causes trouble).
1459 or else ((Configurable_Run_Time_Mode or No_Run_Time_Mode)
1460 and not Debug_Flag_Dot_ZZ
1461 and Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit));
1464 Full_Analysis := True;
1465 Inside_A_Generic := False;
1466 In_Assertion_Expr := 0;
1467 In_Default_Expr := False;
1468 In_Spec_Expression := False;
1469 Set_Comes_From_Source_Default (False);
1471 -- Save current config switches and reset then appropriately
1473 Save_Opt_Config_Switches (Save_Config_Switches);
1474 Set_Opt_Config_Switches
1475 (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
1476 Is_Main_Unit_Or_Main_Unit_Spec);
1478 -- Save current non-partition-wide restrictions
1480 Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save;
1482 -- For unit in main extended unit, we reset the configuration values
1483 -- for the non-partition-wide restrictions. For other units reset them.
1485 if Ext_Main_Source_Unit then
1486 Restore_Config_Cunit_Boolean_Restrictions;
1488 Reset_Cunit_Boolean_Restrictions;
1491 -- Turn off style checks for unit that is not in the extended main
1492 -- source unit. This improves processing efficiency for such units
1493 -- (for which we don't want style checks anyway, and where they will
1494 -- get suppressed), and is definitely needed to stop some style checks
1495 -- from invading the run-time units (e.g. overriding checks).
1497 if not Ext_Main_Source_Unit then
1498 Style_Check := False;
1500 -- If this is part of the extended main source unit, set style check
1501 -- mode to match the style check mode of the main source unit itself.
1504 Style_Check := Style_Check_Main;
1507 -- Only do analysis of unit that has not already been analyzed
1509 if not Analyzed (Comp_Unit) then
1510 Initialize_Version (Current_Sem_Unit);
1512 -- Do analysis, and then append the compilation unit onto the
1513 -- Comp_Unit_List, if appropriate. This is done after analysis,
1514 -- so if this unit depends on some others, they have already been
1515 -- appended. We ignore bodies, except for the main unit itself, and
1516 -- for subprogram bodies that act as specs. We have also to guard
1517 -- against ill-formed subunits that have an improper context.
1521 if Present (Comp_Unit)
1522 and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
1523 and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body
1524 or else not Acts_As_Spec (Comp_Unit))
1525 and then not In_Extended_Main_Source_Unit (Comp_Unit)
1530 Append_New_Elmt (Comp_Unit, To => Comp_Unit_List);
1532 if Debug_Unit_Walk then
1533 Write_Str ("Appending ");
1535 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
1540 -- Save indication of dynamic elaboration checks for ALI file
1542 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
1544 -- Restore settings of saved switches to entry values
1546 Current_Sem_Unit := S_Current_Sem_Unit;
1547 Full_Analysis := S_Full_Analysis;
1548 Global_Discard_Names := S_Global_Dis_Names;
1549 GNAT_Mode := S_GNAT_Mode;
1550 In_Assertion_Expr := S_In_Assertion_Expr;
1551 In_Default_Expr := S_In_Default_Expr;
1552 In_Spec_Expression := S_In_Spec_Expr;
1553 Inside_A_Generic := S_Inside_A_Generic;
1554 Outer_Generic_Scope := S_Outer_Gen_Scope;
1555 Style_Check := S_Style_Check;
1557 Restore_Opt_Config_Switches (Save_Config_Switches);
1559 -- Deal with restore of restrictions
1561 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
1563 Expander_Mode_Restore;
1565 if Debug_Unit_Walk then
1568 if Already_Analyzed then
1569 Write_Str ("(done)");
1573 (Get_Cunit_Unit_Number (Comp_Unit),
1583 function ss (Index : Int) return Scope_Stack_Entry is
1585 return Scope_Stack.Table (Index);
1592 function sst return Scope_Stack_Entry is
1594 return ss (Scope_Stack.Last);
1597 ------------------------
1598 -- Walk_Library_Items --
1599 ------------------------
1601 procedure Walk_Library_Items is
1602 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
1603 pragma Pack (Unit_Number_Set);
1605 Main_CU : constant Node_Id := Cunit (Main_Unit);
1607 Seen, Done : Unit_Number_Set := (others => False);
1608 -- Seen (X) is True after we have seen unit X in the walk. This is used
1609 -- to prevent processing the same unit more than once. Done (X) is True
1610 -- after we have fully processed X, and is used only for debugging
1611 -- printouts and assertions.
1613 Do_Main : Boolean := False;
1614 -- Flag to delay processing the main body until after all other units.
1615 -- This is needed because the spec of the main unit may appear in the
1616 -- context of some other unit. We do not want this to force processing
1617 -- of the main body before all other units have been processed.
1619 -- Another circularity pattern occurs when the main unit is a child unit
1620 -- and the body of an ancestor has a with-clause of the main unit or on
1621 -- one of its children. In both cases the body in question has a with-
1622 -- clause on the main unit, and must be excluded from the traversal. In
1623 -- some convoluted cases this may lead to a CodePeer error because the
1624 -- spec of a subprogram declared in an instance within the parent will
1625 -- not be seen in the main unit.
1627 function Depends_On_Main (CU : Node_Id) return Boolean;
1628 -- The body of a unit that is withed by the spec of the main unit may in
1629 -- turn have a with_clause on that spec. In that case do not traverse
1630 -- the body, to prevent loops. It can also happen that the main body has
1631 -- a with_clause on a child, which of course has an implicit with on its
1632 -- parent. It's OK to traverse the child body if the main spec has been
1633 -- processed, otherwise we also have a circularity to avoid.
1635 procedure Do_Action (CU : Node_Id; Item : Node_Id);
1636 -- Calls Action, with some validity checks
1638 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id);
1639 -- Calls Do_Action, first on the units with'ed by this one, then on
1640 -- this unit. If it's an instance body, do the spec first. If it is
1641 -- an instance spec, do the body last.
1643 procedure Do_Withed_Unit (Withed_Unit : Node_Id);
1644 -- Apply Do_Unit_And_Dependents to a unit in a context clause
1646 procedure Process_Bodies_In_Context (Comp : Node_Id);
1647 -- The main unit and its spec may depend on bodies that contain generics
1648 -- that are instantiated in them. Iterate through the corresponding
1649 -- contexts before processing main (spec/body) itself, to process bodies
1650 -- that may be present, together with their context. The spec of main
1651 -- is processed wherever it appears in the list of units, while the body
1652 -- is processed as the last unit in the list.
1654 ---------------------
1655 -- Depends_On_Main --
1656 ---------------------
1658 function Depends_On_Main (CU : Node_Id) return Boolean is
1660 MCU : constant Node_Id := Unit (Main_CU);
1663 CL := First (Context_Items (CU));
1665 -- Problem does not arise with main subprograms
1668 not Nkind_In (MCU, N_Package_Body, N_Package_Declaration)
1673 while Present (CL) loop
1674 if Nkind (CL) = N_With_Clause
1675 and then Library_Unit (CL) = Main_CU
1676 and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL)))
1685 end Depends_On_Main;
1691 procedure Do_Action (CU : Node_Id; Item : Node_Id) is
1693 -- This calls Action at the end. All the preceding code is just
1694 -- assertions and debugging output.
1696 pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
1698 case Nkind (Item) is
1699 when N_Generic_Subprogram_Declaration |
1700 N_Generic_Package_Declaration |
1701 N_Package_Declaration |
1702 N_Subprogram_Declaration |
1703 N_Subprogram_Renaming_Declaration |
1704 N_Package_Renaming_Declaration |
1705 N_Generic_Function_Renaming_Declaration |
1706 N_Generic_Package_Renaming_Declaration |
1707 N_Generic_Procedure_Renaming_Declaration =>
1713 when N_Package_Body =>
1715 -- Package bodies are processed separately if the main unit
1720 when N_Subprogram_Body =>
1722 -- A subprogram body must be the main unit
1724 pragma Assert (Acts_As_Spec (CU)
1725 or else CU = Cunit (Main_Unit));
1728 when N_Function_Instantiation |
1729 N_Procedure_Instantiation |
1730 N_Package_Instantiation =>
1732 -- Can only happen if some generic body (needed for gnat2scil
1733 -- traversal, but not by GNAT) is not available, ignore.
1737 -- All other cases cannot happen
1740 pragma Assert (False, "subunit");
1744 pragma Assert (False);
1748 if Present (CU) then
1749 pragma Assert (Item /= Stand.Standard_Package_Node);
1750 pragma Assert (Item = Unit (CU));
1753 Unit_Num : constant Unit_Number_Type :=
1754 Get_Cunit_Unit_Number (CU);
1756 procedure Assert_Done (Withed_Unit : Node_Id);
1757 -- Assert Withed_Unit is already Done, unless it's a body. It
1758 -- might seem strange for a with_clause to refer to a body, but
1759 -- this happens in the case of a generic instantiation, which
1760 -- gets transformed into the instance body (and the instance
1761 -- spec is also created). With clauses pointing to the
1762 -- instantiation end up pointing to the instance body.
1768 procedure Assert_Done (Withed_Unit : Node_Id) is
1770 if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
1772 (Unit (Withed_Unit),
1773 N_Generic_Package_Declaration,
1775 N_Package_Renaming_Declaration,
1779 (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit)));
1780 Write_Str (" not yet walked!");
1782 if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
1783 Write_Str (" (self-ref)");
1788 pragma Assert (False);
1793 procedure Assert_Withed_Units_Done is
1794 new Walk_Withs (Assert_Done);
1797 if Debug_Unit_Walk then
1798 Write_Unit_Info (Unit_Num, Item, Withs => True);
1801 -- Main unit should come last, except in the case where we
1802 -- skipped System_Aux_Id, in which case we missed the things it
1803 -- depends on, and in the case of parent bodies if present.
1806 (not Done (Main_Unit)
1807 or else Present (System_Aux_Id)
1808 or else Nkind (Item) = N_Package_Body);
1810 -- We shouldn't do the same thing twice
1812 pragma Assert (not Done (Unit_Num));
1814 -- Everything we depend upon should already be done
1817 (Assert_Withed_Units_Done (CU, Include_Limited => False));
1821 -- Must be Standard, which has no entry in the units table
1823 pragma Assert (Item = Stand.Standard_Package_Node);
1825 if Debug_Unit_Walk then
1826 Write_Line ("Standard");
1833 --------------------
1834 -- Do_Withed_Unit --
1835 --------------------
1837 procedure Do_Withed_Unit (Withed_Unit : Node_Id) is
1839 Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit));
1841 -- If the unit in the with_clause is a generic instance, the clause
1842 -- now denotes the instance body. Traverse the corresponding spec
1843 -- because there may be no other dependence that will force the
1844 -- traversal of its own context.
1846 if Nkind (Unit (Withed_Unit)) = N_Package_Body
1847 and then Is_Generic_Instance
1848 (Defining_Entity (Unit (Library_Unit (Withed_Unit))))
1850 Do_Withed_Unit (Library_Unit (Withed_Unit));
1854 ----------------------------
1855 -- Do_Unit_And_Dependents --
1856 ----------------------------
1858 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
1859 Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU);
1861 Body_U : Unit_Number_Type;
1862 Parent_CU : Node_Id;
1864 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
1867 if not Seen (Unit_Num) then
1869 -- Process the with clauses
1871 Do_Withed_Units (CU, Include_Limited => False);
1873 -- Process the unit if it is a spec or the main unit, if it
1874 -- has no previous spec or we have done all other units.
1876 if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
1877 or else Acts_As_Spec (CU)
1879 if CU = Cunit (Main_Unit)
1880 and then not Do_Main
1882 Seen (Unit_Num) := False;
1885 Seen (Unit_Num) := True;
1887 if CU = Library_Unit (Main_CU) then
1888 Process_Bodies_In_Context (CU);
1890 -- If main is a child unit, examine parent unit contexts
1891 -- to see if they include instantiated units. Also, if
1892 -- the parent itself is an instance, process its body
1893 -- because it may contain subprograms that are called
1894 -- in the main unit.
1896 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
1897 Child := Cunit_Entity (Main_Unit);
1898 while Is_Child_Unit (Child) loop
1901 (Get_Cunit_Entity_Unit_Number (Scope (Child)));
1902 Process_Bodies_In_Context (Parent_CU);
1904 if Nkind (Unit (Parent_CU)) = N_Package_Body
1906 Nkind (Original_Node (Unit (Parent_CU)))
1907 = N_Package_Instantiation
1909 not Seen (Get_Cunit_Unit_Number (Parent_CU))
1911 Body_U := Get_Cunit_Unit_Number (Parent_CU);
1912 Seen (Body_U) := True;
1913 Do_Action (Parent_CU, Unit (Parent_CU));
1914 Done (Body_U) := True;
1917 Child := Scope (Child);
1922 Do_Action (CU, Item);
1923 Done (Unit_Num) := True;
1927 end Do_Unit_And_Dependents;
1929 -------------------------------
1930 -- Process_Bodies_In_Context --
1931 -------------------------------
1933 procedure Process_Bodies_In_Context (Comp : Node_Id) is
1935 Body_U : Unit_Number_Type;
1939 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
1941 -- Start of processing for Process_Bodies_In_Context
1944 Clause := First (Context_Items (Comp));
1945 while Present (Clause) loop
1946 if Nkind (Clause) = N_With_Clause then
1947 Spec := Library_Unit (Clause);
1948 Body_CU := Library_Unit (Spec);
1950 -- If we are processing the spec of the main unit, load bodies
1951 -- only if the with_clause indicates that it forced the loading
1952 -- of the body for a generic instantiation. Note that bodies of
1953 -- parents that are instances have been loaded already.
1955 if Present (Body_CU)
1956 and then Body_CU /= Cunit (Main_Unit)
1957 and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body
1958 and then (Nkind (Unit (Comp)) /= N_Package_Declaration
1959 or else Present (Withed_Body (Clause)))
1961 Body_U := Get_Cunit_Unit_Number (Body_CU);
1963 if not Seen (Body_U)
1964 and then not Depends_On_Main (Body_CU)
1966 Seen (Body_U) := True;
1967 Do_Withed_Units (Body_CU, Include_Limited => False);
1968 Do_Action (Body_CU, Unit (Body_CU));
1969 Done (Body_U) := True;
1976 end Process_Bodies_In_Context;
1978 -- Local Declarations
1982 -- Start of processing for Walk_Library_Items
1985 if Debug_Unit_Walk then
1986 Write_Line ("Walk_Library_Items:");
1990 -- Do Standard first, then walk the Comp_Unit_List
1992 Do_Action (Empty, Standard_Package_Node);
1994 -- First place the context of all instance bodies on the corresponding
1995 -- spec, because it may be needed to analyze the code at the place of
1996 -- the instantiation.
1998 Cur := First_Elmt (Comp_Unit_List);
1999 while Present (Cur) loop
2001 CU : constant Node_Id := Node (Cur);
2002 N : constant Node_Id := Unit (CU);
2005 if Nkind (N) = N_Package_Body
2006 and then Is_Generic_Instance (Defining_Entity (N))
2009 (Context_Items (CU), Context_Items (Library_Unit (CU)));
2016 -- Now traverse compilation units (specs) in order
2018 Cur := First_Elmt (Comp_Unit_List);
2019 while Present (Cur) loop
2021 CU : constant Node_Id := Node (Cur);
2022 N : constant Node_Id := Unit (CU);
2026 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2030 -- If it is a subprogram body, process it if it has no
2033 -- If it's a package body, ignore it, unless it is a body
2034 -- created for an instance that is the main unit. In the case
2035 -- of subprograms, the body is the wrapper package. In case of
2036 -- a package, the original file carries the body, and the spec
2037 -- appears as a later entry in the units list.
2039 -- Otherwise bodies appear in the list only because of inlining
2040 -- or instantiations, and they are processed only if relevant.
2041 -- The flag Withed_Body on a context clause indicates that a
2042 -- unit contains an instantiation that may be needed later,
2043 -- and therefore the body that contains the generic body (and
2044 -- its context) must be traversed immediately after the
2045 -- corresponding spec (see Do_Unit_And_Dependents).
2047 -- The main unit itself is processed separately after all other
2048 -- specs, and relevant bodies are examined in Process_Main.
2050 when N_Subprogram_Body =>
2051 if Acts_As_Spec (N) then
2052 Do_Unit_And_Dependents (CU, N);
2055 when N_Package_Body =>
2057 and then Nkind (Original_Node (Unit (Main_CU))) in
2058 N_Generic_Instantiation
2059 and then Present (Library_Unit (Main_CU))
2061 Do_Unit_And_Dependents
2062 (Library_Unit (Main_CU),
2063 Unit (Library_Unit (Main_CU)));
2066 -- It's a spec, process it, and the units it depends on,
2067 -- unless it is a descendent of the main unit. This can
2068 -- happen when the body of a parent depends on some other
2072 Par := Scope (Defining_Entity (Unit (CU)));
2074 if Is_Child_Unit (Defining_Entity (Unit (CU))) then
2076 and then Par /= Standard_Standard
2077 and then Par /= Cunit_Entity (Main_Unit)
2083 if Par /= Cunit_Entity (Main_Unit) then
2084 Do_Unit_And_Dependents (CU, N);
2092 -- Now process package bodies on which main depends, followed by bodies
2093 -- of parents, if present, and finally main itself.
2095 if not Done (Main_Unit) then
2098 Process_Main : declare
2099 Parent_CU : Node_Id;
2101 Body_U : Unit_Number_Type;
2104 function Is_Subunit_Of_Main (U : Node_Id) return Boolean;
2105 -- If the main unit has subunits, their context may include
2106 -- bodies that are needed in the body of main. We must examine
2107 -- the context of the subunits, which are otherwise not made
2108 -- explicit in the main unit.
2110 ------------------------
2111 -- Is_Subunit_Of_Main --
2112 ------------------------
2114 function Is_Subunit_Of_Main (U : Node_Id) return Boolean is
2120 Lib := Library_Unit (U);
2121 return Nkind (Unit (U)) = N_Subunit
2123 (Lib = Cunit (Main_Unit)
2124 or else Is_Subunit_Of_Main (Lib));
2126 end Is_Subunit_Of_Main;
2128 -- Start of processing for Process_Main
2131 Process_Bodies_In_Context (Main_CU);
2133 for Unit_Num in Done'Range loop
2134 if Is_Subunit_Of_Main (Cunit (Unit_Num)) then
2135 Process_Bodies_In_Context (Cunit (Unit_Num));
2139 -- If the main unit is a child unit, parent bodies may be present
2140 -- because they export instances or inlined subprograms. Check for
2141 -- presence of these, which are not present in context clauses.
2142 -- Note that if the parents are instances, their bodies have been
2143 -- processed before the main spec, because they may be needed
2144 -- therein, so the following loop only affects non-instances.
2146 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
2147 Child := Cunit_Entity (Main_Unit);
2148 while Is_Child_Unit (Child) loop
2150 Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child)));
2151 Body_CU := Library_Unit (Parent_CU);
2153 if Present (Body_CU)
2154 and then not Seen (Get_Cunit_Unit_Number (Body_CU))
2155 and then not Depends_On_Main (Body_CU)
2157 Body_U := Get_Cunit_Unit_Number (Body_CU);
2158 Seen (Body_U) := True;
2159 Do_Action (Body_CU, Unit (Body_CU));
2160 Done (Body_U) := True;
2163 Child := Scope (Child);
2167 Do_Action (Main_CU, Unit (Main_CU));
2168 Done (Main_Unit) := True;
2172 if Debug_Unit_Walk then
2173 if Done /= (Done'Range => True) then
2175 Write_Line ("Ignored units:");
2179 for Unit_Num in Done'Range loop
2180 if not Done (Unit_Num) then
2182 (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True);
2190 pragma Assert (Done (Main_Unit));
2192 if Debug_Unit_Walk then
2194 Write_Line ("end Walk_Library_Items.");
2196 end Walk_Library_Items;
2202 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is
2203 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2204 pragma Assert (Nkind (Unit (CU)) /= N_Subunit);
2206 procedure Walk_Immediate is new Walk_Withs_Immediate (Action);
2209 -- First walk the withs immediately on the library item
2211 Walk_Immediate (CU, Include_Limited);
2213 -- For a body, we must also check for any subunits which belong to it
2214 -- and which have context clauses of their own, since these with'ed
2215 -- units are part of its own dependencies.
2217 if Nkind (Unit (CU)) in N_Unit_Body then
2218 for S in Main_Unit .. Last_Unit loop
2220 -- We are only interested in subunits. For preproc. data and def.
2221 -- files, Cunit is Empty, so we need to test that first.
2223 if Cunit (S) /= Empty
2224 and then Nkind (Unit (Cunit (S))) = N_Subunit
2230 Pnode := Library_Unit (Cunit (S));
2232 -- In -gnatc mode, the errors in the subunits will not have
2233 -- been recorded, but the analysis of the subunit may have
2234 -- failed, so just quit.
2240 -- Find ultimate parent of the subunit
2242 while Nkind (Unit (Pnode)) = N_Subunit loop
2243 Pnode := Library_Unit (Pnode);
2246 -- See if it belongs to current unit, and if so, include its
2247 -- with_clauses. Do not process main unit prematurely.
2249 if Pnode = CU and then CU /= Cunit (Main_Unit) then
2250 Walk_Immediate (Cunit (S), Include_Limited);
2258 --------------------------
2259 -- Walk_Withs_Immediate --
2260 --------------------------
2262 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is
2263 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2265 Context_Item : Node_Id;
2270 Context_Item := First (Context_Items (CU));
2271 while Present (Context_Item) loop
2272 if Nkind (Context_Item) = N_With_Clause
2273 and then (Include_Limited
2274 or else not Limited_Present (Context_Item))
2276 Lib_Unit := Library_Unit (Context_Item);
2279 -- If the context item indicates that a package body is needed
2280 -- because of an instantiation in CU, traverse the body now, even
2281 -- if CU is not related to the main unit. If the generic itself
2282 -- appears in a package body, the context item is this body, and
2283 -- it already appears in the traversal order, so we only need to
2284 -- examine the case of a context item being a package declaration.
2286 if Present (Withed_Body (Context_Item))
2287 and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration
2288 and then Present (Corresponding_Body (Unit (Lib_Unit)))
2292 (Unit_Declaration_Node
2293 (Corresponding_Body (Unit (Lib_Unit))));
2295 -- A body may have an implicit with on its own spec, in which
2296 -- case we must ignore this context item to prevent looping.
2298 if Unit (CU) /= Unit (Body_CU) then
2304 Context_Item := Next (Context_Item);
2306 end Walk_Withs_Immediate;