1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2011, 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;
35 with Lib.Load; use Lib.Load;
36 with Nlists; use Nlists;
37 with Output; use Output;
38 with Restrict; use Restrict;
39 with Sem_Attr; use Sem_Attr;
40 with Sem_Aux; use Sem_Aux;
41 with Sem_Ch2; use Sem_Ch2;
42 with Sem_Ch3; use Sem_Ch3;
43 with Sem_Ch4; use Sem_Ch4;
44 with Sem_Ch5; use Sem_Ch5;
45 with Sem_Ch6; use Sem_Ch6;
46 with Sem_Ch7; use Sem_Ch7;
47 with Sem_Ch8; use Sem_Ch8;
48 with Sem_Ch9; use Sem_Ch9;
49 with Sem_Ch10; use Sem_Ch10;
50 with Sem_Ch11; use Sem_Ch11;
51 with Sem_Ch12; use Sem_Ch12;
52 with Sem_Ch13; use Sem_Ch13;
53 with Sem_Prag; use Sem_Prag;
54 with Sem_Util; use Sem_Util;
55 with Sinfo; use Sinfo;
56 with Stand; use Stand;
57 with Uintp; use Uintp;
58 with Uname; use Uname;
60 with Unchecked_Deallocation;
62 pragma Warnings (Off, Sem_Util);
63 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
67 Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW;
68 -- Controls debugging printouts for Walk_Library_Items
70 Outer_Generic_Scope : Entity_Id := Empty;
71 -- Global reference to the outer scope that is generic. In a non-generic
72 -- context, it is empty. At the moment, it is only used for avoiding
73 -- freezing of external references in generics.
75 Comp_Unit_List : Elist_Id := No_Elist;
76 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
77 -- processed by Semantics, in an appropriate order. Initialized to
78 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
79 -- to New_Elmt_List on first use.
82 with procedure Action (Withed_Unit : Node_Id);
83 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean);
84 -- Walk all the with clauses of CU, and call Action for the with'ed unit.
85 -- Ignore limited withs, unless Include_Limited is True. CU must be an
86 -- N_Compilation_Unit.
89 with procedure Action (Withed_Unit : Node_Id);
90 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean);
91 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
92 -- of this unit, since they count as dependences on their parent library
93 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
95 procedure Write_Unit_Info
96 (Unit_Num : Unit_Number_Type;
98 Prefix : String := "";
99 Withs : Boolean := False);
100 -- Print out debugging information about the unit. Prefix precedes the rest
101 -- of the printout. If Withs is True, we print out units with'ed by this
102 -- unit (not counting limited withs).
108 procedure Analyze (N : Node_Id) is
110 Debug_A_Entry ("analyzing ", N);
112 -- Immediate return if already analyzed
115 Debug_A_Exit ("analyzing ", N, " (done, analyzed already)");
119 -- Otherwise processing depends on the node kind
123 when N_Abort_Statement =>
124 Analyze_Abort_Statement (N);
126 when N_Abstract_Subprogram_Declaration =>
127 Analyze_Abstract_Subprogram_Declaration (N);
129 when N_Accept_Alternative =>
130 Analyze_Accept_Alternative (N);
132 when N_Accept_Statement =>
133 Analyze_Accept_Statement (N);
136 Analyze_Aggregate (N);
139 Analyze_Allocator (N);
142 Analyze_Short_Circuit (N);
144 when N_Assignment_Statement =>
145 Analyze_Assignment (N);
147 when N_Asynchronous_Select =>
148 Analyze_Asynchronous_Select (N);
151 Analyze_At_Clause (N);
153 when N_Attribute_Reference =>
154 Analyze_Attribute (N);
156 when N_Attribute_Definition_Clause =>
157 Analyze_Attribute_Definition_Clause (N);
159 when N_Block_Statement =>
160 Analyze_Block_Statement (N);
162 when N_Case_Expression =>
163 Analyze_Case_Expression (N);
165 when N_Case_Statement =>
166 Analyze_Case_Statement (N);
168 when N_Character_Literal =>
169 Analyze_Character_Literal (N);
171 when N_Code_Statement =>
172 Analyze_Code_Statement (N);
174 when N_Compilation_Unit =>
175 Analyze_Compilation_Unit (N);
177 when N_Component_Declaration =>
178 Analyze_Component_Declaration (N);
180 when N_Conditional_Expression =>
181 Analyze_Conditional_Expression (N);
183 when N_Conditional_Entry_Call =>
184 Analyze_Conditional_Entry_Call (N);
186 when N_Delay_Alternative =>
187 Analyze_Delay_Alternative (N);
189 when N_Delay_Relative_Statement =>
190 Analyze_Delay_Relative (N);
192 when N_Delay_Until_Statement =>
193 Analyze_Delay_Until (N);
196 Analyze_Entry_Body (N);
198 when N_Entry_Body_Formal_Part =>
199 Analyze_Entry_Body_Formal_Part (N);
201 when N_Entry_Call_Alternative =>
202 Analyze_Entry_Call_Alternative (N);
204 when N_Entry_Declaration =>
205 Analyze_Entry_Declaration (N);
207 when N_Entry_Index_Specification =>
208 Analyze_Entry_Index_Specification (N);
210 when N_Enumeration_Representation_Clause =>
211 Analyze_Enumeration_Representation_Clause (N);
213 when N_Exception_Declaration =>
214 Analyze_Exception_Declaration (N);
216 when N_Exception_Renaming_Declaration =>
217 Analyze_Exception_Renaming (N);
219 when N_Exit_Statement =>
220 Analyze_Exit_Statement (N);
222 when N_Expanded_Name =>
223 Analyze_Expanded_Name (N);
225 when N_Explicit_Dereference =>
226 Analyze_Explicit_Dereference (N);
228 when N_Expression_Function =>
229 Analyze_Expression_Function (N);
231 when N_Expression_With_Actions =>
232 Analyze_Expression_With_Actions (N);
234 when N_Extended_Return_Statement =>
235 Analyze_Extended_Return_Statement (N);
237 when N_Extension_Aggregate =>
238 Analyze_Aggregate (N);
240 when N_Formal_Object_Declaration =>
241 Analyze_Formal_Object_Declaration (N);
243 when N_Formal_Package_Declaration =>
244 Analyze_Formal_Package_Declaration (N);
246 when N_Formal_Subprogram_Declaration =>
247 Analyze_Formal_Subprogram_Declaration (N);
249 when N_Formal_Type_Declaration =>
250 Analyze_Formal_Type_Declaration (N);
252 when N_Free_Statement =>
253 Analyze_Free_Statement (N);
255 when N_Freeze_Entity =>
256 Analyze_Freeze_Entity (N);
258 when N_Full_Type_Declaration =>
259 Analyze_Full_Type_Declaration (N);
261 when N_Function_Call =>
262 Analyze_Function_Call (N);
264 when N_Function_Instantiation =>
265 Analyze_Function_Instantiation (N);
267 when N_Generic_Function_Renaming_Declaration =>
268 Analyze_Generic_Function_Renaming (N);
270 when N_Generic_Package_Declaration =>
271 Analyze_Generic_Package_Declaration (N);
273 when N_Generic_Package_Renaming_Declaration =>
274 Analyze_Generic_Package_Renaming (N);
276 when N_Generic_Procedure_Renaming_Declaration =>
277 Analyze_Generic_Procedure_Renaming (N);
279 when N_Generic_Subprogram_Declaration =>
280 Analyze_Generic_Subprogram_Declaration (N);
282 when N_Goto_Statement =>
283 Analyze_Goto_Statement (N);
285 when N_Handled_Sequence_Of_Statements =>
286 Analyze_Handled_Statements (N);
289 Analyze_Identifier (N);
291 when N_If_Statement =>
292 Analyze_If_Statement (N);
294 when N_Implicit_Label_Declaration =>
295 Analyze_Implicit_Label_Declaration (N);
298 Analyze_Membership_Op (N);
300 when N_Incomplete_Type_Declaration =>
301 Analyze_Incomplete_Type_Decl (N);
303 when N_Indexed_Component =>
304 Analyze_Indexed_Component_Form (N);
306 when N_Integer_Literal =>
307 Analyze_Integer_Literal (N);
309 when N_Iterator_Specification =>
310 Analyze_Iterator_Specification (N);
312 when N_Itype_Reference =>
313 Analyze_Itype_Reference (N);
318 when N_Loop_Statement =>
319 Analyze_Loop_Statement (N);
322 Analyze_Membership_Op (N);
327 when N_Null_Statement =>
328 Analyze_Null_Statement (N);
330 when N_Number_Declaration =>
331 Analyze_Number_Declaration (N);
333 when N_Object_Declaration =>
334 Analyze_Object_Declaration (N);
336 when N_Object_Renaming_Declaration =>
337 Analyze_Object_Renaming (N);
339 when N_Operator_Symbol =>
340 Analyze_Operator_Symbol (N);
343 Analyze_Unary_Op (N);
346 Analyze_Arithmetic_Op (N);
349 Analyze_Logical_Op (N);
352 Analyze_Concatenation (N);
355 Analyze_Arithmetic_Op (N);
358 Analyze_Equality_Op (N);
361 Analyze_Arithmetic_Op (N);
364 Analyze_Comparison_Op (N);
367 Analyze_Comparison_Op (N);
370 Analyze_Comparison_Op (N);
373 Analyze_Comparison_Op (N);
376 Analyze_Unary_Op (N);
379 Analyze_Arithmetic_Op (N);
381 when N_Op_Multiply =>
382 Analyze_Arithmetic_Op (N);
385 Analyze_Equality_Op (N);
388 Analyze_Negation (N);
391 Analyze_Logical_Op (N);
394 Analyze_Unary_Op (N);
397 Analyze_Arithmetic_Op (N);
399 when N_Op_Rotate_Left =>
400 Analyze_Arithmetic_Op (N);
402 when N_Op_Rotate_Right =>
403 Analyze_Arithmetic_Op (N);
405 when N_Op_Shift_Left =>
406 Analyze_Arithmetic_Op (N);
408 when N_Op_Shift_Right =>
409 Analyze_Arithmetic_Op (N);
411 when N_Op_Shift_Right_Arithmetic =>
412 Analyze_Arithmetic_Op (N);
414 when N_Op_Subtract =>
415 Analyze_Arithmetic_Op (N);
418 Analyze_Logical_Op (N);
421 Analyze_Short_Circuit (N);
423 when N_Others_Choice =>
424 Analyze_Others_Choice (N);
426 when N_Package_Body =>
427 Analyze_Package_Body (N);
429 when N_Package_Body_Stub =>
430 Analyze_Package_Body_Stub (N);
432 when N_Package_Declaration =>
433 Analyze_Package_Declaration (N);
435 when N_Package_Instantiation =>
436 Analyze_Package_Instantiation (N);
438 when N_Package_Renaming_Declaration =>
439 Analyze_Package_Renaming (N);
441 when N_Package_Specification =>
442 Analyze_Package_Specification (N);
444 when N_Parameter_Association =>
445 Analyze_Parameter_Association (N);
450 when N_Private_Extension_Declaration =>
451 Analyze_Private_Extension_Declaration (N);
453 when N_Private_Type_Declaration =>
454 Analyze_Private_Type_Declaration (N);
456 when N_Procedure_Call_Statement =>
457 Analyze_Procedure_Call (N);
459 when N_Procedure_Instantiation =>
460 Analyze_Procedure_Instantiation (N);
462 when N_Protected_Body =>
463 Analyze_Protected_Body (N);
465 when N_Protected_Body_Stub =>
466 Analyze_Protected_Body_Stub (N);
468 when N_Protected_Definition =>
469 Analyze_Protected_Definition (N);
471 when N_Protected_Type_Declaration =>
472 Analyze_Protected_Type_Declaration (N);
474 when N_Qualified_Expression =>
475 Analyze_Qualified_Expression (N);
477 when N_Quantified_Expression =>
478 Analyze_Quantified_Expression (N);
480 when N_Raise_Statement =>
481 Analyze_Raise_Statement (N);
483 when N_Raise_xxx_Error =>
484 Analyze_Raise_xxx_Error (N);
489 when N_Range_Constraint =>
490 Analyze_Range (Range_Expression (N));
492 when N_Real_Literal =>
493 Analyze_Real_Literal (N);
495 when N_Record_Representation_Clause =>
496 Analyze_Record_Representation_Clause (N);
499 Analyze_Reference (N);
501 when N_Requeue_Statement =>
504 when N_Simple_Return_Statement =>
505 Analyze_Simple_Return_Statement (N);
507 when N_Selected_Component =>
508 Find_Selected_Component (N);
509 -- ??? why not Analyze_Selected_Component, needs comments
511 when N_Selective_Accept =>
512 Analyze_Selective_Accept (N);
514 when N_Single_Protected_Declaration =>
515 Analyze_Single_Protected_Declaration (N);
517 when N_Single_Task_Declaration =>
518 Analyze_Single_Task_Declaration (N);
523 when N_String_Literal =>
524 Analyze_String_Literal (N);
526 when N_Subprogram_Body =>
527 Analyze_Subprogram_Body (N);
529 when N_Subprogram_Body_Stub =>
530 Analyze_Subprogram_Body_Stub (N);
532 when N_Subprogram_Declaration =>
533 Analyze_Subprogram_Declaration (N);
535 when N_Subprogram_Info =>
536 Analyze_Subprogram_Info (N);
538 when N_Subprogram_Renaming_Declaration =>
539 Analyze_Subprogram_Renaming (N);
541 when N_Subtype_Declaration =>
542 Analyze_Subtype_Declaration (N);
544 when N_Subtype_Indication =>
545 Analyze_Subtype_Indication (N);
551 Analyze_Task_Body (N);
553 when N_Task_Body_Stub =>
554 Analyze_Task_Body_Stub (N);
556 when N_Task_Definition =>
557 Analyze_Task_Definition (N);
559 when N_Task_Type_Declaration =>
560 Analyze_Task_Type_Declaration (N);
562 when N_Terminate_Alternative =>
563 Analyze_Terminate_Alternative (N);
565 when N_Timed_Entry_Call =>
566 Analyze_Timed_Entry_Call (N);
568 when N_Triggering_Alternative =>
569 Analyze_Triggering_Alternative (N);
571 when N_Type_Conversion =>
572 Analyze_Type_Conversion (N);
574 when N_Unchecked_Expression =>
575 Analyze_Unchecked_Expression (N);
577 when N_Unchecked_Type_Conversion =>
578 Analyze_Unchecked_Type_Conversion (N);
580 when N_Use_Package_Clause =>
581 Analyze_Use_Package (N);
583 when N_Use_Type_Clause =>
584 Analyze_Use_Type (N);
586 when N_Validate_Unchecked_Conversion =>
589 when N_Variant_Part =>
590 Analyze_Variant_Part (N);
592 when N_With_Clause =>
593 Analyze_With_Clause (N);
595 -- A call to analyze the Empty node is an error, but most likely it
596 -- is an error caused by an attempt to analyze a malformed piece of
597 -- tree caused by some other error, so if there have been any other
598 -- errors, we just ignore it, otherwise it is a real internal error
599 -- which we complain about.
601 -- We must also consider the case of call to a runtime function that
602 -- is not available in the configurable runtime.
605 pragma Assert (Serious_Errors_Detected /= 0
606 or else Configurable_Run_Time_Violations /= 0);
609 -- A call to analyze the error node is simply ignored, to avoid
610 -- causing cascaded errors (happens of course only in error cases)
615 -- Push/Pop nodes normally don't come through an analyze call. An
616 -- exception is the dummy ones bracketing a subprogram body. In any
617 -- case there is nothing to be done to analyze such nodes.
619 when N_Push_Pop_xxx_Label =>
622 -- SCIL nodes don't need analysis because they are decorated when
623 -- they are built. They are added to the tree by Insert_Actions and
624 -- the call to analyze them is generated when the full list is
628 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.
642 N_Access_Definition |
643 N_Access_Function_Definition |
644 N_Access_Procedure_Definition |
645 N_Access_To_Object_Definition |
646 N_Aspect_Specification |
647 N_Case_Expression_Alternative |
648 N_Case_Statement_Alternative |
649 N_Compilation_Unit_Aux |
650 N_Component_Association |
652 N_Component_Definition |
654 N_Constrained_Array_Definition |
656 N_Decimal_Fixed_Point_Definition |
657 N_Defining_Character_Literal |
658 N_Defining_Identifier |
659 N_Defining_Operator_Symbol |
660 N_Defining_Program_Unit_Name |
662 N_Derived_Type_Definition |
664 N_Digits_Constraint |
665 N_Discriminant_Association |
666 N_Discriminant_Specification |
668 N_Entry_Call_Statement |
669 N_Enumeration_Type_Definition |
670 N_Exception_Handler |
671 N_Floating_Point_Definition |
672 N_Formal_Decimal_Fixed_Point_Definition |
673 N_Formal_Derived_Type_Definition |
674 N_Formal_Discrete_Type_Definition |
675 N_Formal_Floating_Point_Definition |
676 N_Formal_Modular_Type_Definition |
677 N_Formal_Ordinary_Fixed_Point_Definition |
678 N_Formal_Private_Type_Definition |
679 N_Formal_Incomplete_Type_Definition |
680 N_Formal_Signed_Integer_Type_Definition |
681 N_Function_Specification |
682 N_Generic_Association |
683 N_Index_Or_Discriminant_Constraint |
685 N_Loop_Parameter_Specification |
687 N_Modular_Type_Definition |
688 N_Ordinary_Fixed_Point_Definition |
689 N_Parameter_Specification |
690 N_Pragma_Argument_Association |
691 N_Procedure_Specification |
692 N_Real_Range_Specification |
693 N_Record_Definition |
694 N_Signed_Integer_Type_Definition |
695 N_Unconstrained_Array_Definition |
703 Debug_A_Exit ("analyzing ", N, " (done)");
705 -- Now that we have analyzed the node, we call the expander to perform
706 -- possible expansion. We skip this for subexpressions, because we don't
707 -- have the type yet, and the expander will need to know the type before
708 -- it can do its job. For subexpression nodes, the call to the expander
709 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
710 -- which can appear in a statement context, and needs expanding now in
711 -- the case (distinguished by Etype, as documented in Sinfo).
713 -- The Analyzed flag is also set at this point for non-subexpression
714 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
715 -- since resolution and expansion have not yet been completed). Note
716 -- that for N_Raise_xxx_Error we have to distinguish the expression
717 -- case from the statement case.
719 if Nkind (N) not in N_Subexpr
720 or else (Nkind (N) in N_Raise_xxx_Error
721 and then Etype (N) = Standard_Void_Type)
727 -- Version with check(s) suppressed
729 procedure Analyze (N : Node_Id; Suppress : Check_Id) is
731 if Suppress = All_Checks then
733 Svg : constant Suppress_Array := Scope_Suppress;
735 Scope_Suppress := (others => True);
737 Scope_Suppress := Svg;
742 Svg : constant Boolean := Scope_Suppress (Suppress);
744 Scope_Suppress (Suppress) := True;
746 Scope_Suppress (Suppress) := Svg;
755 procedure Analyze_List (L : List_Id) is
760 while Present (Node) loop
766 -- Version with check(s) suppressed
768 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
770 if Suppress = All_Checks then
772 Svg : constant Suppress_Array := Scope_Suppress;
774 Scope_Suppress := (others => True);
776 Scope_Suppress := Svg;
781 Svg : constant Boolean := Scope_Suppress (Suppress);
783 Scope_Suppress (Suppress) := True;
785 Scope_Suppress (Suppress) := Svg;
790 --------------------------
791 -- Copy_Suppress_Status --
792 --------------------------
794 procedure Copy_Suppress_Status
800 pragma Warnings (Off, Found);
802 procedure Search_Stack
803 (Top : Suppress_Stack_Entry_Ptr;
804 Found : out Boolean);
805 -- Search given suppress stack for matching entry for entity. If found
806 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
807 -- entry for To onto the local suppress stack.
813 procedure Search_Stack
814 (Top : Suppress_Stack_Entry_Ptr;
817 Ptr : Suppress_Stack_Entry_Ptr;
821 while Ptr /= null loop
823 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
826 Set_Checks_May_Be_Suppressed (To, True);
827 Push_Local_Suppress_Stack_Entry
843 -- Start of processing for Copy_Suppress_Status
846 if not Checks_May_Be_Suppressed (From) then
850 -- First search the global entity suppress table for a matching entry.
851 -- We also search this in reverse order so that if there are multiple
852 -- pragmas for the same entity, the last one applies.
854 Search_Stack (Global_Suppress_Stack_Top, Found);
860 -- Now search the local entity suppress stack, we search this in
861 -- reverse order so that we get the innermost entry that applies to
862 -- this case if there are nested entries. Note that for the purpose
863 -- of this procedure we are ONLY looking for entries corresponding
864 -- to a two-argument Suppress, where the second argument matches From.
866 Search_Stack (Local_Suppress_Stack_Top, Found);
867 end Copy_Suppress_Status;
869 -------------------------
870 -- Enter_Generic_Scope --
871 -------------------------
873 procedure Enter_Generic_Scope (S : Entity_Id) is
875 if No (Outer_Generic_Scope) then
876 Outer_Generic_Scope := S;
878 end Enter_Generic_Scope;
880 ------------------------
881 -- Exit_Generic_Scope --
882 ------------------------
884 procedure Exit_Generic_Scope (S : Entity_Id) is
886 if S = Outer_Generic_Scope then
887 Outer_Generic_Scope := Empty;
889 end Exit_Generic_Scope;
891 -----------------------
892 -- Explicit_Suppress --
893 -----------------------
895 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
896 Ptr : Suppress_Stack_Entry_Ptr;
899 if not Checks_May_Be_Suppressed (E) then
903 Ptr := Global_Suppress_Stack_Top;
904 while Ptr /= null loop
906 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
916 end Explicit_Suppress;
918 -----------------------------
919 -- External_Ref_In_Generic --
920 -----------------------------
922 function External_Ref_In_Generic (E : Entity_Id) return Boolean is
926 -- Entity is global if defined outside of current outer_generic_scope:
927 -- Either the entity has a smaller depth that the outer generic, or it
928 -- is in a different compilation unit, or it is defined within a unit
929 -- in the same compilation, that is not within the outer_generic.
931 if No (Outer_Generic_Scope) then
934 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
935 or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
941 while Present (Scop) loop
942 if Scop = Outer_Generic_Scope then
944 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
947 Scop := Scope (Scop);
953 end External_Ref_In_Generic;
959 procedure Initialize is
960 Next : Suppress_Stack_Entry_Ptr;
962 procedure Free is new Unchecked_Deallocation
963 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
966 -- Free any global suppress stack entries from a previous invocation
967 -- of the compiler (in the normal case this loop does nothing).
969 while Suppress_Stack_Entries /= null loop
970 Next := Suppress_Stack_Entries.Next;
971 Free (Suppress_Stack_Entries);
972 Suppress_Stack_Entries := Next;
975 Local_Suppress_Stack_Top := null;
976 Global_Suppress_Stack_Top := null;
978 -- Clear scope stack, and reset global variables
981 Unloaded_Subunits := False;
984 ------------------------------
985 -- Insert_After_And_Analyze --
986 ------------------------------
988 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
994 -- If we are not at the end of the list, then the easiest
995 -- coding is simply to insert before our successor
997 if Present (Next (N)) then
998 Insert_Before_And_Analyze (Next (N), M);
1000 -- Case of inserting at the end of the list
1003 -- Capture the Node_Id of the node to be inserted. This Node_Id
1004 -- will still be the same after the insert operation.
1007 Insert_After (N, M);
1009 -- Now just analyze from the inserted node to the end of
1010 -- the new list (note that this properly handles the case
1011 -- where any of the analyze calls result in the insertion of
1012 -- nodes after the analyzed node, expecting analysis).
1014 while Present (Node) loop
1016 Mark_Rewrite_Insertion (Node);
1021 end Insert_After_And_Analyze;
1023 -- Version with check(s) suppressed
1025 procedure Insert_After_And_Analyze
1028 Suppress : Check_Id)
1031 if Suppress = All_Checks then
1033 Svg : constant Suppress_Array := Scope_Suppress;
1035 Scope_Suppress := (others => True);
1036 Insert_After_And_Analyze (N, M);
1037 Scope_Suppress := Svg;
1042 Svg : constant Boolean := Scope_Suppress (Suppress);
1044 Scope_Suppress (Suppress) := True;
1045 Insert_After_And_Analyze (N, M);
1046 Scope_Suppress (Suppress) := Svg;
1049 end Insert_After_And_Analyze;
1051 -------------------------------
1052 -- Insert_Before_And_Analyze --
1053 -------------------------------
1055 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
1061 -- Capture the Node_Id of the first list node to be inserted.
1062 -- This will still be the first node after the insert operation,
1063 -- since Insert_List_After does not modify the Node_Id values.
1066 Insert_Before (N, M);
1068 -- The insertion does not change the Id's of any of the nodes in
1069 -- the list, and they are still linked, so we can simply loop from
1070 -- the original first node until we meet the node before which the
1071 -- insertion is occurring. Note that this properly handles the case
1072 -- where any of the analyzed nodes insert nodes after themselves,
1073 -- expecting them to get analyzed.
1075 while Node /= N loop
1077 Mark_Rewrite_Insertion (Node);
1081 end Insert_Before_And_Analyze;
1083 -- Version with check(s) suppressed
1085 procedure Insert_Before_And_Analyze
1088 Suppress : Check_Id)
1091 if Suppress = All_Checks then
1093 Svg : constant Suppress_Array := Scope_Suppress;
1095 Scope_Suppress := (others => True);
1096 Insert_Before_And_Analyze (N, M);
1097 Scope_Suppress := Svg;
1102 Svg : constant Boolean := Scope_Suppress (Suppress);
1104 Scope_Suppress (Suppress) := True;
1105 Insert_Before_And_Analyze (N, M);
1106 Scope_Suppress (Suppress) := Svg;
1109 end Insert_Before_And_Analyze;
1111 -----------------------------------
1112 -- Insert_List_After_And_Analyze --
1113 -----------------------------------
1115 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
1116 After : constant Node_Id := Next (N);
1120 if Is_Non_Empty_List (L) then
1122 -- Capture the Node_Id of the first list node to be inserted.
1123 -- This will still be the first node after the insert operation,
1124 -- since Insert_List_After does not modify the Node_Id values.
1127 Insert_List_After (N, L);
1129 -- Now just analyze from the original first node until we get to the
1130 -- successor of the original insertion point (which may be Empty if
1131 -- the insertion point was at the end of the list). Note that this
1132 -- properly handles the case where any of the analyze calls result in
1133 -- the insertion of nodes after the analyzed node (possibly calling
1134 -- this routine recursively).
1136 while Node /= After loop
1138 Mark_Rewrite_Insertion (Node);
1142 end Insert_List_After_And_Analyze;
1144 -- Version with check(s) suppressed
1146 procedure Insert_List_After_And_Analyze
1147 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1150 if Suppress = All_Checks then
1152 Svg : constant Suppress_Array := Scope_Suppress;
1154 Scope_Suppress := (others => True);
1155 Insert_List_After_And_Analyze (N, L);
1156 Scope_Suppress := Svg;
1161 Svg : constant Boolean := Scope_Suppress (Suppress);
1163 Scope_Suppress (Suppress) := True;
1164 Insert_List_After_And_Analyze (N, L);
1165 Scope_Suppress (Suppress) := Svg;
1168 end Insert_List_After_And_Analyze;
1170 ------------------------------------
1171 -- Insert_List_Before_And_Analyze --
1172 ------------------------------------
1174 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
1178 if Is_Non_Empty_List (L) then
1180 -- Capture the Node_Id of the first list node to be inserted. This
1181 -- will still be the first node after the insert operation, since
1182 -- Insert_List_After does not modify the Node_Id values.
1185 Insert_List_Before (N, L);
1187 -- The insertion does not change the Id's of any of the nodes in
1188 -- the list, and they are still linked, so we can simply loop from
1189 -- the original first node until we meet the node before which the
1190 -- insertion is occurring. Note that this properly handles the case
1191 -- where any of the analyzed nodes insert nodes after themselves,
1192 -- expecting them to get analyzed.
1194 while Node /= N loop
1196 Mark_Rewrite_Insertion (Node);
1200 end Insert_List_Before_And_Analyze;
1202 -- Version with check(s) suppressed
1204 procedure Insert_List_Before_And_Analyze
1205 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1208 if Suppress = All_Checks then
1210 Svg : constant Suppress_Array := Scope_Suppress;
1212 Scope_Suppress := (others => True);
1213 Insert_List_Before_And_Analyze (N, L);
1214 Scope_Suppress := Svg;
1219 Svg : constant Boolean := Scope_Suppress (Suppress);
1221 Scope_Suppress (Suppress) := True;
1222 Insert_List_Before_And_Analyze (N, L);
1223 Scope_Suppress (Suppress) := Svg;
1226 end Insert_List_Before_And_Analyze;
1228 -------------------------
1229 -- Is_Check_Suppressed --
1230 -------------------------
1232 function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
1234 Ptr : Suppress_Stack_Entry_Ptr;
1237 -- First search the local entity suppress stack. We search this from the
1238 -- top of the stack down so that we get the innermost entry that applies
1239 -- to this case if there are nested entries.
1241 Ptr := Local_Suppress_Stack_Top;
1242 while Ptr /= null loop
1243 if (Ptr.Entity = Empty or else Ptr.Entity = E)
1244 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1246 return Ptr.Suppress;
1252 -- Now search the global entity suppress table for a matching entry.
1253 -- We also search this from the top down so that if there are multiple
1254 -- pragmas for the same entity, the last one applies (not clear what
1255 -- or whether the RM specifies this handling, but it seems reasonable).
1257 Ptr := Global_Suppress_Stack_Top;
1258 while Ptr /= null loop
1259 if (Ptr.Entity = Empty or else Ptr.Entity = E)
1260 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1262 return Ptr.Suppress;
1268 -- If we did not find a matching entry, then use the normal scope
1269 -- suppress value after all (actually this will be the global setting
1270 -- since it clearly was not overridden at any point). For a predefined
1271 -- check, we test the specific flag. For a user defined check, we check
1272 -- the All_Checks flag.
1274 if C in Predefined_Check_Id then
1275 return Scope_Suppress (C);
1277 return Scope_Suppress (All_Checks);
1279 end Is_Check_Suppressed;
1287 Scope_Stack.Locked := True;
1288 Scope_Stack.Release;
1291 --------------------------------------
1292 -- Push_Global_Suppress_Stack_Entry --
1293 --------------------------------------
1295 procedure Push_Global_Suppress_Stack_Entry
1296 (Entity : Entity_Id;
1301 Global_Suppress_Stack_Top :=
1302 new Suppress_Stack_Entry'
1305 Suppress => Suppress,
1306 Prev => Global_Suppress_Stack_Top,
1307 Next => Suppress_Stack_Entries);
1308 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1311 end Push_Global_Suppress_Stack_Entry;
1313 -------------------------------------
1314 -- Push_Local_Suppress_Stack_Entry --
1315 -------------------------------------
1317 procedure Push_Local_Suppress_Stack_Entry
1318 (Entity : Entity_Id;
1323 Local_Suppress_Stack_Top :=
1324 new Suppress_Stack_Entry'
1327 Suppress => Suppress,
1328 Prev => Local_Suppress_Stack_Top,
1329 Next => Suppress_Stack_Entries);
1330 Suppress_Stack_Entries := Local_Suppress_Stack_Top;
1333 end Push_Local_Suppress_Stack_Entry;
1339 procedure Semantics (Comp_Unit : Node_Id) is
1341 -- The following locations save the corresponding global flags and
1342 -- variables so that they can be restored on completion. This is needed
1343 -- so that calls to Rtsfind start with the proper default values for
1344 -- these variables, and also that such calls do not disturb the settings
1345 -- for units being analyzed at a higher level.
1347 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
1348 S_Full_Analysis : constant Boolean := Full_Analysis;
1349 S_GNAT_Mode : constant Boolean := GNAT_Mode;
1350 S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
1351 S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
1352 S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
1353 S_New_Nodes_OK : constant Int := New_Nodes_OK;
1354 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
1356 Generic_Main : constant Boolean :=
1357 Nkind (Unit (Cunit (Main_Unit)))
1358 in N_Generic_Declaration;
1359 -- If the main unit is generic, every compiled unit, including its
1360 -- context, is compiled with expansion disabled.
1362 Save_Config_Switches : Config_Switches_Type;
1363 -- Variable used to save values of config switches while we analyze the
1364 -- new unit, to be restored on exit for proper recursive behavior.
1366 Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions;
1367 -- Used to save non-partition wide restrictions before processing new
1368 -- unit. All with'ed units are analyzed with config restrictions reset
1369 -- and we need to restore these saved values at the end.
1371 procedure Do_Analyze;
1372 -- Procedure to analyze the compilation unit. This is called more than
1373 -- once when the high level optimizer is activated.
1379 procedure Do_Analyze is
1382 Push_Scope (Standard_Standard);
1383 Scope_Suppress := Suppress_Options;
1385 (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
1387 (Scope_Stack.Last).Is_Active_Stack_Base := True;
1388 Outer_Generic_Scope := Empty;
1390 -- Now analyze the top level compilation unit node
1392 Analyze (Comp_Unit);
1394 -- Check for scope mismatch on exit from compilation
1396 pragma Assert (Current_Scope = Standard_Standard
1397 or else Comp_Unit = Cunit (Main_Unit));
1399 -- Then pop entry for Standard, and pop implicit types
1402 Restore_Scope_Stack;
1405 Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
1407 -- Start of processing for Semantics
1410 if Debug_Unit_Walk then
1411 if Already_Analyzed then
1412 Write_Str ("(done)");
1416 (Get_Cunit_Unit_Number (Comp_Unit),
1422 Compiler_State := Analyzing;
1423 Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
1425 -- Compile predefined units with GNAT_Mode set to True, to properly
1426 -- process the categorization stuff. However, do not set GNAT_Mode
1427 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1428 -- Sequential_IO) as this would prevent pragma Extend_System from being
1429 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1431 -- Cleaner might be to do the kludge at the point of excluding the
1432 -- pragma (do not exclude for renamings ???)
1434 if Is_Predefined_File_Name
1435 (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
1440 if Generic_Main then
1441 Expander_Mode_Save_And_Set (False);
1443 Expander_Mode_Save_And_Set
1444 (Operating_Mode = Generate_Code or Debug_Flag_X);
1447 Full_Analysis := True;
1448 Inside_A_Generic := False;
1449 In_Spec_Expression := False;
1451 Set_Comes_From_Source_Default (False);
1453 -- Save current config switches and reset then appropriately
1455 Save_Opt_Config_Switches (Save_Config_Switches);
1456 Set_Opt_Config_Switches
1457 (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
1458 Current_Sem_Unit = Main_Unit);
1460 -- Save current non-partition-wide restrictions
1462 Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save;
1464 -- For unit in main extended unit, we reset the configuration values
1465 -- for the non-partition-wide restrictions. For other units reset them.
1467 if In_Extended_Main_Source_Unit (Comp_Unit) then
1468 Restore_Config_Cunit_Boolean_Restrictions;
1470 Reset_Cunit_Boolean_Restrictions;
1473 -- Only do analysis of unit that has not already been analyzed
1475 if not Analyzed (Comp_Unit) then
1476 Initialize_Version (Current_Sem_Unit);
1478 Expander_Mode_Save_And_Set (False);
1481 Reset_Analyzed_Flags (Comp_Unit);
1482 Expander_Mode_Restore;
1483 High_Level_Optimize (Comp_Unit);
1487 -- Do analysis, and then append the compilation unit onto the
1488 -- Comp_Unit_List, if appropriate. This is done after analysis,
1489 -- so if this unit depends on some others, they have already been
1490 -- appended. We ignore bodies, except for the main unit itself, and
1491 -- for subprogram bodies that act as specs. We have also to guard
1492 -- against ill-formed subunits that have an improper context.
1496 if Present (Comp_Unit)
1497 and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
1498 and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body
1499 or else not Acts_As_Spec (Comp_Unit))
1500 and then not In_Extended_Main_Source_Unit (Comp_Unit)
1505 -- Initialize if first time
1507 if No (Comp_Unit_List) then
1508 Comp_Unit_List := New_Elmt_List;
1511 Append_Elmt (Comp_Unit, Comp_Unit_List);
1513 if Debug_Unit_Walk then
1514 Write_Str ("Appending ");
1516 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
1521 -- Save indication of dynamic elaboration checks for ALI file
1523 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
1525 -- Restore settings of saved switches to entry values
1527 Current_Sem_Unit := S_Current_Sem_Unit;
1528 Full_Analysis := S_Full_Analysis;
1529 Global_Discard_Names := S_Global_Dis_Names;
1530 GNAT_Mode := S_GNAT_Mode;
1531 In_Spec_Expression := S_In_Spec_Expr;
1532 Inside_A_Generic := S_Inside_A_Generic;
1533 New_Nodes_OK := S_New_Nodes_OK;
1534 Outer_Generic_Scope := S_Outer_Gen_Scope;
1536 Restore_Opt_Config_Switches (Save_Config_Switches);
1538 -- Deal with restore of restrictions
1540 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
1542 Expander_Mode_Restore;
1544 if Debug_Unit_Walk then
1547 if Already_Analyzed then
1548 Write_Str ("(done)");
1552 (Get_Cunit_Unit_Number (Comp_Unit),
1558 ------------------------
1559 -- Walk_Library_Items --
1560 ------------------------
1562 procedure Walk_Library_Items is
1563 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
1564 pragma Pack (Unit_Number_Set);
1566 Main_CU : constant Node_Id := Cunit (Main_Unit);
1568 Seen, Done : Unit_Number_Set := (others => False);
1569 -- Seen (X) is True after we have seen unit X in the walk. This is used
1570 -- to prevent processing the same unit more than once. Done (X) is True
1571 -- after we have fully processed X, and is used only for debugging
1572 -- printouts and assertions.
1574 Do_Main : Boolean := False;
1575 -- Flag to delay processing the main body until after all other units.
1576 -- This is needed because the spec of the main unit may appear in the
1577 -- context of some other unit. We do not want this to force processing
1578 -- of the main body before all other units have been processed.
1580 -- Another circularity pattern occurs when the main unit is a child unit
1581 -- and the body of an ancestor has a with-clause of the main unit or on
1582 -- one of its children. In both cases the body in question has a with-
1583 -- clause on the main unit, and must be excluded from the traversal. In
1584 -- some convoluted cases this may lead to a CodePeer error because the
1585 -- spec of a subprogram declared in an instance within the parent will
1586 -- not be seen in the main unit.
1588 function Depends_On_Main (CU : Node_Id) return Boolean;
1589 -- The body of a unit that is withed by the spec of the main unit may in
1590 -- turn have a with_clause on that spec. In that case do not traverse
1591 -- the body, to prevent loops. It can also happen that the main body has
1592 -- a with_clause on a child, which of course has an implicit with on its
1593 -- parent. It's OK to traverse the child body if the main spec has been
1594 -- processed, otherwise we also have a circularity to avoid.
1596 procedure Do_Action (CU : Node_Id; Item : Node_Id);
1597 -- Calls Action, with some validity checks
1599 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id);
1600 -- Calls Do_Action, first on the units with'ed by this one, then on
1601 -- this unit. If it's an instance body, do the spec first. If it is
1602 -- an instance spec, do the body last.
1604 procedure Do_Withed_Unit (Withed_Unit : Node_Id);
1605 -- Apply Do_Unit_And_Dependents to a unit in a context clause.
1607 procedure Process_Bodies_In_Context (Comp : Node_Id);
1608 -- The main unit and its spec may depend on bodies that contain generics
1609 -- that are instantiated in them. Iterate through the corresponding
1610 -- contexts before processing main (spec/body) itself, to process bodies
1611 -- that may be present, together with their context. The spec of main
1612 -- is processed wherever it appears in the list of units, while the body
1613 -- is processed as the last unit in the list.
1615 ---------------------
1616 -- Depends_On_Main --
1617 ---------------------
1619 function Depends_On_Main (CU : Node_Id) return Boolean is
1621 MCU : constant Node_Id := Unit (Main_CU);
1624 CL := First (Context_Items (CU));
1626 -- Problem does not arise with main subprograms
1629 not Nkind_In (MCU, N_Package_Body, N_Package_Declaration)
1634 while Present (CL) loop
1635 if Nkind (CL) = N_With_Clause
1636 and then Library_Unit (CL) = Main_CU
1637 and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL)))
1646 end Depends_On_Main;
1652 procedure Do_Action (CU : Node_Id; Item : Node_Id) is
1654 -- This calls Action at the end. All the preceding code is just
1655 -- assertions and debugging output.
1657 pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
1659 case Nkind (Item) is
1660 when N_Generic_Subprogram_Declaration |
1661 N_Generic_Package_Declaration |
1662 N_Package_Declaration |
1663 N_Subprogram_Declaration |
1664 N_Subprogram_Renaming_Declaration |
1665 N_Package_Renaming_Declaration |
1666 N_Generic_Function_Renaming_Declaration |
1667 N_Generic_Package_Renaming_Declaration |
1668 N_Generic_Procedure_Renaming_Declaration =>
1674 when N_Package_Body =>
1676 -- Package bodies are processed separately if the main unit
1681 when N_Subprogram_Body =>
1683 -- A subprogram body must be the main unit
1685 pragma Assert (Acts_As_Spec (CU)
1686 or else CU = Cunit (Main_Unit));
1689 when N_Function_Instantiation |
1690 N_Procedure_Instantiation |
1691 N_Package_Instantiation =>
1693 -- Can only happen if some generic body (needed for gnat2scil
1694 -- traversal, but not by GNAT) is not available, ignore.
1698 -- All other cases cannot happen
1701 pragma Assert (False, "subunit");
1705 pragma Assert (False);
1709 if Present (CU) then
1710 pragma Assert (Item /= Stand.Standard_Package_Node);
1711 pragma Assert (Item = Unit (CU));
1714 Unit_Num : constant Unit_Number_Type :=
1715 Get_Cunit_Unit_Number (CU);
1717 procedure Assert_Done (Withed_Unit : Node_Id);
1718 -- Assert Withed_Unit is already Done, unless it's a body. It
1719 -- might seem strange for a with_clause to refer to a body, but
1720 -- this happens in the case of a generic instantiation, which
1721 -- gets transformed into the instance body (and the instance
1722 -- spec is also created). With clauses pointing to the
1723 -- instantiation end up pointing to the instance body.
1729 procedure Assert_Done (Withed_Unit : Node_Id) is
1731 if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
1733 (Unit (Withed_Unit),
1734 N_Generic_Package_Declaration,
1736 N_Package_Renaming_Declaration,
1740 (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit)));
1741 Write_Str (" not yet walked!");
1743 if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
1744 Write_Str (" (self-ref)");
1749 pragma Assert (False);
1754 procedure Assert_Withed_Units_Done is
1755 new Walk_Withs (Assert_Done);
1758 if Debug_Unit_Walk then
1759 Write_Unit_Info (Unit_Num, Item, Withs => True);
1762 -- Main unit should come last, except in the case where we
1763 -- skipped System_Aux_Id, in which case we missed the things it
1764 -- depends on, and in the case of parent bodies if present.
1767 (not Done (Main_Unit)
1768 or else Present (System_Aux_Id)
1769 or else Nkind (Item) = N_Package_Body);
1771 -- We shouldn't do the same thing twice
1773 pragma Assert (not Done (Unit_Num));
1775 -- Everything we depend upon should already be done
1778 (Assert_Withed_Units_Done (CU, Include_Limited => False));
1782 -- Must be Standard, which has no entry in the units table
1784 pragma Assert (Item = Stand.Standard_Package_Node);
1786 if Debug_Unit_Walk then
1787 Write_Line ("Standard");
1794 --------------------
1795 -- Do_Withed_Unit --
1796 --------------------
1798 procedure Do_Withed_Unit (Withed_Unit : Node_Id) is
1800 Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit));
1802 -- If the unit in the with_clause is a generic instance, the clause
1803 -- now denotes the instance body. Traverse the corresponding spec
1804 -- because there may be no other dependence that will force the
1805 -- traversal of its own context.
1807 if Nkind (Unit (Withed_Unit)) = N_Package_Body
1808 and then Is_Generic_Instance
1809 (Defining_Entity (Unit (Library_Unit (Withed_Unit))))
1811 Do_Withed_Unit (Library_Unit (Withed_Unit));
1815 ----------------------------
1816 -- Do_Unit_And_Dependents --
1817 ----------------------------
1819 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
1820 Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU);
1822 Body_U : Unit_Number_Type;
1823 Parent_CU : Node_Id;
1825 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
1828 if not Seen (Unit_Num) then
1830 -- Process the with clauses
1832 Do_Withed_Units (CU, Include_Limited => False);
1834 -- Process the unit if it is a spec or the main unit, if it
1835 -- has no previous spec or we have done all other units.
1837 if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
1838 or else Acts_As_Spec (CU)
1840 if CU = Cunit (Main_Unit)
1841 and then not Do_Main
1843 Seen (Unit_Num) := False;
1846 Seen (Unit_Num) := True;
1848 if CU = Library_Unit (Main_CU) then
1849 Process_Bodies_In_Context (CU);
1851 -- If main is a child unit, examine parent unit contexts
1852 -- to see if they include instantiated units. Also, if
1853 -- the parent itself is an instance, process its body
1854 -- because it may contain subprograms that are called
1855 -- in the main unit.
1857 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
1858 Child := Cunit_Entity (Main_Unit);
1859 while Is_Child_Unit (Child) loop
1862 (Get_Cunit_Entity_Unit_Number (Scope (Child)));
1863 Process_Bodies_In_Context (Parent_CU);
1865 if Nkind (Unit (Parent_CU)) = N_Package_Body
1867 Nkind (Original_Node (Unit (Parent_CU)))
1868 = N_Package_Instantiation
1870 not Seen (Get_Cunit_Unit_Number (Parent_CU))
1872 Body_U := Get_Cunit_Unit_Number (Parent_CU);
1873 Seen (Body_U) := True;
1874 Do_Action (Parent_CU, Unit (Parent_CU));
1875 Done (Body_U) := True;
1878 Child := Scope (Child);
1883 Do_Action (CU, Item);
1884 Done (Unit_Num) := True;
1888 end Do_Unit_And_Dependents;
1890 -------------------------------
1891 -- Process_Bodies_In_Context --
1892 -------------------------------
1894 procedure Process_Bodies_In_Context (Comp : Node_Id) is
1896 Body_U : Unit_Number_Type;
1900 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
1902 -- Start of processing for Process_Bodies_In_Context
1905 Clause := First (Context_Items (Comp));
1906 while Present (Clause) loop
1907 if Nkind (Clause) = N_With_Clause then
1908 Spec := Library_Unit (Clause);
1909 Body_CU := Library_Unit (Spec);
1911 -- If we are processing the spec of the main unit, load bodies
1912 -- only if the with_clause indicates that it forced the loading
1913 -- of the body for a generic instantiation. Note that bodies of
1914 -- parents that are instances have been loaded already.
1916 if Present (Body_CU)
1917 and then Body_CU /= Cunit (Main_Unit)
1918 and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body
1919 and then (Nkind (Unit (Comp)) /= N_Package_Declaration
1920 or else Present (Withed_Body (Clause)))
1922 Body_U := Get_Cunit_Unit_Number (Body_CU);
1924 if not Seen (Body_U)
1925 and then not Depends_On_Main (Body_CU)
1927 Seen (Body_U) := True;
1928 Do_Withed_Units (Body_CU, Include_Limited => False);
1929 Do_Action (Body_CU, Unit (Body_CU));
1930 Done (Body_U) := True;
1937 end Process_Bodies_In_Context;
1939 -- Local Declarations
1943 -- Start of processing for Walk_Library_Items
1946 if Debug_Unit_Walk then
1947 Write_Line ("Walk_Library_Items:");
1951 -- Do Standard first, then walk the Comp_Unit_List
1953 Do_Action (Empty, Standard_Package_Node);
1955 -- First place the context of all instance bodies on the corresponding
1956 -- spec, because it may be needed to analyze the code at the place of
1957 -- the instantiation.
1959 Cur := First_Elmt (Comp_Unit_List);
1960 while Present (Cur) loop
1962 CU : constant Node_Id := Node (Cur);
1963 N : constant Node_Id := Unit (CU);
1966 if Nkind (N) = N_Package_Body
1967 and then Is_Generic_Instance (Defining_Entity (N))
1970 (Context_Items (CU), Context_Items (Library_Unit (CU)));
1977 -- Now traverse compilation units (specs) in order
1979 Cur := First_Elmt (Comp_Unit_List);
1980 while Present (Cur) loop
1982 CU : constant Node_Id := Node (Cur);
1983 N : constant Node_Id := Unit (CU);
1987 pragma Assert (Nkind (CU) = N_Compilation_Unit);
1991 -- If it is a subprogram body, process it if it has no
1994 -- If it's a package body, ignore it, unless it is a body
1995 -- created for an instance that is the main unit. In the case
1996 -- of subprograms, the body is the wrapper package. In case of
1997 -- a package, the original file carries the body, and the spec
1998 -- appears as a later entry in the units list.
2000 -- Otherwise bodies appear in the list only because of inlining
2001 -- or instantiations, and they are processed only if relevant.
2002 -- The flag Withed_Body on a context clause indicates that a
2003 -- unit contains an instantiation that may be needed later,
2004 -- and therefore the body that contains the generic body (and
2005 -- its context) must be traversed immediately after the
2006 -- corresponding spec (see Do_Unit_And_Dependents).
2008 -- The main unit itself is processed separately after all other
2009 -- specs, and relevant bodies are examined in Process_Main.
2011 when N_Subprogram_Body =>
2012 if Acts_As_Spec (N) then
2013 Do_Unit_And_Dependents (CU, N);
2016 when N_Package_Body =>
2018 and then Nkind (Original_Node (Unit (Main_CU))) in
2019 N_Generic_Instantiation
2020 and then Present (Library_Unit (Main_CU))
2022 Do_Unit_And_Dependents
2023 (Library_Unit (Main_CU),
2024 Unit (Library_Unit (Main_CU)));
2027 -- It's a spec, process it, and the units it depends on,
2028 -- unless it is a descendent of the main unit. This can
2029 -- happen when the body of a parent depends on some other
2033 Par := Scope (Defining_Entity (Unit (CU)));
2035 if Is_Child_Unit (Defining_Entity (Unit (CU))) then
2037 and then Par /= Standard_Standard
2038 and then Par /= Cunit_Entity (Main_Unit)
2044 if Par /= Cunit_Entity (Main_Unit) then
2045 Do_Unit_And_Dependents (CU, N);
2053 -- Now process package bodies on which main depends, followed by bodies
2054 -- of parents, if present, and finally main itself.
2056 if not Done (Main_Unit) then
2059 Process_Main : declare
2060 Parent_CU : Node_Id;
2062 Body_U : Unit_Number_Type;
2065 function Is_Subunit_Of_Main (U : Node_Id) return Boolean;
2066 -- If the main unit has subunits, their context may include
2067 -- bodies that are needed in the body of main. We must examine
2068 -- the context of the subunits, which are otherwise not made
2069 -- explicit in the main unit.
2071 ------------------------
2072 -- Is_Subunit_Of_Main --
2073 ------------------------
2075 function Is_Subunit_Of_Main (U : Node_Id) return Boolean is
2081 Lib := Library_Unit (U);
2082 return Nkind (Unit (U)) = N_Subunit
2084 (Lib = Cunit (Main_Unit)
2085 or else Is_Subunit_Of_Main (Lib));
2087 end Is_Subunit_Of_Main;
2089 -- Start of processing for Process_Main
2092 Process_Bodies_In_Context (Main_CU);
2094 for Unit_Num in Done'Range loop
2095 if Is_Subunit_Of_Main (Cunit (Unit_Num)) then
2096 Process_Bodies_In_Context (Cunit (Unit_Num));
2100 -- If the main unit is a child unit, parent bodies may be present
2101 -- because they export instances or inlined subprograms. Check for
2102 -- presence of these, which are not present in context clauses.
2103 -- Note that if the parents are instances, their bodies have been
2104 -- processed before the main spec, because they may be needed
2105 -- therein, so the following loop only affects non-instances.
2107 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
2108 Child := Cunit_Entity (Main_Unit);
2109 while Is_Child_Unit (Child) loop
2111 Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child)));
2112 Body_CU := Library_Unit (Parent_CU);
2114 if Present (Body_CU)
2115 and then not Seen (Get_Cunit_Unit_Number (Body_CU))
2116 and then not Depends_On_Main (Body_CU)
2118 Body_U := Get_Cunit_Unit_Number (Body_CU);
2119 Seen (Body_U) := True;
2120 Do_Action (Body_CU, Unit (Body_CU));
2121 Done (Body_U) := True;
2124 Child := Scope (Child);
2128 Do_Action (Main_CU, Unit (Main_CU));
2129 Done (Main_Unit) := True;
2133 if Debug_Unit_Walk then
2134 if Done /= (Done'Range => True) then
2136 Write_Line ("Ignored units:");
2140 for Unit_Num in Done'Range loop
2141 if not Done (Unit_Num) then
2143 (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True);
2151 pragma Assert (Done (Main_Unit));
2153 if Debug_Unit_Walk then
2155 Write_Line ("end Walk_Library_Items.");
2157 end Walk_Library_Items;
2163 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is
2164 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2165 pragma Assert (Nkind (Unit (CU)) /= N_Subunit);
2167 procedure Walk_Immediate is new Walk_Withs_Immediate (Action);
2170 -- First walk the withs immediately on the library item
2172 Walk_Immediate (CU, Include_Limited);
2174 -- For a body, we must also check for any subunits which belong to it
2175 -- and which have context clauses of their own, since these with'ed
2176 -- units are part of its own dependencies.
2178 if Nkind (Unit (CU)) in N_Unit_Body then
2179 for S in Main_Unit .. Last_Unit loop
2181 -- We are only interested in subunits. For preproc. data and def.
2182 -- files, Cunit is Empty, so we need to test that first.
2184 if Cunit (S) /= Empty
2185 and then Nkind (Unit (Cunit (S))) = N_Subunit
2191 Pnode := Library_Unit (Cunit (S));
2193 -- In -gnatc mode, the errors in the subunits will not have
2194 -- been recorded, but the analysis of the subunit may have
2195 -- failed, so just quit.
2201 -- Find ultimate parent of the subunit
2203 while Nkind (Unit (Pnode)) = N_Subunit loop
2204 Pnode := Library_Unit (Pnode);
2207 -- See if it belongs to current unit, and if so, include its
2208 -- with_clauses. Do not process main unit prematurely.
2210 if Pnode = CU and then CU /= Cunit (Main_Unit) then
2211 Walk_Immediate (Cunit (S), Include_Limited);
2219 --------------------------
2220 -- Walk_Withs_Immediate --
2221 --------------------------
2223 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is
2224 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2226 Context_Item : Node_Id;
2231 Context_Item := First (Context_Items (CU));
2232 while Present (Context_Item) loop
2233 if Nkind (Context_Item) = N_With_Clause
2234 and then (Include_Limited
2235 or else not Limited_Present (Context_Item))
2237 Lib_Unit := Library_Unit (Context_Item);
2240 -- If the context item indicates that a package body is needed
2241 -- because of an instantiation in CU, traverse the body now, even
2242 -- if CU is not related to the main unit. If the generic itself
2243 -- appears in a package body, the context item is this body, and
2244 -- it already appears in the traversal order, so we only need to
2245 -- examine the case of a context item being a package declaration.
2247 if Present (Withed_Body (Context_Item))
2248 and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration
2249 and then Present (Corresponding_Body (Unit (Lib_Unit)))
2253 (Unit_Declaration_Node
2254 (Corresponding_Body (Unit (Lib_Unit))));
2256 -- A body may have an implicit with on its own spec, in which
2257 -- case we must ignore this context item to prevent looping.
2259 if Unit (CU) /= Unit (Body_CU) then
2265 Context_Item := Next (Context_Item);
2267 end Walk_Withs_Immediate;
2269 ---------------------
2270 -- Write_Unit_Info --
2271 ---------------------
2273 procedure Write_Unit_Info
2274 (Unit_Num : Unit_Number_Type;
2276 Prefix : String := "";
2277 Withs : Boolean := False)
2281 Write_Unit_Name (Unit_Name (Unit_Num));
2282 Write_Str (", unit ");
2283 Write_Int (Int (Unit_Num));
2285 Write_Int (Int (Item));
2287 Write_Str (Node_Kind'Image (Nkind (Item)));
2289 if Item /= Original_Node (Item) then
2290 Write_Str (", orig = ");
2291 Write_Int (Int (Original_Node (Item)));
2293 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
2298 -- Skip the rest if we're not supposed to print the withs
2305 Context_Item : Node_Id;
2308 Context_Item := First (Context_Items (Cunit (Unit_Num)));
2309 while Present (Context_Item)
2310 and then (Nkind (Context_Item) /= N_With_Clause
2311 or else Limited_Present (Context_Item))
2313 Context_Item := Next (Context_Item);
2316 if Present (Context_Item) then
2318 Write_Line ("withs:");
2321 while Present (Context_Item) loop
2322 if Nkind (Context_Item) = N_With_Clause
2323 and then not Limited_Present (Context_Item)
2325 pragma Assert (Present (Library_Unit (Context_Item)));
2328 (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
2330 if Implicit_With (Context_Item) then
2331 Write_Str (" -- implicit");
2337 Context_Item := Next (Context_Item);
2341 Write_Line ("end withs");
2345 end Write_Unit_Info;