1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- You should have received a copy of the GNU General Public License along --
19 -- with this program; see file COPYING3. If not see --
20 -- <http://www.gnu.org/licenses/>. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Debug_A; use Debug_A;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Expander; use Expander;
33 with Fname; use Fname;
36 with Lib.Load; use Lib.Load;
37 with Nlists; use Nlists;
38 with Output; use Output;
39 with Sem_Attr; use Sem_Attr;
40 with Sem_Ch2; use Sem_Ch2;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch4; use Sem_Ch4;
43 with Sem_Ch5; use Sem_Ch5;
44 with Sem_Ch6; use Sem_Ch6;
45 with Sem_Ch7; use Sem_Ch7;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Ch9; use Sem_Ch9;
48 with Sem_Ch10; use Sem_Ch10;
49 with Sem_Ch11; use Sem_Ch11;
50 with Sem_Ch12; use Sem_Ch12;
51 with Sem_Ch13; use Sem_Ch13;
52 with Sem_Prag; use Sem_Prag;
53 with Sem_Util; use Sem_Util;
54 with Sinfo; use Sinfo;
55 with Stand; use Stand;
56 with Uintp; use Uintp;
57 with Uname; use Uname;
59 with Unchecked_Deallocation;
61 pragma Warnings (Off, Sem_Util);
62 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
66 Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW;
67 -- Controls debugging printouts for Walk_Library_Items
69 Outer_Generic_Scope : Entity_Id := Empty;
70 -- Global reference to the outer scope that is generic. In a non
71 -- generic context, it is empty. At the moment, it is only used
72 -- for avoiding freezing of external references in generics.
74 Comp_Unit_List : Elist_Id := No_Elist;
75 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
76 -- processed by Semantics, in an appropriate order. Initialized to
77 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
78 -- to New_Elmt_List on first use.
81 with procedure Action (Withed_Unit : Node_Id);
82 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean);
83 -- Walk all the with clauses of CU, and call Action for the with'ed
84 -- unit. Ignore limited withs, unless Include_Limited is True.
85 -- CU must be an N_Compilation_Unit.
88 with procedure Action (Withed_Unit : Node_Id);
89 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean);
90 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
91 -- of this unit, since they count as dependences on their parent library
92 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
94 procedure Write_Unit_Info
95 (Unit_Num : Unit_Number_Type;
97 Prefix : String := "";
98 Withs : Boolean := False);
99 -- Print out debugging information about the unit. Prefix precedes the rest
100 -- of the printout. If Withs is True, we print out units with'ed by this
101 -- unit (not counting limited withs).
107 procedure Analyze (N : Node_Id) is
109 Debug_A_Entry ("analyzing ", N);
111 -- Immediate return if already analyzed
114 Debug_A_Exit ("analyzing ", N, " (done, analyzed already)");
118 -- Otherwise processing depends on the node kind
122 when N_Abort_Statement =>
123 Analyze_Abort_Statement (N);
125 when N_Abstract_Subprogram_Declaration =>
126 Analyze_Abstract_Subprogram_Declaration (N);
128 when N_Accept_Alternative =>
129 Analyze_Accept_Alternative (N);
131 when N_Accept_Statement =>
132 Analyze_Accept_Statement (N);
135 Analyze_Aggregate (N);
138 Analyze_Allocator (N);
141 Analyze_Short_Circuit (N);
143 when N_Assignment_Statement =>
144 Analyze_Assignment (N);
146 when N_Asynchronous_Select =>
147 Analyze_Asynchronous_Select (N);
150 Analyze_At_Clause (N);
152 when N_Attribute_Reference =>
153 Analyze_Attribute (N);
155 when N_Attribute_Definition_Clause =>
156 Analyze_Attribute_Definition_Clause (N);
158 when N_Block_Statement =>
159 Analyze_Block_Statement (N);
161 when N_Case_Expression =>
162 Analyze_Case_Expression (N);
164 when N_Case_Statement =>
165 Analyze_Case_Statement (N);
167 when N_Character_Literal =>
168 Analyze_Character_Literal (N);
170 when N_Code_Statement =>
171 Analyze_Code_Statement (N);
173 when N_Compilation_Unit =>
174 Analyze_Compilation_Unit (N);
176 when N_Component_Declaration =>
177 Analyze_Component_Declaration (N);
179 when N_Conditional_Expression =>
180 Analyze_Conditional_Expression (N);
182 when N_Conditional_Entry_Call =>
183 Analyze_Conditional_Entry_Call (N);
185 when N_Delay_Alternative =>
186 Analyze_Delay_Alternative (N);
188 when N_Delay_Relative_Statement =>
189 Analyze_Delay_Relative (N);
191 when N_Delay_Until_Statement =>
192 Analyze_Delay_Until (N);
195 Analyze_Entry_Body (N);
197 when N_Entry_Body_Formal_Part =>
198 Analyze_Entry_Body_Formal_Part (N);
200 when N_Entry_Call_Alternative =>
201 Analyze_Entry_Call_Alternative (N);
203 when N_Entry_Declaration =>
204 Analyze_Entry_Declaration (N);
206 when N_Entry_Index_Specification =>
207 Analyze_Entry_Index_Specification (N);
209 when N_Enumeration_Representation_Clause =>
210 Analyze_Enumeration_Representation_Clause (N);
212 when N_Exception_Declaration =>
213 Analyze_Exception_Declaration (N);
215 when N_Exception_Renaming_Declaration =>
216 Analyze_Exception_Renaming (N);
218 when N_Exit_Statement =>
219 Analyze_Exit_Statement (N);
221 when N_Expanded_Name =>
222 Analyze_Expanded_Name (N);
224 when N_Explicit_Dereference =>
225 Analyze_Explicit_Dereference (N);
227 when N_Expression_With_Actions =>
228 Analyze_Expression_With_Actions (N);
230 when N_Extended_Return_Statement =>
231 Analyze_Extended_Return_Statement (N);
233 when N_Extension_Aggregate =>
234 Analyze_Aggregate (N);
236 when N_Formal_Object_Declaration =>
237 Analyze_Formal_Object_Declaration (N);
239 when N_Formal_Package_Declaration =>
240 Analyze_Formal_Package (N);
242 when N_Formal_Subprogram_Declaration =>
243 Analyze_Formal_Subprogram (N);
245 when N_Formal_Type_Declaration =>
246 Analyze_Formal_Type_Declaration (N);
248 when N_Free_Statement =>
249 Analyze_Free_Statement (N);
251 when N_Freeze_Entity =>
252 Analyze_Freeze_Entity (N);
254 when N_Full_Type_Declaration =>
255 Analyze_Type_Declaration (N);
257 when N_Function_Call =>
258 Analyze_Function_Call (N);
260 when N_Function_Instantiation =>
261 Analyze_Function_Instantiation (N);
263 when N_Generic_Function_Renaming_Declaration =>
264 Analyze_Generic_Function_Renaming (N);
266 when N_Generic_Package_Declaration =>
267 Analyze_Generic_Package_Declaration (N);
269 when N_Generic_Package_Renaming_Declaration =>
270 Analyze_Generic_Package_Renaming (N);
272 when N_Generic_Procedure_Renaming_Declaration =>
273 Analyze_Generic_Procedure_Renaming (N);
275 when N_Generic_Subprogram_Declaration =>
276 Analyze_Generic_Subprogram_Declaration (N);
278 when N_Goto_Statement =>
279 Analyze_Goto_Statement (N);
281 when N_Handled_Sequence_Of_Statements =>
282 Analyze_Handled_Statements (N);
285 Analyze_Identifier (N);
287 when N_If_Statement =>
288 Analyze_If_Statement (N);
290 when N_Implicit_Label_Declaration =>
291 Analyze_Implicit_Label_Declaration (N);
294 Analyze_Membership_Op (N);
296 when N_Incomplete_Type_Declaration =>
297 Analyze_Incomplete_Type_Decl (N);
299 when N_Indexed_Component =>
300 Analyze_Indexed_Component_Form (N);
302 when N_Integer_Literal =>
303 Analyze_Integer_Literal (N);
305 when N_Itype_Reference =>
306 Analyze_Itype_Reference (N);
311 when N_Loop_Statement =>
312 Analyze_Loop_Statement (N);
315 Analyze_Membership_Op (N);
320 when N_Null_Statement =>
321 Analyze_Null_Statement (N);
323 when N_Number_Declaration =>
324 Analyze_Number_Declaration (N);
326 when N_Object_Declaration =>
327 Analyze_Object_Declaration (N);
329 when N_Object_Renaming_Declaration =>
330 Analyze_Object_Renaming (N);
332 when N_Operator_Symbol =>
333 Analyze_Operator_Symbol (N);
336 Analyze_Unary_Op (N);
339 Analyze_Arithmetic_Op (N);
342 Analyze_Logical_Op (N);
345 Analyze_Concatenation (N);
348 Analyze_Arithmetic_Op (N);
351 Analyze_Equality_Op (N);
354 Analyze_Arithmetic_Op (N);
357 Analyze_Comparison_Op (N);
360 Analyze_Comparison_Op (N);
363 Analyze_Comparison_Op (N);
366 Analyze_Comparison_Op (N);
369 Analyze_Unary_Op (N);
372 Analyze_Arithmetic_Op (N);
374 when N_Op_Multiply =>
375 Analyze_Arithmetic_Op (N);
378 Analyze_Equality_Op (N);
381 Analyze_Negation (N);
384 Analyze_Logical_Op (N);
387 Analyze_Unary_Op (N);
390 Analyze_Arithmetic_Op (N);
392 when N_Op_Rotate_Left =>
393 Analyze_Arithmetic_Op (N);
395 when N_Op_Rotate_Right =>
396 Analyze_Arithmetic_Op (N);
398 when N_Op_Shift_Left =>
399 Analyze_Arithmetic_Op (N);
401 when N_Op_Shift_Right =>
402 Analyze_Arithmetic_Op (N);
404 when N_Op_Shift_Right_Arithmetic =>
405 Analyze_Arithmetic_Op (N);
407 when N_Op_Subtract =>
408 Analyze_Arithmetic_Op (N);
411 Analyze_Logical_Op (N);
414 Analyze_Short_Circuit (N);
416 when N_Others_Choice =>
417 Analyze_Others_Choice (N);
419 when N_Package_Body =>
420 Analyze_Package_Body (N);
422 when N_Package_Body_Stub =>
423 Analyze_Package_Body_Stub (N);
425 when N_Package_Declaration =>
426 Analyze_Package_Declaration (N);
428 when N_Package_Instantiation =>
429 Analyze_Package_Instantiation (N);
431 when N_Package_Renaming_Declaration =>
432 Analyze_Package_Renaming (N);
434 when N_Package_Specification =>
435 Analyze_Package_Specification (N);
437 when N_Parameter_Association =>
438 Analyze_Parameter_Association (N);
443 when N_Private_Extension_Declaration =>
444 Analyze_Private_Extension_Declaration (N);
446 when N_Private_Type_Declaration =>
447 Analyze_Private_Type_Declaration (N);
449 when N_Procedure_Call_Statement =>
450 Analyze_Procedure_Call (N);
452 when N_Procedure_Instantiation =>
453 Analyze_Procedure_Instantiation (N);
455 when N_Protected_Body =>
456 Analyze_Protected_Body (N);
458 when N_Protected_Body_Stub =>
459 Analyze_Protected_Body_Stub (N);
461 when N_Protected_Definition =>
462 Analyze_Protected_Definition (N);
464 when N_Protected_Type_Declaration =>
465 Analyze_Protected_Type (N);
467 when N_Qualified_Expression =>
468 Analyze_Qualified_Expression (N);
470 when N_Raise_Statement =>
471 Analyze_Raise_Statement (N);
473 when N_Raise_xxx_Error =>
474 Analyze_Raise_xxx_Error (N);
479 when N_Range_Constraint =>
480 Analyze_Range (Range_Expression (N));
482 when N_Real_Literal =>
483 Analyze_Real_Literal (N);
485 when N_Record_Representation_Clause =>
486 Analyze_Record_Representation_Clause (N);
489 Analyze_Reference (N);
491 when N_Requeue_Statement =>
494 when N_Simple_Return_Statement =>
495 Analyze_Simple_Return_Statement (N);
497 when N_Selected_Component =>
498 Find_Selected_Component (N);
499 -- ??? why not Analyze_Selected_Component, needs comments
501 when N_Selective_Accept =>
502 Analyze_Selective_Accept (N);
504 when N_Single_Protected_Declaration =>
505 Analyze_Single_Protected (N);
507 when N_Single_Task_Declaration =>
508 Analyze_Single_Task (N);
513 when N_String_Literal =>
514 Analyze_String_Literal (N);
516 when N_Subprogram_Body =>
517 Analyze_Subprogram_Body (N);
519 when N_Subprogram_Body_Stub =>
520 Analyze_Subprogram_Body_Stub (N);
522 when N_Subprogram_Declaration =>
523 Analyze_Subprogram_Declaration (N);
525 when N_Subprogram_Info =>
526 Analyze_Subprogram_Info (N);
528 when N_Subprogram_Renaming_Declaration =>
529 Analyze_Subprogram_Renaming (N);
531 when N_Subtype_Declaration =>
532 Analyze_Subtype_Declaration (N);
534 when N_Subtype_Indication =>
535 Analyze_Subtype_Indication (N);
541 Analyze_Task_Body (N);
543 when N_Task_Body_Stub =>
544 Analyze_Task_Body_Stub (N);
546 when N_Task_Definition =>
547 Analyze_Task_Definition (N);
549 when N_Task_Type_Declaration =>
550 Analyze_Task_Type (N);
552 when N_Terminate_Alternative =>
553 Analyze_Terminate_Alternative (N);
555 when N_Timed_Entry_Call =>
556 Analyze_Timed_Entry_Call (N);
558 when N_Triggering_Alternative =>
559 Analyze_Triggering_Alternative (N);
561 when N_Type_Conversion =>
562 Analyze_Type_Conversion (N);
564 when N_Unchecked_Expression =>
565 Analyze_Unchecked_Expression (N);
567 when N_Unchecked_Type_Conversion =>
568 Analyze_Unchecked_Type_Conversion (N);
570 when N_Use_Package_Clause =>
571 Analyze_Use_Package (N);
573 when N_Use_Type_Clause =>
574 Analyze_Use_Type (N);
576 when N_Validate_Unchecked_Conversion =>
579 when N_Variant_Part =>
580 Analyze_Variant_Part (N);
582 when N_With_Clause =>
583 Analyze_With_Clause (N);
585 -- A call to analyze the Empty node is an error, but most likely
586 -- it is an error caused by an attempt to analyze a malformed
587 -- piece of tree caused by some other error, so if there have
588 -- been any other errors, we just ignore it, otherwise it is
589 -- a real internal error which we complain about.
591 -- We must also consider the case of call to a runtime function
592 -- that is not available in the configurable runtime.
595 pragma Assert (Serious_Errors_Detected /= 0
596 or else Configurable_Run_Time_Violations /= 0);
599 -- A call to analyze the error node is simply ignored, to avoid
600 -- causing cascaded errors (happens of course only in error cases)
605 -- Push/Pop nodes normally don't come through an analyze call. An
606 -- exception is the dummy ones bracketing a subprogram body. In any
607 -- case there is nothing to be done to analyze such nodes.
609 when N_Push_Pop_xxx_Label =>
612 -- SCIL nodes don't need analysis because they are decorated when
613 -- they are built. They are added to the tree by Insert_Actions and
614 -- the call to analyze them is generated when the full list is
618 N_SCIL_Dispatch_Table_Object_Init |
619 N_SCIL_Dispatch_Table_Tag_Init |
620 N_SCIL_Dispatching_Call |
621 N_SCIL_Membership_Test |
625 -- For the remaining node types, we generate compiler abort, because
626 -- these nodes are always analyzed within the Sem_Chn routines and
627 -- there should never be a case of making a call to the main Analyze
628 -- routine for these node kinds. For example, an N_Access_Definition
629 -- node appears only in the context of a type declaration, and is
630 -- processed by the analyze routine for type declarations.
634 N_Access_Definition |
635 N_Access_Function_Definition |
636 N_Access_Procedure_Definition |
637 N_Access_To_Object_Definition |
638 N_Case_Expression_Alternative |
639 N_Case_Statement_Alternative |
640 N_Compilation_Unit_Aux |
641 N_Component_Association |
643 N_Component_Definition |
645 N_Constrained_Array_Definition |
646 N_Decimal_Fixed_Point_Definition |
647 N_Defining_Character_Literal |
648 N_Defining_Identifier |
649 N_Defining_Operator_Symbol |
650 N_Defining_Program_Unit_Name |
652 N_Derived_Type_Definition |
654 N_Digits_Constraint |
655 N_Discriminant_Association |
656 N_Discriminant_Specification |
658 N_Entry_Call_Statement |
659 N_Enumeration_Type_Definition |
660 N_Exception_Handler |
661 N_Floating_Point_Definition |
662 N_Formal_Decimal_Fixed_Point_Definition |
663 N_Formal_Derived_Type_Definition |
664 N_Formal_Discrete_Type_Definition |
665 N_Formal_Floating_Point_Definition |
666 N_Formal_Modular_Type_Definition |
667 N_Formal_Ordinary_Fixed_Point_Definition |
668 N_Formal_Private_Type_Definition |
669 N_Formal_Signed_Integer_Type_Definition |
670 N_Function_Specification |
671 N_Generic_Association |
672 N_Index_Or_Discriminant_Constraint |
674 N_Loop_Parameter_Specification |
676 N_Modular_Type_Definition |
677 N_Ordinary_Fixed_Point_Definition |
678 N_Parameter_Specification |
679 N_Pragma_Argument_Association |
680 N_Procedure_Specification |
681 N_Real_Range_Specification |
682 N_Record_Definition |
683 N_Signed_Integer_Type_Definition |
684 N_Unconstrained_Array_Definition |
692 Debug_A_Exit ("analyzing ", N, " (done)");
694 -- Now that we have analyzed the node, we call the expander to perform
695 -- possible expansion. We skip this for subexpressions, because we don't
696 -- have the type yet, and the expander will need to know the type before
697 -- it can do its job. For subexpression nodes, the call to the expander
698 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
699 -- which can appear in a statement context, and needs expanding now in
700 -- the case (distinguished by Etype, as documented in Sinfo).
702 -- The Analyzed flag is also set at this point for non-subexpression
703 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
704 -- since resolution and expansion have not yet been completed). Note
705 -- that for N_Raise_xxx_Error we have to distinguish the expression
706 -- case from the statement case.
708 if Nkind (N) not in N_Subexpr
709 or else (Nkind (N) in N_Raise_xxx_Error
710 and then Etype (N) = Standard_Void_Type)
716 -- Version with check(s) suppressed
718 procedure Analyze (N : Node_Id; Suppress : Check_Id) is
720 if Suppress = All_Checks then
722 Svg : constant Suppress_Array := Scope_Suppress;
724 Scope_Suppress := (others => True);
726 Scope_Suppress := Svg;
731 Svg : constant Boolean := Scope_Suppress (Suppress);
733 Scope_Suppress (Suppress) := True;
735 Scope_Suppress (Suppress) := Svg;
744 procedure Analyze_List (L : List_Id) is
749 while Present (Node) loop
755 -- Version with check(s) suppressed
757 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
759 if Suppress = All_Checks then
761 Svg : constant Suppress_Array := Scope_Suppress;
763 Scope_Suppress := (others => True);
765 Scope_Suppress := Svg;
770 Svg : constant Boolean := Scope_Suppress (Suppress);
772 Scope_Suppress (Suppress) := True;
774 Scope_Suppress (Suppress) := Svg;
779 --------------------------
780 -- Copy_Suppress_Status --
781 --------------------------
783 procedure Copy_Suppress_Status
789 pragma Warnings (Off, Found);
791 procedure Search_Stack
792 (Top : Suppress_Stack_Entry_Ptr;
793 Found : out Boolean);
794 -- Search given suppress stack for matching entry for entity. If found
795 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
796 -- entry for To onto the local suppress stack.
802 procedure Search_Stack
803 (Top : Suppress_Stack_Entry_Ptr;
806 Ptr : Suppress_Stack_Entry_Ptr;
810 while Ptr /= null loop
812 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
815 Set_Checks_May_Be_Suppressed (To, True);
816 Push_Local_Suppress_Stack_Entry
832 -- Start of processing for Copy_Suppress_Status
835 if not Checks_May_Be_Suppressed (From) then
839 -- First search the local entity suppress stack, we search this in
840 -- reverse order so that we get the innermost entry that applies to
841 -- this case if there are nested entries. Note that for the purpose
842 -- of this procedure we are ONLY looking for entries corresponding
843 -- to a two-argument Suppress, where the second argument matches From.
845 Search_Stack (Global_Suppress_Stack_Top, Found);
851 -- Now search the global entity suppress table for a matching entry
852 -- We also search this in reverse order so that if there are multiple
853 -- pragmas for the same entity, the last one applies.
855 Search_Stack (Local_Suppress_Stack_Top, Found);
856 end Copy_Suppress_Status;
858 -------------------------
859 -- Enter_Generic_Scope --
860 -------------------------
862 procedure Enter_Generic_Scope (S : Entity_Id) is
864 if No (Outer_Generic_Scope) then
865 Outer_Generic_Scope := S;
867 end Enter_Generic_Scope;
869 ------------------------
870 -- Exit_Generic_Scope --
871 ------------------------
873 procedure Exit_Generic_Scope (S : Entity_Id) is
875 if S = Outer_Generic_Scope then
876 Outer_Generic_Scope := Empty;
878 end Exit_Generic_Scope;
880 -----------------------
881 -- Explicit_Suppress --
882 -----------------------
884 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
885 Ptr : Suppress_Stack_Entry_Ptr;
888 if not Checks_May_Be_Suppressed (E) then
892 Ptr := Global_Suppress_Stack_Top;
893 while Ptr /= null loop
895 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
905 end Explicit_Suppress;
907 -----------------------------
908 -- External_Ref_In_Generic --
909 -----------------------------
911 function External_Ref_In_Generic (E : Entity_Id) return Boolean is
915 -- Entity is global if defined outside of current outer_generic_scope:
916 -- Either the entity has a smaller depth that the outer generic, or it
917 -- is in a different compilation unit, or it is defined within a unit
918 -- in the same compilation, that is not within the outer_generic.
920 if No (Outer_Generic_Scope) then
923 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
924 or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
931 while Present (Scop) loop
932 if Scop = Outer_Generic_Scope then
934 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
937 Scop := Scope (Scop);
943 end External_Ref_In_Generic;
949 procedure Initialize is
950 Next : Suppress_Stack_Entry_Ptr;
952 procedure Free is new Unchecked_Deallocation
953 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
956 -- Free any global suppress stack entries from a previous invocation
957 -- of the compiler (in the normal case this loop does nothing).
959 while Suppress_Stack_Entries /= null loop
960 Next := Global_Suppress_Stack_Top.Next;
961 Free (Suppress_Stack_Entries);
962 Suppress_Stack_Entries := Next;
965 Local_Suppress_Stack_Top := null;
966 Global_Suppress_Stack_Top := null;
968 -- Clear scope stack, and reset global variables
971 Unloaded_Subunits := False;
974 ------------------------------
975 -- Insert_After_And_Analyze --
976 ------------------------------
978 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
984 -- If we are not at the end of the list, then the easiest
985 -- coding is simply to insert before our successor
987 if Present (Next (N)) then
988 Insert_Before_And_Analyze (Next (N), M);
990 -- Case of inserting at the end of the list
993 -- Capture the Node_Id of the node to be inserted. This Node_Id
994 -- will still be the same after the insert operation.
999 -- Now just analyze from the inserted node to the end of
1000 -- the new list (note that this properly handles the case
1001 -- where any of the analyze calls result in the insertion of
1002 -- nodes after the analyzed node, expecting analysis).
1004 while Present (Node) loop
1006 Mark_Rewrite_Insertion (Node);
1011 end Insert_After_And_Analyze;
1013 -- Version with check(s) suppressed
1015 procedure Insert_After_And_Analyze
1018 Suppress : Check_Id)
1021 if Suppress = All_Checks then
1023 Svg : constant Suppress_Array := Scope_Suppress;
1025 Scope_Suppress := (others => True);
1026 Insert_After_And_Analyze (N, M);
1027 Scope_Suppress := Svg;
1032 Svg : constant Boolean := Scope_Suppress (Suppress);
1034 Scope_Suppress (Suppress) := True;
1035 Insert_After_And_Analyze (N, M);
1036 Scope_Suppress (Suppress) := Svg;
1039 end Insert_After_And_Analyze;
1041 -------------------------------
1042 -- Insert_Before_And_Analyze --
1043 -------------------------------
1045 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
1051 -- Capture the Node_Id of the first list node to be inserted.
1052 -- This will still be the first node after the insert operation,
1053 -- since Insert_List_After does not modify the Node_Id values.
1056 Insert_Before (N, M);
1058 -- The insertion does not change the Id's of any of the nodes in
1059 -- the list, and they are still linked, so we can simply loop from
1060 -- the original first node until we meet the node before which the
1061 -- insertion is occurring. Note that this properly handles the case
1062 -- where any of the analyzed nodes insert nodes after themselves,
1063 -- expecting them to get analyzed.
1065 while Node /= N loop
1067 Mark_Rewrite_Insertion (Node);
1071 end Insert_Before_And_Analyze;
1073 -- Version with check(s) suppressed
1075 procedure Insert_Before_And_Analyze
1078 Suppress : Check_Id)
1081 if Suppress = All_Checks then
1083 Svg : constant Suppress_Array := Scope_Suppress;
1085 Scope_Suppress := (others => True);
1086 Insert_Before_And_Analyze (N, M);
1087 Scope_Suppress := Svg;
1092 Svg : constant Boolean := Scope_Suppress (Suppress);
1094 Scope_Suppress (Suppress) := True;
1095 Insert_Before_And_Analyze (N, M);
1096 Scope_Suppress (Suppress) := Svg;
1099 end Insert_Before_And_Analyze;
1101 -----------------------------------
1102 -- Insert_List_After_And_Analyze --
1103 -----------------------------------
1105 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
1106 After : constant Node_Id := Next (N);
1110 if Is_Non_Empty_List (L) then
1112 -- Capture the Node_Id of the first list node to be inserted.
1113 -- This will still be the first node after the insert operation,
1114 -- since Insert_List_After does not modify the Node_Id values.
1117 Insert_List_After (N, L);
1119 -- Now just analyze from the original first node until we get to
1120 -- the successor of the original insertion point (which may be
1121 -- Empty if the insertion point was at the end of the list). Note
1122 -- that this properly handles the case where any of the analyze
1123 -- calls result in the insertion of nodes after the analyzed
1124 -- node (possibly calling this routine recursively).
1126 while Node /= After loop
1128 Mark_Rewrite_Insertion (Node);
1132 end Insert_List_After_And_Analyze;
1134 -- Version with check(s) suppressed
1136 procedure Insert_List_After_And_Analyze
1137 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1140 if Suppress = All_Checks then
1142 Svg : constant Suppress_Array := Scope_Suppress;
1144 Scope_Suppress := (others => True);
1145 Insert_List_After_And_Analyze (N, L);
1146 Scope_Suppress := Svg;
1151 Svg : constant Boolean := Scope_Suppress (Suppress);
1153 Scope_Suppress (Suppress) := True;
1154 Insert_List_After_And_Analyze (N, L);
1155 Scope_Suppress (Suppress) := Svg;
1158 end Insert_List_After_And_Analyze;
1160 ------------------------------------
1161 -- Insert_List_Before_And_Analyze --
1162 ------------------------------------
1164 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
1168 if Is_Non_Empty_List (L) then
1170 -- Capture the Node_Id of the first list node to be inserted.
1171 -- This will still be the first node after the insert operation,
1172 -- since Insert_List_After does not modify the Node_Id values.
1175 Insert_List_Before (N, L);
1177 -- The insertion does not change the Id's of any of the nodes in
1178 -- the list, and they are still linked, so we can simply loop from
1179 -- the original first node until we meet the node before which the
1180 -- insertion is occurring. Note that this properly handles the case
1181 -- where any of the analyzed nodes insert nodes after themselves,
1182 -- expecting them to get analyzed.
1184 while Node /= N loop
1186 Mark_Rewrite_Insertion (Node);
1190 end Insert_List_Before_And_Analyze;
1192 -- Version with check(s) suppressed
1194 procedure Insert_List_Before_And_Analyze
1195 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1198 if Suppress = All_Checks then
1200 Svg : constant Suppress_Array := Scope_Suppress;
1202 Scope_Suppress := (others => True);
1203 Insert_List_Before_And_Analyze (N, L);
1204 Scope_Suppress := Svg;
1209 Svg : constant Boolean := Scope_Suppress (Suppress);
1211 Scope_Suppress (Suppress) := True;
1212 Insert_List_Before_And_Analyze (N, L);
1213 Scope_Suppress (Suppress) := Svg;
1216 end Insert_List_Before_And_Analyze;
1218 -------------------------
1219 -- Is_Check_Suppressed --
1220 -------------------------
1222 function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
1224 Ptr : Suppress_Stack_Entry_Ptr;
1227 -- First search the local entity suppress stack, we search this from the
1228 -- top of the stack down, so that we get the innermost entry that
1229 -- applies to this case if there are nested entries.
1231 Ptr := Local_Suppress_Stack_Top;
1232 while Ptr /= null loop
1233 if (Ptr.Entity = Empty or else Ptr.Entity = E)
1234 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1236 return Ptr.Suppress;
1242 -- Now search the global entity suppress table for a matching entry
1243 -- We also search this from the top down so that if there are multiple
1244 -- pragmas for the same entity, the last one applies (not clear what
1245 -- or whether the RM specifies this handling, but it seems reasonable).
1247 Ptr := Global_Suppress_Stack_Top;
1248 while Ptr /= null loop
1249 if (Ptr.Entity = Empty or else Ptr.Entity = E)
1250 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1252 return Ptr.Suppress;
1258 -- If we did not find a matching entry, then use the normal scope
1259 -- suppress value after all (actually this will be the global setting
1260 -- since it clearly was not overridden at any point). For a predefined
1261 -- check, we test the specific flag. For a user defined check, we check
1262 -- the All_Checks flag.
1264 if C in Predefined_Check_Id then
1265 return Scope_Suppress (C);
1267 return Scope_Suppress (All_Checks);
1269 end Is_Check_Suppressed;
1277 Scope_Stack.Locked := True;
1278 Scope_Stack.Release;
1281 --------------------------------------
1282 -- Push_Global_Suppress_Stack_Entry --
1283 --------------------------------------
1285 procedure Push_Global_Suppress_Stack_Entry
1286 (Entity : Entity_Id;
1291 Global_Suppress_Stack_Top :=
1292 new Suppress_Stack_Entry'
1295 Suppress => Suppress,
1296 Prev => Global_Suppress_Stack_Top,
1297 Next => Suppress_Stack_Entries);
1298 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1301 end Push_Global_Suppress_Stack_Entry;
1303 -------------------------------------
1304 -- Push_Local_Suppress_Stack_Entry --
1305 -------------------------------------
1307 procedure Push_Local_Suppress_Stack_Entry
1308 (Entity : Entity_Id;
1313 Local_Suppress_Stack_Top :=
1314 new Suppress_Stack_Entry'
1317 Suppress => Suppress,
1318 Prev => Local_Suppress_Stack_Top,
1319 Next => Suppress_Stack_Entries);
1320 Suppress_Stack_Entries := Local_Suppress_Stack_Top;
1323 end Push_Local_Suppress_Stack_Entry;
1329 procedure Semantics (Comp_Unit : Node_Id) is
1331 -- The following locations save the corresponding global flags and
1332 -- variables so that they can be restored on completion. This is
1333 -- needed so that calls to Rtsfind start with the proper default
1334 -- values for these variables, and also that such calls do not
1335 -- disturb the settings for units being analyzed at a higher level.
1337 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
1338 S_Full_Analysis : constant Boolean := Full_Analysis;
1339 S_GNAT_Mode : constant Boolean := GNAT_Mode;
1340 S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
1341 S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
1342 S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
1343 S_New_Nodes_OK : constant Int := New_Nodes_OK;
1344 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
1346 Generic_Main : constant Boolean :=
1347 Nkind (Unit (Cunit (Main_Unit)))
1348 in N_Generic_Declaration;
1349 -- If the main unit is generic, every compiled unit, including its
1350 -- context, is compiled with expansion disabled.
1352 Save_Config_Switches : Config_Switches_Type;
1353 -- Variable used to save values of config switches while we analyze
1354 -- the new unit, to be restored on exit for proper recursive behavior.
1356 procedure Do_Analyze;
1357 -- Procedure to analyze the compilation unit. This is called more
1358 -- than once when the high level optimizer is activated.
1364 procedure Do_Analyze is
1367 Push_Scope (Standard_Standard);
1368 Scope_Suppress := Suppress_Options;
1370 (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
1372 (Scope_Stack.Last).Is_Active_Stack_Base := True;
1373 Outer_Generic_Scope := Empty;
1375 -- Now analyze the top level compilation unit node
1377 Analyze (Comp_Unit);
1379 -- Check for scope mismatch on exit from compilation
1381 pragma Assert (Current_Scope = Standard_Standard
1382 or else Comp_Unit = Cunit (Main_Unit));
1384 -- Then pop entry for Standard, and pop implicit types
1387 Restore_Scope_Stack;
1390 Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
1392 -- Start of processing for Semantics
1395 if Debug_Unit_Walk then
1396 if Already_Analyzed then
1397 Write_Str ("(done)");
1401 (Get_Cunit_Unit_Number (Comp_Unit),
1407 Compiler_State := Analyzing;
1408 Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
1410 -- Compile predefined units with GNAT_Mode set to True, to properly
1411 -- process the categorization stuff. However, do not set GNAT_Mode
1412 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1413 -- Sequential_IO) as this would prevent pragma Extend_System from being
1414 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1416 -- Cleaner might be to do the kludge at the point of excluding the
1417 -- pragma (do not exclude for renamings ???)
1419 if Is_Predefined_File_Name
1420 (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
1425 if Generic_Main then
1426 Expander_Mode_Save_And_Set (False);
1428 Expander_Mode_Save_And_Set
1429 (Operating_Mode = Generate_Code or Debug_Flag_X);
1432 Full_Analysis := True;
1433 Inside_A_Generic := False;
1434 In_Spec_Expression := False;
1436 Set_Comes_From_Source_Default (False);
1437 Save_Opt_Config_Switches (Save_Config_Switches);
1438 Set_Opt_Config_Switches
1439 (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
1440 Current_Sem_Unit = Main_Unit);
1442 -- Only do analysis of unit that has not already been analyzed
1444 if not Analyzed (Comp_Unit) then
1445 Initialize_Version (Current_Sem_Unit);
1447 Expander_Mode_Save_And_Set (False);
1450 Reset_Analyzed_Flags (Comp_Unit);
1451 Expander_Mode_Restore;
1452 High_Level_Optimize (Comp_Unit);
1456 -- Do analysis, and then append the compilation unit onto the
1457 -- Comp_Unit_List, if appropriate. This is done after analysis, so
1458 -- if this unit depends on some others, they have already been
1459 -- appended. We ignore bodies, except for the main unit itself. We
1460 -- have also to guard against ill-formed subunits that have an
1461 -- improper context.
1465 if Present (Comp_Unit)
1466 and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
1467 and then not In_Extended_Main_Source_Unit (Comp_Unit)
1472 -- Initialize if first time
1474 if No (Comp_Unit_List) then
1475 Comp_Unit_List := New_Elmt_List;
1478 Append_Elmt (Comp_Unit, Comp_Unit_List);
1480 if Debug_Unit_Walk then
1481 Write_Str ("Appending ");
1483 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
1488 -- Save indication of dynamic elaboration checks for ALI file
1490 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
1492 -- Restore settings of saved switches to entry values
1494 Current_Sem_Unit := S_Current_Sem_Unit;
1495 Full_Analysis := S_Full_Analysis;
1496 Global_Discard_Names := S_Global_Dis_Names;
1497 GNAT_Mode := S_GNAT_Mode;
1498 In_Spec_Expression := S_In_Spec_Expr;
1499 Inside_A_Generic := S_Inside_A_Generic;
1500 New_Nodes_OK := S_New_Nodes_OK;
1501 Outer_Generic_Scope := S_Outer_Gen_Scope;
1503 Restore_Opt_Config_Switches (Save_Config_Switches);
1504 Expander_Mode_Restore;
1506 if Debug_Unit_Walk then
1509 if Already_Analyzed then
1510 Write_Str ("(done)");
1514 (Get_Cunit_Unit_Number (Comp_Unit),
1520 ------------------------
1521 -- Walk_Library_Items --
1522 ------------------------
1524 procedure Walk_Library_Items is
1525 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
1526 pragma Pack (Unit_Number_Set);
1528 Main_CU : constant Node_Id := Cunit (Main_Unit);
1530 Seen, Done : Unit_Number_Set := (others => False);
1531 -- Seen (X) is True after we have seen unit X in the walk. This is used
1532 -- to prevent processing the same unit more than once. Done (X) is True
1533 -- after we have fully processed X, and is used only for debugging
1534 -- printouts and assertions.
1536 Do_Main : Boolean := False;
1537 -- Flag to delay processing the main body until after all other units.
1538 -- This is needed because the spec of the main unit may appear in the
1539 -- context of some other unit. We do not want this to force processing
1540 -- of the main body before all other units have been processed.
1542 procedure Do_Action (CU : Node_Id; Item : Node_Id);
1543 -- Calls Action, with some validity checks
1545 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id);
1546 -- Calls Do_Action, first on the units with'ed by this one, then on
1547 -- this unit. If it's an instance body, do the spec first. If it is
1548 -- an instance spec, do the body last.
1550 procedure Do_Withed_Unit (Withed_Unit : Node_Id);
1551 -- Apply Do_Unit_And_Dependents to a unit in a context clause.
1553 procedure Process_Bodies_In_Context (Comp : Node_Id);
1554 -- The main unit and its spec may depend on bodies that contain generics
1555 -- that are instantiated in them. Iterate through the corresponding
1556 -- contexts before processing main (spec/body) itself, to process bodies
1557 -- that may be present, together with their context. The spec of main
1558 -- is processed wherever it appears in the list of units, while the body
1559 -- is processed as the last unit in the list.
1565 procedure Do_Action (CU : Node_Id; Item : Node_Id) is
1567 -- This calls Action at the end. All the preceding code is just
1568 -- assertions and debugging output.
1570 pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
1572 case Nkind (Item) is
1573 when N_Generic_Subprogram_Declaration |
1574 N_Generic_Package_Declaration |
1575 N_Package_Declaration |
1576 N_Subprogram_Declaration |
1577 N_Subprogram_Renaming_Declaration |
1578 N_Package_Renaming_Declaration |
1579 N_Generic_Function_Renaming_Declaration |
1580 N_Generic_Package_Renaming_Declaration |
1581 N_Generic_Procedure_Renaming_Declaration =>
1587 when N_Package_Body =>
1589 -- Package bodies are processed separately if the main
1590 -- unit depends on them.
1594 when N_Subprogram_Body =>
1596 -- A subprogram body must be the main unit
1598 pragma Assert (Acts_As_Spec (CU)
1599 or else CU = Cunit (Main_Unit));
1602 -- All other cases cannot happen
1604 when N_Function_Instantiation |
1605 N_Procedure_Instantiation |
1606 N_Package_Instantiation =>
1607 pragma Assert (False, "instantiation");
1611 pragma Assert (False, "subunit");
1615 pragma Assert (False);
1619 if Present (CU) then
1620 pragma Assert (Item /= Stand.Standard_Package_Node);
1621 pragma Assert (Item = Unit (CU));
1624 Unit_Num : constant Unit_Number_Type :=
1625 Get_Cunit_Unit_Number (CU);
1627 procedure Assert_Done (Withed_Unit : Node_Id);
1628 -- Assert Withed_Unit is already Done, unless it's a body. It
1629 -- might seem strange for a with_clause to refer to a body, but
1630 -- this happens in the case of a generic instantiation, which
1631 -- gets transformed into the instance body (and the instance
1632 -- spec is also created). With clauses pointing to the
1633 -- instantiation end up pointing to the instance body.
1639 procedure Assert_Done (Withed_Unit : Node_Id) is
1641 if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
1643 (Unit (Withed_Unit),
1644 N_Generic_Package_Declaration,
1646 N_Package_Renaming_Declaration,
1650 (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit)));
1651 Write_Str (" not yet walked!");
1653 if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
1654 Write_Str (" (self-ref)");
1659 pragma Assert (False);
1664 procedure Assert_Withed_Units_Done is
1665 new Walk_Withs (Assert_Done);
1668 if Debug_Unit_Walk then
1669 Write_Unit_Info (Unit_Num, Item, Withs => True);
1672 -- Main unit should come last, except in the case where we
1673 -- skipped System_Aux_Id, in which case we missed the things it
1674 -- depends on, and in the case of parent bodies if present.
1677 (not Done (Main_Unit)
1678 or else Present (System_Aux_Id)
1679 or else Nkind (Item) = N_Package_Body);
1681 -- We shouldn't do the same thing twice
1683 pragma Assert (not Done (Unit_Num));
1685 -- Everything we depend upon should already be done
1688 (Assert_Withed_Units_Done (CU, Include_Limited => False));
1692 -- Must be Standard, which has no entry in the units table
1694 pragma Assert (Item = Stand.Standard_Package_Node);
1696 if Debug_Unit_Walk then
1697 Write_Line ("Standard");
1704 --------------------
1705 -- Do_Withed_Unit --
1706 --------------------
1708 procedure Do_Withed_Unit (Withed_Unit : Node_Id) is
1710 Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit));
1712 -- If the unit in the with_clause is a generic instance, the clause
1713 -- now denotes the instance body. Traverse the corresponding spec
1714 -- because there may be no other dependence that will force the
1715 -- traversal of its own context.
1717 if Nkind (Unit (Withed_Unit)) = N_Package_Body
1718 and then Is_Generic_Instance
1719 (Defining_Entity (Unit (Library_Unit (Withed_Unit))))
1721 Do_Withed_Unit (Library_Unit (Withed_Unit));
1725 ----------------------------
1726 -- Do_Unit_And_Dependents --
1727 ----------------------------
1729 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
1730 Unit_Num : constant Unit_Number_Type :=
1731 Get_Cunit_Unit_Number (CU);
1733 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
1735 -- Start of processing for Do_Unit_And_Dependents
1738 if not Seen (Unit_Num) then
1740 -- Process the with clauses
1742 Do_Withed_Units (CU, Include_Limited => False);
1744 -- Process the unit if it is a spec or the the main unit, if
1745 -- it has no previous spec or we have done all other units.
1747 if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
1748 or else Acts_As_Spec (CU)
1751 if CU = Cunit (Main_Unit)
1752 and then not Do_Main
1754 Seen (Unit_Num) := False;
1757 Seen (Unit_Num) := True;
1759 if CU = Library_Unit (Main_CU) then
1760 Process_Bodies_In_Context (CU);
1763 Do_Action (CU, Item);
1764 Done (Unit_Num) := True;
1768 end Do_Unit_And_Dependents;
1770 -------------------------------
1771 -- Process_Bodies_In_Context --
1772 -------------------------------
1774 procedure Process_Bodies_In_Context (Comp : Node_Id) is
1776 Body_U : Unit_Number_Type;
1780 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
1782 function Depends_On_Main (CU : Node_Id) return Boolean;
1783 -- The body of a unit that is withed by the spec of the main
1784 -- unit may in turn have a with_clause on that spec. In that
1785 -- case do not traverse the body, to prevent loops.
1787 ---------------------
1788 -- Depends_On_Main --
1789 ---------------------
1791 function Depends_On_Main (CU : Node_Id) return Boolean is
1795 CL := First (Context_Items (CU));
1797 -- Problem does not arise with main subprograms.
1799 if Nkind (Unit (Main_CU)) /= N_Package_Body then
1803 while Present (CL) loop
1804 if Nkind (CL) = N_With_Clause
1805 and then Library_Unit (CL) = Library_Unit (Main_CU)
1814 end Depends_On_Main;
1816 -- Start of processing for Process_Bodies_In_Context
1819 Clause := First (Context_Items (Comp));
1820 while Present (Clause) loop
1821 if Nkind (Clause) = N_With_Clause then
1822 Spec := Library_Unit (Clause);
1823 Body_CU := Library_Unit (Spec);
1825 -- If we are processing the spec of the main unit, load bodies
1826 -- only if the with_clause indicates that it forced the loading
1827 -- of the body for a generic instantiation.
1829 if Present (Body_CU)
1830 and then Body_CU /= Cunit (Main_Unit)
1831 and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body
1832 and then (Nkind (Unit (Comp)) /= N_Package_Declaration
1833 or else Present (Withed_Body (Clause)))
1835 Body_U := Get_Cunit_Unit_Number (Body_CU);
1837 if not Seen (Body_U)
1838 and then not Depends_On_Main (Body_CU)
1840 Seen (Body_U) := True;
1841 Do_Withed_Units (Body_CU, Include_Limited => False);
1842 Do_Action (Body_CU, Unit (Body_CU));
1843 Done (Body_U) := True;
1850 end Process_Bodies_In_Context;
1852 -- Local Declarations
1856 -- Start of processing for Walk_Library_Items
1859 if Debug_Unit_Walk then
1860 Write_Line ("Walk_Library_Items:");
1864 -- Do Standard first, then walk the Comp_Unit_List
1866 Do_Action (Empty, Standard_Package_Node);
1868 -- First place the context of all instance bodies on the corresponding
1869 -- spec, because it may be needed to analyze the code at the place of
1870 -- the instantiation.
1872 Cur := First_Elmt (Comp_Unit_List);
1873 while Present (Cur) loop
1875 CU : constant Node_Id := Node (Cur);
1876 N : constant Node_Id := Unit (CU);
1879 if Nkind (N) = N_Package_Body
1880 and then Is_Generic_Instance (Defining_Entity (N))
1883 (Context_Items (CU), Context_Items (Library_Unit (CU)));
1890 -- Now traverse compilation units (specs) in order
1892 Cur := First_Elmt (Comp_Unit_List);
1893 while Present (Cur) loop
1895 CU : constant Node_Id := Node (Cur);
1896 N : constant Node_Id := Unit (CU);
1899 pragma Assert (Nkind (CU) = N_Compilation_Unit);
1903 -- If it is a subprogram body, process it if it has no
1906 -- If it's a package body, ignore it, unless it is a body
1907 -- created for an instance that is the main unit. In the
1908 -- case of subprograms, the body is the wrapper package. In
1909 -- case of a package, the original file carries the body,
1910 -- and the spec appears as a later entry in the units list.
1912 -- Otherwise Bodies appear in the list only because of
1913 -- inlining/instantiations, and they are processed only
1914 -- if relevant to the main unit. The main unit itself
1915 -- is processed separately after all other specs.
1917 when N_Subprogram_Body =>
1918 if Acts_As_Spec (N) then
1919 Do_Unit_And_Dependents (CU, N);
1922 when N_Package_Body =>
1924 and then Nkind (Original_Node (Unit (Main_CU))) in
1925 N_Generic_Instantiation
1926 and then Present (Library_Unit (Main_CU))
1928 Do_Unit_And_Dependents
1929 (Library_Unit (Main_CU),
1930 Unit (Library_Unit (Main_CU)));
1933 -- It's a spec, process it, and the units it depends on.
1936 Do_Unit_And_Dependents (CU, N);
1943 -- Now process package bodies on which main depends, followed by
1944 -- bodies of parents, if present, and finally main itself.
1946 if not Done (Main_Unit) then
1950 Parent_CU : Node_Id;
1952 Body_U : Unit_Number_Type;
1956 Process_Bodies_In_Context (Main_CU);
1958 -- If the main unit is a child unit, parent bodies may be present
1959 -- because they export instances or inlined subprograms. Check for
1960 -- presence of these, which are not present in context clauses.
1962 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
1963 Child := Cunit_Entity (Main_Unit);
1964 while Is_Child_Unit (Child) loop
1966 Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child)));
1967 Body_CU := Library_Unit (Parent_CU);
1969 if Present (Body_CU)
1970 and then not Seen (Get_Cunit_Unit_Number (Body_CU))
1972 Body_U := Get_Cunit_Unit_Number (Body_CU);
1973 Seen (Body_U) := True;
1974 Do_Action (Body_CU, Unit (Body_CU));
1975 Done (Body_U) := True;
1978 Child := Scope (Child);
1982 Do_Action (Main_CU, Unit (Main_CU));
1983 Done (Main_Unit) := True;
1987 if Debug_Unit_Walk then
1988 if Done /= (Done'Range => True) then
1990 Write_Line ("Ignored units:");
1994 for Unit_Num in Done'Range loop
1995 if not Done (Unit_Num) then
1997 (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True);
2005 pragma Assert (Done (Main_Unit));
2007 if Debug_Unit_Walk then
2009 Write_Line ("end Walk_Library_Items.");
2011 end Walk_Library_Items;
2017 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is
2018 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2019 pragma Assert (Nkind (Unit (CU)) /= N_Subunit);
2021 procedure Walk_Immediate is new Walk_Withs_Immediate (Action);
2024 -- First walk the withs immediately on the library item
2026 Walk_Immediate (CU, Include_Limited);
2028 -- For a body, we must also check for any subunits which belong to it
2029 -- and which have context clauses of their own, since these with'ed
2030 -- units are part of its own dependencies.
2032 if Nkind (Unit (CU)) in N_Unit_Body then
2033 for S in Main_Unit .. Last_Unit loop
2035 -- We are only interested in subunits. For preproc. data and def.
2036 -- files, Cunit is Empty, so we need to test that first.
2038 if Cunit (S) /= Empty
2039 and then Nkind (Unit (Cunit (S))) = N_Subunit
2045 Pnode := Library_Unit (Cunit (S));
2047 -- In -gnatc mode, the errors in the subunits will not have
2048 -- been recorded, but the analysis of the subunit may have
2049 -- failed, so just quit.
2055 -- Find ultimate parent of the subunit
2057 while Nkind (Unit (Pnode)) = N_Subunit loop
2058 Pnode := Library_Unit (Pnode);
2061 -- See if it belongs to current unit, and if so, include its
2062 -- with_clauses. Do not process main unit prematurely.
2064 if Pnode = CU and then CU /= Cunit (Main_Unit) then
2065 Walk_Immediate (Cunit (S), Include_Limited);
2073 --------------------------
2074 -- Walk_Withs_Immediate --
2075 --------------------------
2077 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is
2078 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2080 Context_Item : Node_Id;
2083 Context_Item := First (Context_Items (CU));
2084 while Present (Context_Item) loop
2085 if Nkind (Context_Item) = N_With_Clause
2086 and then (Include_Limited
2087 or else not Limited_Present (Context_Item))
2089 Action (Library_Unit (Context_Item));
2092 Context_Item := Next (Context_Item);
2094 end Walk_Withs_Immediate;
2096 ---------------------
2097 -- Write_Unit_Info --
2098 ---------------------
2100 procedure Write_Unit_Info
2101 (Unit_Num : Unit_Number_Type;
2103 Prefix : String := "";
2104 Withs : Boolean := False)
2108 Write_Unit_Name (Unit_Name (Unit_Num));
2109 Write_Str (", unit ");
2110 Write_Int (Int (Unit_Num));
2112 Write_Int (Int (Item));
2114 Write_Str (Node_Kind'Image (Nkind (Item)));
2116 if Item /= Original_Node (Item) then
2117 Write_Str (", orig = ");
2118 Write_Int (Int (Original_Node (Item)));
2120 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
2125 -- Skip the rest if we're not supposed to print the withs
2132 Context_Item : Node_Id;
2135 Context_Item := First (Context_Items (Cunit (Unit_Num)));
2136 while Present (Context_Item)
2137 and then (Nkind (Context_Item) /= N_With_Clause
2138 or else Limited_Present (Context_Item))
2140 Context_Item := Next (Context_Item);
2143 if Present (Context_Item) then
2145 Write_Line ("withs:");
2148 while Present (Context_Item) loop
2149 if Nkind (Context_Item) = N_With_Clause
2150 and then not Limited_Present (Context_Item)
2152 pragma Assert (Present (Library_Unit (Context_Item)));
2155 (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
2157 if Implicit_With (Context_Item) then
2158 Write_Str (" -- implicit");
2164 Context_Item := Next (Context_Item);
2168 Write_Line ("end withs");
2172 end Write_Unit_Info;