1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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 Exp_SPARK; use Exp_SPARK;
31 with Expander; use Expander;
32 with Ghost; use Ghost;
34 with Lib.Load; use Lib.Load;
35 with Nlists; use Nlists;
36 with Output; use Output;
37 with Restrict; use Restrict;
38 with Sem_Attr; use Sem_Attr;
39 with Sem_Ch2; use Sem_Ch2;
40 with Sem_Ch3; use Sem_Ch3;
41 with Sem_Ch4; use Sem_Ch4;
42 with Sem_Ch5; use Sem_Ch5;
43 with Sem_Ch6; use Sem_Ch6;
44 with Sem_Ch7; use Sem_Ch7;
45 with Sem_Ch8; use Sem_Ch8;
46 with Sem_Ch9; use Sem_Ch9;
47 with Sem_Ch10; use Sem_Ch10;
48 with Sem_Ch11; use Sem_Ch11;
49 with Sem_Ch12; use Sem_Ch12;
50 with Sem_Ch13; use Sem_Ch13;
51 with Sem_Prag; use Sem_Prag;
52 with Sem_Util; use Sem_Util;
53 with Sinfo; use Sinfo;
54 with Stand; use Stand;
55 with Stylesw; use Stylesw;
56 with Uintp; use Uintp;
57 with Uname; use Uname;
59 with Unchecked_Deallocation;
61 pragma Warnings (Off, Sem_Util);
62 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
66 Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW;
67 -- Controls debugging printouts for Walk_Library_Items
69 Outer_Generic_Scope : Entity_Id := Empty;
70 -- Global reference to the outer scope that is generic. In a non-generic
71 -- context, it is empty. At the moment, it is only used for avoiding
72 -- freezing of external references in generics.
74 Comp_Unit_List : Elist_Id := No_Elist;
75 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
76 -- processed by Semantics, in an appropriate order. Initialized to
77 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
78 -- to New_Elmt_List on first use.
81 with procedure Action (Withed_Unit : Node_Id);
82 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean);
83 -- Walk all the with clauses of CU, and call Action for the with'ed unit.
84 -- Ignore limited withs, unless Include_Limited is True. CU must be an
85 -- N_Compilation_Unit.
88 with procedure Action (Withed_Unit : Node_Id);
89 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean);
90 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
91 -- of this unit, since they count as dependences on their parent library
92 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
98 -- WARNING: This routine manages Ghost regions. Return statements must be
99 -- replaced by gotos which jump to the end of the routine and restore the
102 procedure Analyze (N : Node_Id) is
103 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
104 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
105 -- Save the Ghost-related attributes to restore on exit
108 Debug_A_Entry ("analyzing ", N);
110 -- Immediate return if already analyzed
113 Debug_A_Exit ("analyzing ", N, " (done, analyzed already)");
117 -- A declaration may be subject to pragma Ghost. Set the mode now to
118 -- ensure that any nodes generated during analysis and expansion are
121 if Is_Declaration (N) then
122 Mark_And_Set_Ghost_Declaration (N);
125 -- Otherwise processing depends on the node kind
128 when N_Abort_Statement =>
129 Analyze_Abort_Statement (N);
131 when N_Abstract_Subprogram_Declaration =>
132 Analyze_Abstract_Subprogram_Declaration (N);
134 when N_Accept_Alternative =>
135 Analyze_Accept_Alternative (N);
137 when N_Accept_Statement =>
138 Analyze_Accept_Statement (N);
141 Analyze_Aggregate (N);
144 Analyze_Allocator (N);
147 Analyze_Short_Circuit (N);
149 when N_Assignment_Statement =>
150 Analyze_Assignment (N);
152 when N_Asynchronous_Select =>
153 Analyze_Asynchronous_Select (N);
156 Analyze_At_Clause (N);
158 when N_Attribute_Reference =>
159 Analyze_Attribute (N);
161 when N_Attribute_Definition_Clause =>
162 Analyze_Attribute_Definition_Clause (N);
164 when N_Block_Statement =>
165 Analyze_Block_Statement (N);
167 when N_Case_Expression =>
168 Analyze_Case_Expression (N);
170 when N_Case_Statement =>
171 Analyze_Case_Statement (N);
173 when N_Character_Literal =>
174 Analyze_Character_Literal (N);
176 when N_Code_Statement =>
177 Analyze_Code_Statement (N);
179 when N_Compilation_Unit =>
180 Analyze_Compilation_Unit (N);
182 when N_Component_Declaration =>
183 Analyze_Component_Declaration (N);
185 when N_Compound_Statement =>
186 Analyze_Compound_Statement (N);
188 when N_Conditional_Entry_Call =>
189 Analyze_Conditional_Entry_Call (N);
191 when N_Delay_Alternative =>
192 Analyze_Delay_Alternative (N);
194 when N_Delay_Relative_Statement =>
195 Analyze_Delay_Relative (N);
197 when N_Delay_Until_Statement =>
198 Analyze_Delay_Until (N);
200 when N_Delta_Aggregate =>
201 Analyze_Aggregate (N);
204 Analyze_Entry_Body (N);
206 when N_Entry_Body_Formal_Part =>
207 Analyze_Entry_Body_Formal_Part (N);
209 when N_Entry_Call_Alternative =>
210 Analyze_Entry_Call_Alternative (N);
212 when N_Entry_Declaration =>
213 Analyze_Entry_Declaration (N);
215 when N_Entry_Index_Specification =>
216 Analyze_Entry_Index_Specification (N);
218 when N_Enumeration_Representation_Clause =>
219 Analyze_Enumeration_Representation_Clause (N);
221 when N_Exception_Declaration =>
222 Analyze_Exception_Declaration (N);
224 when N_Exception_Renaming_Declaration =>
225 Analyze_Exception_Renaming (N);
227 when N_Exit_Statement =>
228 Analyze_Exit_Statement (N);
230 when N_Expanded_Name =>
231 Analyze_Expanded_Name (N);
233 when N_Explicit_Dereference =>
234 Analyze_Explicit_Dereference (N);
236 when N_Expression_Function =>
237 Analyze_Expression_Function (N);
239 when N_Expression_With_Actions =>
240 Analyze_Expression_With_Actions (N);
242 when N_Extended_Return_Statement =>
243 Analyze_Extended_Return_Statement (N);
245 when N_Extension_Aggregate =>
246 Analyze_Aggregate (N);
248 when N_Formal_Object_Declaration =>
249 Analyze_Formal_Object_Declaration (N);
251 when N_Formal_Package_Declaration =>
252 Analyze_Formal_Package_Declaration (N);
254 when N_Formal_Subprogram_Declaration =>
255 Analyze_Formal_Subprogram_Declaration (N);
257 when N_Formal_Type_Declaration =>
258 Analyze_Formal_Type_Declaration (N);
260 when N_Free_Statement =>
261 Analyze_Free_Statement (N);
263 when N_Freeze_Entity =>
264 Analyze_Freeze_Entity (N);
266 when N_Freeze_Generic_Entity =>
267 Analyze_Freeze_Generic_Entity (N);
269 when N_Full_Type_Declaration =>
270 Analyze_Full_Type_Declaration (N);
272 when N_Function_Call =>
273 Analyze_Function_Call (N);
275 when N_Function_Instantiation =>
276 Analyze_Function_Instantiation (N);
278 when N_Generic_Function_Renaming_Declaration =>
279 Analyze_Generic_Function_Renaming (N);
281 when N_Generic_Package_Declaration =>
282 Analyze_Generic_Package_Declaration (N);
284 when N_Generic_Package_Renaming_Declaration =>
285 Analyze_Generic_Package_Renaming (N);
287 when N_Generic_Procedure_Renaming_Declaration =>
288 Analyze_Generic_Procedure_Renaming (N);
290 when N_Generic_Subprogram_Declaration =>
291 Analyze_Generic_Subprogram_Declaration (N);
293 when N_Goto_Statement =>
294 Analyze_Goto_Statement (N);
296 when N_Handled_Sequence_Of_Statements =>
297 Analyze_Handled_Statements (N);
300 Analyze_Identifier (N);
302 when N_If_Expression =>
303 Analyze_If_Expression (N);
305 when N_If_Statement =>
306 Analyze_If_Statement (N);
308 when N_Implicit_Label_Declaration =>
309 Analyze_Implicit_Label_Declaration (N);
312 Analyze_Membership_Op (N);
314 when N_Incomplete_Type_Declaration =>
315 Analyze_Incomplete_Type_Decl (N);
317 when N_Indexed_Component =>
318 Analyze_Indexed_Component_Form (N);
320 when N_Integer_Literal =>
321 Analyze_Integer_Literal (N);
323 when N_Iterator_Specification =>
324 Analyze_Iterator_Specification (N);
326 when N_Itype_Reference =>
327 Analyze_Itype_Reference (N);
332 when N_Loop_Parameter_Specification =>
333 Analyze_Loop_Parameter_Specification (N);
335 when N_Loop_Statement =>
336 Analyze_Loop_Statement (N);
339 Analyze_Membership_Op (N);
344 when N_Null_Statement =>
345 Analyze_Null_Statement (N);
347 when N_Number_Declaration =>
348 Analyze_Number_Declaration (N);
350 when N_Object_Declaration =>
351 Analyze_Object_Declaration (N);
353 when N_Object_Renaming_Declaration =>
354 Analyze_Object_Renaming (N);
356 when N_Operator_Symbol =>
357 Analyze_Operator_Symbol (N);
360 Analyze_Unary_Op (N);
363 Analyze_Arithmetic_Op (N);
366 Analyze_Logical_Op (N);
369 Analyze_Concatenation (N);
372 Analyze_Arithmetic_Op (N);
375 Analyze_Equality_Op (N);
378 Analyze_Arithmetic_Op (N);
381 Analyze_Comparison_Op (N);
384 Analyze_Comparison_Op (N);
387 Analyze_Comparison_Op (N);
390 Analyze_Comparison_Op (N);
393 Analyze_Unary_Op (N);
398 when N_Op_Multiply =>
399 Analyze_Arithmetic_Op (N);
402 Analyze_Equality_Op (N);
405 Analyze_Negation (N);
408 Analyze_Logical_Op (N);
411 Analyze_Unary_Op (N);
414 Analyze_Arithmetic_Op (N);
416 when N_Op_Rotate_Left =>
417 Analyze_Arithmetic_Op (N);
419 when N_Op_Rotate_Right =>
420 Analyze_Arithmetic_Op (N);
422 when N_Op_Shift_Left =>
423 Analyze_Arithmetic_Op (N);
425 when N_Op_Shift_Right =>
426 Analyze_Arithmetic_Op (N);
428 when N_Op_Shift_Right_Arithmetic =>
429 Analyze_Arithmetic_Op (N);
431 when N_Op_Subtract =>
432 Analyze_Arithmetic_Op (N);
435 Analyze_Logical_Op (N);
438 Analyze_Short_Circuit (N);
440 when N_Others_Choice =>
441 Analyze_Others_Choice (N);
443 when N_Package_Body =>
444 Analyze_Package_Body (N);
446 when N_Package_Body_Stub =>
447 Analyze_Package_Body_Stub (N);
449 when N_Package_Declaration =>
450 Analyze_Package_Declaration (N);
452 when N_Package_Instantiation =>
453 Analyze_Package_Instantiation (N);
455 when N_Package_Renaming_Declaration =>
456 Analyze_Package_Renaming (N);
458 when N_Package_Specification =>
459 Analyze_Package_Specification (N);
461 when N_Parameter_Association =>
462 Analyze_Parameter_Association (N);
467 when N_Private_Extension_Declaration =>
468 Analyze_Private_Extension_Declaration (N);
470 when N_Private_Type_Declaration =>
471 Analyze_Private_Type_Declaration (N);
473 when N_Procedure_Call_Statement =>
474 Analyze_Procedure_Call (N);
476 when N_Procedure_Instantiation =>
477 Analyze_Procedure_Instantiation (N);
479 when N_Protected_Body =>
480 Analyze_Protected_Body (N);
482 when N_Protected_Body_Stub =>
483 Analyze_Protected_Body_Stub (N);
485 when N_Protected_Definition =>
486 Analyze_Protected_Definition (N);
488 when N_Protected_Type_Declaration =>
489 Analyze_Protected_Type_Declaration (N);
491 when N_Qualified_Expression =>
492 Analyze_Qualified_Expression (N);
494 when N_Quantified_Expression =>
495 Analyze_Quantified_Expression (N);
497 when N_Raise_Expression =>
498 Analyze_Raise_Expression (N);
500 when N_Raise_Statement =>
501 Analyze_Raise_Statement (N);
503 when N_Raise_xxx_Error =>
504 Analyze_Raise_xxx_Error (N);
509 when N_Range_Constraint =>
510 Analyze_Range (Range_Expression (N));
512 when N_Real_Literal =>
513 Analyze_Real_Literal (N);
515 when N_Record_Representation_Clause =>
516 Analyze_Record_Representation_Clause (N);
519 Analyze_Reference (N);
521 when N_Requeue_Statement =>
524 when N_Simple_Return_Statement =>
525 Analyze_Simple_Return_Statement (N);
527 when N_Selected_Component =>
528 Find_Selected_Component (N);
529 -- ??? why not Analyze_Selected_Component, needs comments
531 when N_Selective_Accept =>
532 Analyze_Selective_Accept (N);
534 when N_Single_Protected_Declaration =>
535 Analyze_Single_Protected_Declaration (N);
537 when N_Single_Task_Declaration =>
538 Analyze_Single_Task_Declaration (N);
543 when N_String_Literal =>
544 Analyze_String_Literal (N);
546 when N_Subprogram_Body =>
547 Analyze_Subprogram_Body (N);
549 when N_Subprogram_Body_Stub =>
550 Analyze_Subprogram_Body_Stub (N);
552 when N_Subprogram_Declaration =>
553 Analyze_Subprogram_Declaration (N);
555 when N_Subprogram_Renaming_Declaration =>
556 Analyze_Subprogram_Renaming (N);
558 when N_Subtype_Declaration =>
559 Analyze_Subtype_Declaration (N);
561 when N_Subtype_Indication =>
562 Analyze_Subtype_Indication (N);
567 when N_Target_Name =>
568 Analyze_Target_Name (N);
571 Analyze_Task_Body (N);
573 when N_Task_Body_Stub =>
574 Analyze_Task_Body_Stub (N);
576 when N_Task_Definition =>
577 Analyze_Task_Definition (N);
579 when N_Task_Type_Declaration =>
580 Analyze_Task_Type_Declaration (N);
582 when N_Terminate_Alternative =>
583 Analyze_Terminate_Alternative (N);
585 when N_Timed_Entry_Call =>
586 Analyze_Timed_Entry_Call (N);
588 when N_Triggering_Alternative =>
589 Analyze_Triggering_Alternative (N);
591 when N_Type_Conversion =>
592 Analyze_Type_Conversion (N);
594 when N_Unchecked_Expression =>
595 Analyze_Unchecked_Expression (N);
597 when N_Unchecked_Type_Conversion =>
598 Analyze_Unchecked_Type_Conversion (N);
600 when N_Use_Package_Clause =>
601 Analyze_Use_Package (N);
603 when N_Use_Type_Clause =>
604 Analyze_Use_Type (N);
606 when N_Validate_Unchecked_Conversion =>
609 when N_Variant_Part =>
610 Analyze_Variant_Part (N);
612 when N_With_Clause =>
613 Analyze_With_Clause (N);
615 -- A call to analyze a marker is ignored because the node does not
616 -- have any static and run-time semantics.
619 | N_Variable_Reference_Marker
623 -- A call to analyze the Empty node is an error, but most likely it
624 -- is an error caused by an attempt to analyze a malformed piece of
625 -- tree caused by some other error, so if there have been any other
626 -- errors, we just ignore it, otherwise it is a real internal error
627 -- which we complain about.
629 -- We must also consider the case of call to a runtime function that
630 -- is not available in the configurable runtime.
633 pragma Assert (Serious_Errors_Detected /= 0
634 or else Configurable_Run_Time_Violations /= 0);
637 -- A call to analyze the error node is simply ignored, to avoid
638 -- causing cascaded errors (happens of course only in error cases)
639 -- Disable expansion in case it is still enabled, to prevent other
640 -- subsequent compiler glitches.
643 Expander_Mode_Save_And_Set (False);
646 -- Push/Pop nodes normally don't come through an analyze call. An
647 -- exception is the dummy ones bracketing a subprogram body. In any
648 -- case there is nothing to be done to analyze such nodes.
650 when N_Push_Pop_xxx_Label =>
653 -- SCIL nodes don't need analysis because they are decorated when
654 -- they are built. They are added to the tree by Insert_Actions and
655 -- the call to analyze them is generated when the full list is
658 when N_SCIL_Dispatch_Table_Tag_Init
659 | N_SCIL_Dispatching_Call
660 | N_SCIL_Membership_Test
664 -- A quantified expression with a missing "all" or "some" qualifier
665 -- looks identical to an iterated component association. By language
666 -- definition, the latter must be present within array aggregates. If
667 -- this is not the case, then the iterated component association is
668 -- really an illegal quantified expression. Diagnose this scenario.
670 when N_Iterated_Component_Association =>
671 Diagnose_Iterated_Component_Association (N);
673 -- For the remaining node types, we generate compiler abort, because
674 -- these nodes are always analyzed within the Sem_Chn routines and
675 -- there should never be a case of making a call to the main Analyze
676 -- routine for these node kinds. For example, an N_Access_Definition
677 -- node appears only in the context of a type declaration, and is
678 -- processed by the analyze routine for type declarations.
680 when N_Abortable_Part
681 | N_Access_Definition
682 | N_Access_Function_Definition
683 | N_Access_Procedure_Definition
684 | N_Access_To_Object_Definition
685 | N_Aspect_Specification
686 | N_Case_Expression_Alternative
687 | N_Case_Statement_Alternative
688 | N_Compilation_Unit_Aux
689 | N_Component_Association
691 | N_Component_Definition
693 | N_Constrained_Array_Definition
695 | N_Decimal_Fixed_Point_Definition
696 | N_Defining_Character_Literal
697 | N_Defining_Identifier
698 | N_Defining_Operator_Symbol
699 | N_Defining_Program_Unit_Name
701 | N_Derived_Type_Definition
703 | N_Digits_Constraint
704 | N_Discriminant_Association
705 | N_Discriminant_Specification
707 | N_Entry_Call_Statement
708 | N_Enumeration_Type_Definition
709 | N_Exception_Handler
710 | N_Floating_Point_Definition
711 | N_Formal_Decimal_Fixed_Point_Definition
712 | N_Formal_Derived_Type_Definition
713 | N_Formal_Discrete_Type_Definition
714 | N_Formal_Floating_Point_Definition
715 | N_Formal_Modular_Type_Definition
716 | N_Formal_Ordinary_Fixed_Point_Definition
717 | N_Formal_Private_Type_Definition
718 | N_Formal_Incomplete_Type_Definition
719 | N_Formal_Signed_Integer_Type_Definition
720 | N_Function_Specification
721 | N_Generic_Association
722 | N_Index_Or_Discriminant_Constraint
725 | N_Modular_Type_Definition
726 | N_Ordinary_Fixed_Point_Definition
727 | N_Parameter_Specification
728 | N_Pragma_Argument_Association
729 | N_Procedure_Specification
730 | N_Real_Range_Specification
731 | N_Record_Definition
732 | N_Signed_Integer_Type_Definition
733 | N_Unconstrained_Array_Definition
741 Debug_A_Exit ("analyzing ", N, " (done)");
743 -- Mark relevant use-type and use-package clauses as effective
744 -- preferring the original node over the analyzed one in the case that
745 -- constant folding has occurred and removed references that need to be
746 -- examined. Also, if the node in question is overloaded then this is
747 -- deferred until resolution.
750 Operat : Node_Id := Empty;
752 -- Attempt to obtain a checkable operator node
754 if Nkind (Original_Node (N)) in N_Op then
755 Operat := Original_Node (N);
756 elsif Nkind (N) in N_Op then
763 and then Present (Entity (Operat))
764 and then not Is_Overloaded (Operat)
766 Mark_Use_Clauses (Operat);
770 -- Now that we have analyzed the node, we call the expander to perform
771 -- possible expansion. We skip this for subexpressions, because we don't
772 -- have the type yet, and the expander will need to know the type before
773 -- it can do its job. For subexpression nodes, the call to the expander
774 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
775 -- which can appear in a statement context, and needs expanding now in
776 -- the case (distinguished by Etype, as documented in Sinfo).
778 -- The Analyzed flag is also set at this point for non-subexpression
779 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
780 -- since resolution and expansion have not yet been completed). Note
781 -- that for N_Raise_xxx_Error we have to distinguish the expression
782 -- case from the statement case.
784 if Nkind (N) not in N_Subexpr
785 or else (Nkind (N) in N_Raise_xxx_Error
786 and then Etype (N) = Standard_Void_Type)
790 -- Replace a reference to a renaming with the renamed object for SPARK.
791 -- In general this modification is performed by Expand_SPARK, however
792 -- certain constructs may not reach the resolution or expansion phase
793 -- and thus remain unchanged. The replacement is not performed when the
794 -- construct is overloaded as resolution must first take place. This is
795 -- also not done when analyzing a generic to preserve the original tree
796 -- and because the reference may become overloaded in the instance.
799 and then Nkind_In (N, N_Expanded_Name, N_Identifier)
800 and then not Is_Overloaded (N)
801 and then not Inside_A_Generic
803 Expand_SPARK_Potential_Renaming (N);
806 Restore_Ghost_Region (Saved_GM, Saved_IGR);
809 -- Version with check(s) suppressed
811 procedure Analyze (N : Node_Id; Suppress : Check_Id) is
813 if Suppress = All_Checks then
815 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
817 Scope_Suppress.Suppress := (others => True);
819 Scope_Suppress.Suppress := Svs;
822 elsif Suppress = Overflow_Check then
824 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
826 Scope_Suppress.Suppress (Suppress) := True;
828 Scope_Suppress.Suppress (Suppress) := Svg;
837 procedure Analyze_List (L : List_Id) is
842 while Present (Node) loop
848 -- Version with check(s) suppressed
850 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
852 if Suppress = All_Checks then
854 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
856 Scope_Suppress.Suppress := (others => True);
858 Scope_Suppress.Suppress := Svs;
863 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
865 Scope_Suppress.Suppress (Suppress) := True;
867 Scope_Suppress.Suppress (Suppress) := Svg;
872 --------------------------
873 -- Copy_Suppress_Status --
874 --------------------------
876 procedure Copy_Suppress_Status
882 pragma Warnings (Off, Found);
884 procedure Search_Stack
885 (Top : Suppress_Stack_Entry_Ptr;
886 Found : out Boolean);
887 -- Search given suppress stack for matching entry for entity. If found
888 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
889 -- entry for To onto the local suppress stack.
895 procedure Search_Stack
896 (Top : Suppress_Stack_Entry_Ptr;
899 Ptr : Suppress_Stack_Entry_Ptr;
903 while Ptr /= null loop
905 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
908 Set_Checks_May_Be_Suppressed (To, True);
909 Push_Local_Suppress_Stack_Entry
925 -- Start of processing for Copy_Suppress_Status
928 if not Checks_May_Be_Suppressed (From) then
932 -- First search the global entity suppress table for a matching entry.
933 -- We also search this in reverse order so that if there are multiple
934 -- pragmas for the same entity, the last one applies.
936 Search_Stack (Global_Suppress_Stack_Top, Found);
942 -- Now search the local entity suppress stack, we search this in
943 -- reverse order so that we get the innermost entry that applies to
944 -- this case if there are nested entries. Note that for the purpose
945 -- of this procedure we are ONLY looking for entries corresponding
946 -- to a two-argument Suppress, where the second argument matches From.
948 Search_Stack (Local_Suppress_Stack_Top, Found);
949 end Copy_Suppress_Status;
951 -------------------------
952 -- Enter_Generic_Scope --
953 -------------------------
955 procedure Enter_Generic_Scope (S : Entity_Id) is
957 if No (Outer_Generic_Scope) then
958 Outer_Generic_Scope := S;
960 end Enter_Generic_Scope;
962 ------------------------
963 -- Exit_Generic_Scope --
964 ------------------------
966 procedure Exit_Generic_Scope (S : Entity_Id) is
968 if S = Outer_Generic_Scope then
969 Outer_Generic_Scope := Empty;
971 end Exit_Generic_Scope;
973 -----------------------
974 -- Explicit_Suppress --
975 -----------------------
977 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
978 Ptr : Suppress_Stack_Entry_Ptr;
981 if not Checks_May_Be_Suppressed (E) then
985 Ptr := Global_Suppress_Stack_Top;
986 while Ptr /= null loop
988 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
998 end Explicit_Suppress;
1000 -----------------------------
1001 -- External_Ref_In_Generic --
1002 -----------------------------
1004 function External_Ref_In_Generic (E : Entity_Id) return Boolean is
1008 -- Entity is global if defined outside of current outer_generic_scope:
1009 -- Either the entity has a smaller depth that the outer generic, or it
1010 -- is in a different compilation unit, or it is defined within a unit
1011 -- in the same compilation, that is not within the outer_generic.
1013 if No (Outer_Generic_Scope) then
1016 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
1017 or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
1023 while Present (Scop) loop
1024 if Scop = Outer_Generic_Scope then
1026 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
1029 Scop := Scope (Scop);
1035 end External_Ref_In_Generic;
1041 procedure Initialize is
1042 Next : Suppress_Stack_Entry_Ptr;
1044 procedure Free is new Unchecked_Deallocation
1045 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
1048 -- Free any global suppress stack entries from a previous invocation
1049 -- of the compiler (in the normal case this loop does nothing).
1051 while Suppress_Stack_Entries /= null loop
1052 Next := Suppress_Stack_Entries.Next;
1053 Free (Suppress_Stack_Entries);
1054 Suppress_Stack_Entries := Next;
1057 Local_Suppress_Stack_Top := null;
1058 Global_Suppress_Stack_Top := null;
1060 -- Clear scope stack, and reset global variables
1063 Unloaded_Subunits := False;
1066 ------------------------------
1067 -- Insert_After_And_Analyze --
1068 ------------------------------
1070 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
1076 -- If we are not at the end of the list, then the easiest
1077 -- coding is simply to insert before our successor.
1079 if Present (Next (N)) then
1080 Insert_Before_And_Analyze (Next (N), M);
1082 -- Case of inserting at the end of the list
1085 -- Capture the Node_Id of the node to be inserted. This Node_Id
1086 -- will still be the same after the insert operation.
1089 Insert_After (N, M);
1091 -- Now just analyze from the inserted node to the end of
1092 -- the new list (note that this properly handles the case
1093 -- where any of the analyze calls result in the insertion of
1094 -- nodes after the analyzed node, expecting analysis).
1096 while Present (Node) loop
1098 Mark_Rewrite_Insertion (Node);
1103 end Insert_After_And_Analyze;
1105 -- Version with check(s) suppressed
1107 procedure Insert_After_And_Analyze
1110 Suppress : Check_Id)
1113 if Suppress = All_Checks then
1115 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1117 Scope_Suppress.Suppress := (others => True);
1118 Insert_After_And_Analyze (N, M);
1119 Scope_Suppress.Suppress := Svs;
1124 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1126 Scope_Suppress.Suppress (Suppress) := True;
1127 Insert_After_And_Analyze (N, M);
1128 Scope_Suppress.Suppress (Suppress) := Svg;
1131 end Insert_After_And_Analyze;
1133 -------------------------------
1134 -- Insert_Before_And_Analyze --
1135 -------------------------------
1137 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
1143 -- Capture the Node_Id of the first list node to be inserted.
1144 -- This will still be the first node after the insert operation,
1145 -- since Insert_List_After does not modify the Node_Id values.
1148 Insert_Before (N, M);
1150 -- The insertion does not change the Id's of any of the nodes in
1151 -- the list, and they are still linked, so we can simply loop from
1152 -- the original first node until we meet the node before which the
1153 -- insertion is occurring. Note that this properly handles the case
1154 -- where any of the analyzed nodes insert nodes after themselves,
1155 -- expecting them to get analyzed.
1157 while Node /= N loop
1159 Mark_Rewrite_Insertion (Node);
1163 end Insert_Before_And_Analyze;
1165 -- Version with check(s) suppressed
1167 procedure Insert_Before_And_Analyze
1170 Suppress : Check_Id)
1173 if Suppress = All_Checks then
1175 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1177 Scope_Suppress.Suppress := (others => True);
1178 Insert_Before_And_Analyze (N, M);
1179 Scope_Suppress.Suppress := Svs;
1184 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1186 Scope_Suppress.Suppress (Suppress) := True;
1187 Insert_Before_And_Analyze (N, M);
1188 Scope_Suppress.Suppress (Suppress) := Svg;
1191 end Insert_Before_And_Analyze;
1193 -----------------------------------
1194 -- Insert_List_After_And_Analyze --
1195 -----------------------------------
1197 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
1198 After : constant Node_Id := Next (N);
1202 if Is_Non_Empty_List (L) then
1204 -- Capture the Node_Id of the first list node to be inserted.
1205 -- This will still be the first node after the insert operation,
1206 -- since Insert_List_After does not modify the Node_Id values.
1209 Insert_List_After (N, L);
1211 -- Now just analyze from the original first node until we get to the
1212 -- successor of the original insertion point (which may be Empty if
1213 -- the insertion point was at the end of the list). Note that this
1214 -- properly handles the case where any of the analyze calls result in
1215 -- the insertion of nodes after the analyzed node (possibly calling
1216 -- this routine recursively).
1218 while Node /= After loop
1220 Mark_Rewrite_Insertion (Node);
1224 end Insert_List_After_And_Analyze;
1226 ------------------------------------
1227 -- Insert_List_Before_And_Analyze --
1228 ------------------------------------
1230 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
1234 if Is_Non_Empty_List (L) then
1236 -- Capture the Node_Id of the first list node to be inserted. This
1237 -- will still be the first node after the insert operation, since
1238 -- Insert_List_After does not modify the Node_Id values.
1241 Insert_List_Before (N, L);
1243 -- The insertion does not change the Id's of any of the nodes in
1244 -- the list, and they are still linked, so we can simply loop from
1245 -- the original first node until we meet the node before which the
1246 -- insertion is occurring. Note that this properly handles the case
1247 -- where any of the analyzed nodes insert nodes after themselves,
1248 -- expecting them to get analyzed.
1250 while Node /= N loop
1252 Mark_Rewrite_Insertion (Node);
1256 end Insert_List_Before_And_Analyze;
1264 Scope_Stack.Release;
1265 Scope_Stack.Locked := True;
1268 ------------------------
1269 -- Preanalysis_Active --
1270 ------------------------
1272 function Preanalysis_Active return Boolean is
1274 return not Full_Analysis and not Expander_Active;
1275 end Preanalysis_Active;
1281 procedure Preanalyze (N : Node_Id) is
1282 Save_Full_Analysis : constant Boolean := Full_Analysis;
1285 Full_Analysis := False;
1286 Expander_Mode_Save_And_Set (False);
1290 Expander_Mode_Restore;
1291 Full_Analysis := Save_Full_Analysis;
1294 --------------------------------------
1295 -- Push_Global_Suppress_Stack_Entry --
1296 --------------------------------------
1298 procedure Push_Global_Suppress_Stack_Entry
1299 (Entity : Entity_Id;
1304 Global_Suppress_Stack_Top :=
1305 new Suppress_Stack_Entry'
1308 Suppress => Suppress,
1309 Prev => Global_Suppress_Stack_Top,
1310 Next => Suppress_Stack_Entries);
1311 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1313 end Push_Global_Suppress_Stack_Entry;
1315 -------------------------------------
1316 -- Push_Local_Suppress_Stack_Entry --
1317 -------------------------------------
1319 procedure Push_Local_Suppress_Stack_Entry
1320 (Entity : Entity_Id;
1325 Local_Suppress_Stack_Top :=
1326 new Suppress_Stack_Entry'
1329 Suppress => Suppress,
1330 Prev => Local_Suppress_Stack_Top,
1331 Next => Suppress_Stack_Entries);
1332 Suppress_Stack_Entries := Local_Suppress_Stack_Top;
1335 end Push_Local_Suppress_Stack_Entry;
1341 procedure Semantics (Comp_Unit : Node_Id) is
1342 procedure Do_Analyze;
1343 -- Perform the analysis of the compilation unit
1349 -- WARNING: This routine manages Ghost regions. Return statements must
1350 -- be replaced by gotos which jump to the end of the routine and restore
1353 procedure Do_Analyze is
1354 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
1355 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
1356 -- Save the Ghost-related attributes to restore on exit
1358 -- Generally style checks are preserved across compilations, with
1359 -- one exception: s-oscons.ads, which allows arbitrary long lines
1360 -- unconditionally, and has no restore mechanism, because it is
1361 -- intended as a lowest-level Pure package.
1363 Saved_ML : constant Int := Style_Max_Line_Length;
1368 List := Save_Scope_Stack;
1369 Push_Scope (Standard_Standard);
1371 -- Set up a clean environment before analyzing
1373 Install_Ghost_Region (None, Empty);
1375 Outer_Generic_Scope := Empty;
1376 Scope_Suppress := Suppress_Options;
1378 (Scope_Stack.Last).Component_Alignment_Default :=
1379 Configuration_Component_Alignment;
1381 (Scope_Stack.Last).Is_Active_Stack_Base := True;
1383 -- Now analyze the top level compilation unit node
1385 Analyze (Comp_Unit);
1387 -- Check for scope mismatch on exit from compilation
1389 pragma Assert (Current_Scope = Standard_Standard
1390 or else Comp_Unit = Cunit (Main_Unit));
1392 -- Then pop entry for Standard, and pop implicit types
1395 Restore_Scope_Stack (List);
1396 Restore_Ghost_Region (Saved_GM, Saved_IGR);
1397 Style_Max_Line_Length := Saved_ML;
1398 Style_Check_Max_Line_Length := Style_Max_Line_Length /= 0;
1403 -- The following locations save the corresponding global flags and
1404 -- variables so that they can be restored on completion. This is needed
1405 -- so that calls to Rtsfind start with the proper default values for
1406 -- these variables, and also that such calls do not disturb the settings
1407 -- for units being analyzed at a higher level.
1409 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
1410 S_Full_Analysis : constant Boolean := Full_Analysis;
1411 S_GNAT_Mode : constant Boolean := GNAT_Mode;
1412 S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
1413 S_In_Assertion_Expr : constant Nat := In_Assertion_Expr;
1414 S_In_Default_Expr : constant Boolean := In_Default_Expr;
1415 S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
1416 S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
1417 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
1418 S_Style_Check : constant Boolean := Style_Check;
1420 Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
1422 Curunit : constant Unit_Number_Type := Get_Cunit_Unit_Number (Comp_Unit);
1423 -- New value of Current_Sem_Unit
1425 Generic_Main : constant Boolean :=
1426 Nkind (Unit (Cunit (Main_Unit))) in N_Generic_Declaration;
1427 -- If the main unit is generic, every compiled unit, including its
1428 -- context, is compiled with expansion disabled.
1430 Is_Main_Unit_Or_Main_Unit_Spec : constant Boolean :=
1433 (Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
1434 and then Library_Unit (Cunit (Main_Unit)) = Cunit (Curunit));
1435 -- Configuration flags have special settings when compiling a predefined
1436 -- file as a main unit. This applies to its spec as well.
1438 Ext_Main_Source_Unit : constant Boolean :=
1439 In_Extended_Main_Source_Unit (Comp_Unit);
1440 -- Determine if unit is in extended main source unit
1442 Save_Config_Attrs : Config_Switches_Type;
1443 -- Variable used to save values of config switches while we analyze the
1444 -- new unit, to be restored on exit for proper recursive behavior.
1446 Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions;
1447 -- Used to save non-partition wide restrictions before processing new
1448 -- unit. All with'ed units are analyzed with config restrictions reset
1449 -- and we need to restore these saved values at the end.
1451 Save_Preanalysis_Counter : constant Nat :=
1452 Inside_Preanalysis_Without_Freezing;
1453 -- Saves the preanalysis nesting-level counter; required since we may
1454 -- need to analyze a unit as a consequence of the preanalysis of an
1455 -- expression without freezing (and the loaded unit must be fully
1458 -- Start of processing for Semantics
1461 Inside_Preanalysis_Without_Freezing := 0;
1463 if Debug_Unit_Walk then
1464 if Already_Analyzed then
1465 Write_Str ("(done)");
1469 (Get_Cunit_Unit_Number (Comp_Unit),
1475 Compiler_State := Analyzing;
1476 Current_Sem_Unit := Curunit;
1478 -- Compile predefined units with GNAT_Mode set to True, to properly
1479 -- process the categorization stuff. However, do not set GNAT_Mode
1480 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1481 -- Sequential_IO) as this would prevent pragma Extend_System from being
1482 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1484 if Is_Predefined_Unit (Current_Sem_Unit)
1485 and then not Is_Predefined_Renaming (Current_Sem_Unit)
1490 -- For generic main, never do expansion
1492 if Generic_Main then
1493 Expander_Mode_Save_And_Set (False);
1498 Expander_Mode_Save_And_Set
1500 -- Turn on expansion if generating code
1502 (Operating_Mode = Generate_Code
1504 -- Or if special debug flag -gnatdx is set
1506 or else Debug_Flag_X
1508 -- Or if in configuration run-time mode. We do this so we get
1509 -- error messages about missing entities in the run-time even
1510 -- if we are compiling in -gnatc (no code generation) mode.
1511 -- Similar processing applies to No_Run_Time_Mode. However,
1512 -- don't do this if debug flag -gnatd.Z is set or when we are
1513 -- compiling a separate unit (this is to handle a situation
1514 -- where this new processing causes trouble).
1517 ((Configurable_Run_Time_Mode or No_Run_Time_Mode)
1518 and then not Debug_Flag_Dot_ZZ
1519 and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit));
1522 Full_Analysis := True;
1523 Inside_A_Generic := False;
1524 In_Assertion_Expr := 0;
1525 In_Default_Expr := False;
1526 In_Spec_Expression := False;
1527 Set_Comes_From_Source_Default (False);
1529 -- Save current config switches and reset then appropriately
1531 Save_Config_Attrs := Save_Config_Switches;
1533 (Is_Internal_Unit (Current_Sem_Unit),
1534 Is_Main_Unit_Or_Main_Unit_Spec);
1536 -- Save current non-partition-wide restrictions
1538 Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save;
1540 -- For unit in main extended unit, we reset the configuration values
1541 -- for the non-partition-wide restrictions. For other units reset them.
1543 if Ext_Main_Source_Unit then
1544 Restore_Config_Cunit_Boolean_Restrictions;
1546 Reset_Cunit_Boolean_Restrictions;
1549 -- Turn off style checks for unit that is not in the extended main
1550 -- source unit. This improves processing efficiency for such units
1551 -- (for which we don't want style checks anyway, and where they will
1552 -- get suppressed), and is definitely needed to stop some style checks
1553 -- from invading the run-time units (e.g. overriding checks).
1555 if not Ext_Main_Source_Unit then
1556 Style_Check := False;
1558 -- If this is part of the extended main source unit, set style check
1559 -- mode to match the style check mode of the main source unit itself.
1562 Style_Check := Style_Check_Main;
1565 -- Only do analysis of unit that has not already been analyzed
1567 if not Analyzed (Comp_Unit) then
1568 Initialize_Version (Current_Sem_Unit);
1570 -- Do analysis, and then append the compilation unit onto the
1571 -- Comp_Unit_List, if appropriate. This is done after analysis,
1572 -- so if this unit depends on some others, they have already been
1573 -- appended. We ignore bodies, except for the main unit itself, and
1574 -- for subprogram bodies that act as specs. We have also to guard
1575 -- against ill-formed subunits that have an improper context.
1579 if Present (Comp_Unit)
1580 and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
1581 and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body
1582 or else not Acts_As_Spec (Comp_Unit))
1583 and then not Ext_Main_Source_Unit
1588 Append_New_Elmt (Comp_Unit, To => Comp_Unit_List);
1590 if Debug_Unit_Walk then
1591 Write_Str ("Appending ");
1593 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
1598 -- Save indication of dynamic elaboration checks for ALI file
1600 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
1602 -- Restore settings of saved switches to entry values
1604 Current_Sem_Unit := S_Current_Sem_Unit;
1605 Full_Analysis := S_Full_Analysis;
1606 Global_Discard_Names := S_Global_Dis_Names;
1607 GNAT_Mode := S_GNAT_Mode;
1608 In_Assertion_Expr := S_In_Assertion_Expr;
1609 In_Default_Expr := S_In_Default_Expr;
1610 In_Spec_Expression := S_In_Spec_Expr;
1611 Inside_A_Generic := S_Inside_A_Generic;
1612 Outer_Generic_Scope := S_Outer_Gen_Scope;
1613 Style_Check := S_Style_Check;
1615 Restore_Config_Switches (Save_Config_Attrs);
1617 -- Deal with restore of restrictions
1619 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
1621 Expander_Mode_Restore;
1623 if Debug_Unit_Walk then
1626 if Already_Analyzed then
1627 Write_Str ("(done)");
1631 (Get_Cunit_Unit_Number (Comp_Unit),
1636 Inside_Preanalysis_Without_Freezing := Save_Preanalysis_Counter;
1643 function ss (Index : Int) return Scope_Stack_Entry is
1645 return Scope_Stack.Table (Index);
1652 function sst return Scope_Stack_Entry is
1654 return ss (Scope_Stack.Last);
1663 Scope_Stack.Locked := False;
1666 ------------------------
1667 -- Walk_Library_Items --
1668 ------------------------
1670 procedure Walk_Library_Items is
1671 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
1672 pragma Pack (Unit_Number_Set);
1674 Main_CU : constant Node_Id := Cunit (Main_Unit);
1676 Seen, Done : Unit_Number_Set := (others => False);
1677 -- Seen (X) is True after we have seen unit X in the walk. This is used
1678 -- to prevent processing the same unit more than once. Done (X) is True
1679 -- after we have fully processed X, and is used only for debugging
1680 -- printouts and assertions.
1682 Do_Main : Boolean := False;
1683 -- Flag to delay processing the main body until after all other units.
1684 -- This is needed because the spec of the main unit may appear in the
1685 -- context of some other unit. We do not want this to force processing
1686 -- of the main body before all other units have been processed.
1688 -- Another circularity pattern occurs when the main unit is a child unit
1689 -- and the body of an ancestor has a with-clause of the main unit or on
1690 -- one of its children. In both cases the body in question has a with-
1691 -- clause on the main unit, and must be excluded from the traversal. In
1692 -- some convoluted cases this may lead to a CodePeer error because the
1693 -- spec of a subprogram declared in an instance within the parent will
1694 -- not be seen in the main unit.
1696 function Depends_On_Main (CU : Node_Id) return Boolean;
1697 -- The body of a unit that is withed by the spec of the main unit may in
1698 -- turn have a with_clause on that spec. In that case do not traverse
1699 -- the body, to prevent loops. It can also happen that the main body has
1700 -- a with_clause on a child, which of course has an implicit with on its
1701 -- parent. It's OK to traverse the child body if the main spec has been
1702 -- processed, otherwise we also have a circularity to avoid.
1704 procedure Do_Action (CU : Node_Id; Item : Node_Id);
1705 -- Calls Action, with some validity checks
1707 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id);
1708 -- Calls Do_Action, first on the units with'ed by this one, then on
1709 -- this unit. If it's an instance body, do the spec first. If it is
1710 -- an instance spec, do the body last.
1712 procedure Do_Withed_Unit (Withed_Unit : Node_Id);
1713 -- Apply Do_Unit_And_Dependents to a unit in a context clause
1715 procedure Process_Bodies_In_Context (Comp : Node_Id);
1716 -- The main unit and its spec may depend on bodies that contain generics
1717 -- that are instantiated in them. Iterate through the corresponding
1718 -- contexts before processing main (spec/body) itself, to process bodies
1719 -- that may be present, together with their context. The spec of main
1720 -- is processed wherever it appears in the list of units, while the body
1721 -- is processed as the last unit in the list.
1723 ---------------------
1724 -- Depends_On_Main --
1725 ---------------------
1727 function Depends_On_Main (CU : Node_Id) return Boolean is
1729 MCU : constant Node_Id := Unit (Main_CU);
1732 CL := First (Context_Items (CU));
1734 -- Problem does not arise with main subprograms
1737 not Nkind_In (MCU, N_Package_Body, N_Package_Declaration)
1742 while Present (CL) loop
1743 if Nkind (CL) = N_With_Clause
1744 and then Library_Unit (CL) = Main_CU
1745 and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL)))
1754 end Depends_On_Main;
1760 procedure Do_Action (CU : Node_Id; Item : Node_Id) is
1762 -- This calls Action at the end. All the preceding code is just
1763 -- assertions and debugging output.
1765 pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
1767 case Nkind (Item) is
1768 when N_Generic_Function_Renaming_Declaration
1769 | N_Generic_Package_Declaration
1770 | N_Generic_Package_Renaming_Declaration
1771 | N_Generic_Procedure_Renaming_Declaration
1772 | N_Generic_Subprogram_Declaration
1773 | N_Package_Declaration
1774 | N_Package_Renaming_Declaration
1775 | N_Subprogram_Declaration
1776 | N_Subprogram_Renaming_Declaration
1782 when N_Package_Body =>
1784 -- Package bodies are processed separately if the main unit
1789 when N_Subprogram_Body =>
1791 -- A subprogram body must be the main unit
1793 pragma Assert (Acts_As_Spec (CU) or else CU = Main_CU);
1796 when N_Function_Instantiation
1797 | N_Package_Instantiation
1798 | N_Procedure_Instantiation
1800 -- Can only happen if some generic body (needed for gnat2scil
1801 -- traversal, but not by GNAT) is not available, ignore.
1805 -- All other cases cannot happen
1808 pragma Assert (False, "subunit");
1811 when N_Null_Statement =>
1813 -- Do not call Action for an ignored ghost unit
1815 pragma Assert (Is_Ignored_Ghost_Node (Original_Node (Item)));
1819 pragma Assert (False);
1823 if Present (CU) then
1824 pragma Assert (Item /= Stand.Standard_Package_Node);
1825 pragma Assert (Item = Unit (CU));
1828 Unit_Num : constant Unit_Number_Type :=
1829 Get_Cunit_Unit_Number (CU);
1831 procedure Assert_Done (Withed_Unit : Node_Id);
1832 -- Assert Withed_Unit is already Done, unless it's a body. It
1833 -- might seem strange for a with_clause to refer to a body, but
1834 -- this happens in the case of a generic instantiation, which
1835 -- gets transformed into the instance body (and the instance
1836 -- spec is also created). With clauses pointing to the
1837 -- instantiation end up pointing to the instance body.
1843 procedure Assert_Done (Withed_Unit : Node_Id) is
1845 if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
1847 (Unit (Withed_Unit),
1848 N_Generic_Package_Declaration,
1850 N_Package_Renaming_Declaration,
1854 (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit)));
1855 Write_Str (" not yet walked!");
1857 if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
1858 Write_Str (" (self-ref)");
1863 pragma Assert (False);
1868 procedure Assert_Withed_Units_Done is
1869 new Walk_Withs (Assert_Done);
1872 if Debug_Unit_Walk then
1873 Write_Unit_Info (Unit_Num, Item, Withs => True);
1876 -- Main unit should come last, except in the case where we
1877 -- skipped System_Aux_Id, in which case we missed the things it
1878 -- depends on, and in the case of parent bodies if present.
1881 (not Done (Main_Unit)
1882 or else Present (System_Aux_Id)
1883 or else Nkind (Item) = N_Package_Body);
1885 -- We shouldn't do the same thing twice
1887 pragma Assert (not Done (Unit_Num));
1889 -- Everything we depend upon should already be done
1892 (Assert_Withed_Units_Done (CU, Include_Limited => False));
1896 -- Must be Standard, which has no entry in the units table
1898 pragma Assert (Item = Stand.Standard_Package_Node);
1900 if Debug_Unit_Walk then
1901 Write_Line ("Standard");
1908 --------------------
1909 -- Do_Withed_Unit --
1910 --------------------
1912 procedure Do_Withed_Unit (Withed_Unit : Node_Id) is
1914 Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit));
1916 -- If the unit in the with_clause is a generic instance, the clause
1917 -- now denotes the instance body. Traverse the corresponding spec
1918 -- because there may be no other dependence that will force the
1919 -- traversal of its own context.
1921 if Nkind (Unit (Withed_Unit)) = N_Package_Body
1922 and then Is_Generic_Instance
1923 (Defining_Entity (Unit (Library_Unit (Withed_Unit))))
1925 Do_Withed_Unit (Library_Unit (Withed_Unit));
1929 ----------------------------
1930 -- Do_Unit_And_Dependents --
1931 ----------------------------
1933 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
1934 Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU);
1936 Body_U : Unit_Number_Type;
1937 Parent_CU : Node_Id;
1939 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
1942 if not Seen (Unit_Num) then
1944 -- Process the with clauses
1946 Do_Withed_Units (CU, Include_Limited => False);
1948 -- Process the unit if it is a spec or the main unit, if it
1949 -- has no previous spec or we have done all other units.
1951 if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
1952 or else Acts_As_Spec (CU)
1954 if CU = Main_CU and then not Do_Main then
1955 Seen (Unit_Num) := False;
1958 Seen (Unit_Num) := True;
1960 if CU = Library_Unit (Main_CU) then
1961 Process_Bodies_In_Context (CU);
1963 -- If main is a child unit, examine parent unit contexts
1964 -- to see if they include instantiated units. Also, if
1965 -- the parent itself is an instance, process its body
1966 -- because it may contain subprograms that are called
1967 -- in the main unit.
1969 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
1970 Child := Cunit_Entity (Main_Unit);
1971 while Is_Child_Unit (Child) loop
1974 (Get_Cunit_Entity_Unit_Number (Scope (Child)));
1975 Process_Bodies_In_Context (Parent_CU);
1977 if Nkind (Unit (Parent_CU)) = N_Package_Body
1979 Nkind (Original_Node (Unit (Parent_CU)))
1980 = N_Package_Instantiation
1982 not Seen (Get_Cunit_Unit_Number (Parent_CU))
1984 Body_U := Get_Cunit_Unit_Number (Parent_CU);
1985 Seen (Body_U) := True;
1986 Do_Action (Parent_CU, Unit (Parent_CU));
1987 Done (Body_U) := True;
1990 Child := Scope (Child);
1995 Do_Action (CU, Item);
1996 Done (Unit_Num) := True;
2000 end Do_Unit_And_Dependents;
2002 -------------------------------
2003 -- Process_Bodies_In_Context --
2004 -------------------------------
2006 procedure Process_Bodies_In_Context (Comp : Node_Id) is
2008 Body_U : Unit_Number_Type;
2012 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
2014 -- Start of processing for Process_Bodies_In_Context
2017 Clause := First (Context_Items (Comp));
2018 while Present (Clause) loop
2019 if Nkind (Clause) = N_With_Clause then
2020 Spec := Library_Unit (Clause);
2021 Body_CU := Library_Unit (Spec);
2023 -- If we are processing the spec of the main unit, load bodies
2024 -- only if the with_clause indicates that it forced the loading
2025 -- of the body for a generic instantiation. Note that bodies of
2026 -- parents that are instances have been loaded already.
2028 if Present (Body_CU)
2029 and then Body_CU /= Main_CU
2030 and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body
2031 and then Nkind (Unit (Comp)) /= N_Package_Declaration
2033 Body_U := Get_Cunit_Unit_Number (Body_CU);
2035 if not Seen (Body_U)
2036 and then not Depends_On_Main (Body_CU)
2038 Seen (Body_U) := True;
2039 Do_Withed_Units (Body_CU, Include_Limited => False);
2040 Do_Action (Body_CU, Unit (Body_CU));
2041 Done (Body_U) := True;
2048 end Process_Bodies_In_Context;
2050 -- Local Declarations
2054 -- Start of processing for Walk_Library_Items
2057 if Debug_Unit_Walk then
2058 Write_Line ("Walk_Library_Items:");
2062 -- Do Standard first, then walk the Comp_Unit_List
2064 Do_Action (Empty, Standard_Package_Node);
2066 -- First place the context of all instance bodies on the corresponding
2067 -- spec, because it may be needed to analyze the code at the place of
2068 -- the instantiation.
2070 Cur := First_Elmt (Comp_Unit_List);
2071 while Present (Cur) loop
2073 CU : constant Node_Id := Node (Cur);
2074 N : constant Node_Id := Unit (CU);
2077 if Nkind (N) = N_Package_Body
2078 and then Is_Generic_Instance (Defining_Entity (N))
2081 (Context_Items (CU), Context_Items (Library_Unit (CU)));
2088 -- Now traverse compilation units (specs) in order
2090 Cur := First_Elmt (Comp_Unit_List);
2091 while Present (Cur) loop
2093 CU : constant Node_Id := Node (Cur);
2094 N : constant Node_Id := Unit (CU);
2098 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2102 -- If it is a subprogram body, process it if it has no
2105 -- If it's a package body, ignore it, unless it is a body
2106 -- created for an instance that is the main unit. In the case
2107 -- of subprograms, the body is the wrapper package. In case of
2108 -- a package, the original file carries the body, and the spec
2109 -- appears as a later entry in the units list.
2111 -- Otherwise bodies appear in the list only because of inlining
2112 -- or instantiations, and they are processed only if relevant.
2113 -- The flag Withed_Body on a context clause indicates that a
2114 -- unit contains an instantiation that may be needed later,
2115 -- and therefore the body that contains the generic body (and
2116 -- its context) must be traversed immediately after the
2117 -- corresponding spec (see Do_Unit_And_Dependents).
2119 -- The main unit itself is processed separately after all other
2120 -- specs, and relevant bodies are examined in Process_Main.
2122 when N_Subprogram_Body =>
2123 if Acts_As_Spec (N) then
2124 Do_Unit_And_Dependents (CU, N);
2127 when N_Package_Body =>
2129 and then Nkind (Original_Node (Unit (Main_CU))) in
2130 N_Generic_Instantiation
2131 and then Present (Library_Unit (Main_CU))
2133 Do_Unit_And_Dependents
2134 (Library_Unit (Main_CU),
2135 Unit (Library_Unit (Main_CU)));
2138 -- It is a spec, process it, and the units it depends on,
2139 -- unless it is a descendant of the main unit. This can happen
2140 -- when the body of a parent depends on some other descendant.
2142 when N_Null_Statement =>
2144 -- Ignore an ignored ghost unit
2146 pragma Assert (Is_Ignored_Ghost_Node (Original_Node (N)));
2150 Par := Scope (Defining_Entity (Unit (CU)));
2152 if Is_Child_Unit (Defining_Entity (Unit (CU))) then
2154 and then Par /= Standard_Standard
2155 and then Par /= Cunit_Entity (Main_Unit)
2161 if Par /= Cunit_Entity (Main_Unit) then
2162 Do_Unit_And_Dependents (CU, N);
2171 -- Now process package bodies on which main depends, followed by bodies
2172 -- of parents, if present, and finally main itself.
2174 if not Done (Main_Unit) then
2177 Process_Main : declare
2178 Parent_CU : Node_Id;
2180 Body_U : Unit_Number_Type;
2183 function Is_Subunit_Of_Main (U : Node_Id) return Boolean;
2184 -- If the main unit has subunits, their context may include
2185 -- bodies that are needed in the body of main. We must examine
2186 -- the context of the subunits, which are otherwise not made
2187 -- explicit in the main unit.
2189 ------------------------
2190 -- Is_Subunit_Of_Main --
2191 ------------------------
2193 function Is_Subunit_Of_Main (U : Node_Id) return Boolean is
2197 if Present (U) and then Nkind (Unit (U)) = N_Subunit then
2198 Lib := Library_Unit (U);
2199 return Lib = Main_CU or else Is_Subunit_Of_Main (Lib);
2203 end Is_Subunit_Of_Main;
2205 -- Start of processing for Process_Main
2208 Process_Bodies_In_Context (Main_CU);
2210 for Unit_Num in Done'Range loop
2211 if Is_Subunit_Of_Main (Cunit (Unit_Num)) then
2212 Process_Bodies_In_Context (Cunit (Unit_Num));
2216 -- If the main unit is a child unit, parent bodies may be present
2217 -- because they export instances or inlined subprograms. Check for
2218 -- presence of these, which are not present in context clauses.
2219 -- Note that if the parents are instances, their bodies have been
2220 -- processed before the main spec, because they may be needed
2221 -- therein, so the following loop only affects non-instances.
2223 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
2224 Child := Cunit_Entity (Main_Unit);
2225 while Is_Child_Unit (Child) loop
2227 Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child)));
2228 Body_CU := Library_Unit (Parent_CU);
2230 if Present (Body_CU)
2231 and then not Seen (Get_Cunit_Unit_Number (Body_CU))
2232 and then not Depends_On_Main (Body_CU)
2234 Body_U := Get_Cunit_Unit_Number (Body_CU);
2235 Seen (Body_U) := True;
2236 Do_Action (Body_CU, Unit (Body_CU));
2237 Done (Body_U) := True;
2240 Child := Scope (Child);
2244 Do_Action (Main_CU, Unit (Main_CU));
2245 Done (Main_Unit) := True;
2249 if Debug_Unit_Walk then
2250 if Done /= (Done'Range => True) then
2252 Write_Line ("Ignored units:");
2256 for Unit_Num in Done'Range loop
2257 if not Done (Unit_Num) then
2259 -- Units with configuration pragmas (.ads files) have empty
2260 -- compilation-unit nodes; skip printing info about them.
2262 if Present (Cunit (Unit_Num)) then
2264 (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True);
2273 pragma Assert (Done (Main_Unit));
2275 if Debug_Unit_Walk then
2277 Write_Line ("end Walk_Library_Items.");
2279 end Walk_Library_Items;
2285 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is
2286 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2287 pragma Assert (Nkind (Unit (CU)) /= N_Subunit);
2289 procedure Walk_Immediate is new Walk_Withs_Immediate (Action);
2292 -- First walk the withs immediately on the library item
2294 Walk_Immediate (CU, Include_Limited);
2296 -- For a body, we must also check for any subunits which belong to it
2297 -- and which have context clauses of their own, since these with'ed
2298 -- units are part of its own dependencies.
2300 if Nkind (Unit (CU)) in N_Unit_Body then
2301 for S in Main_Unit .. Last_Unit loop
2303 -- We are only interested in subunits. For preproc. data and def.
2304 -- files, Cunit is Empty, so we need to test that first.
2306 if Cunit (S) /= Empty
2307 and then Nkind (Unit (Cunit (S))) = N_Subunit
2313 Pnode := Library_Unit (Cunit (S));
2315 -- In -gnatc mode, the errors in the subunits will not have
2316 -- been recorded, but the analysis of the subunit may have
2317 -- failed, so just quit.
2323 -- Find ultimate parent of the subunit
2325 while Nkind (Unit (Pnode)) = N_Subunit loop
2326 Pnode := Library_Unit (Pnode);
2329 -- See if it belongs to current unit, and if so, include its
2330 -- with_clauses. Do not process main unit prematurely.
2332 if Pnode = CU and then CU /= Cunit (Main_Unit) then
2333 Walk_Immediate (Cunit (S), Include_Limited);
2341 --------------------------
2342 -- Walk_Withs_Immediate --
2343 --------------------------
2345 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is
2346 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2348 Context_Item : Node_Id;
2352 Context_Item := First (Context_Items (CU));
2353 while Present (Context_Item) loop
2354 if Nkind (Context_Item) = N_With_Clause
2355 and then (Include_Limited
2356 or else not Limited_Present (Context_Item))
2358 Lib_Unit := Library_Unit (Context_Item);
2362 Context_Item := Next (Context_Item);
2364 end Walk_Withs_Immediate;