File : sem.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
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 Fname; use Fname;
33 with Ghost; use Ghost;
34 with Lib; use Lib;
35 with Lib.Load; use Lib.Load;
36 with Nlists; use Nlists;
37 with Output; use Output;
38 with Restrict; use Restrict;
39 with Sem_Attr; use Sem_Attr;
40 with Sem_Aux; use Sem_Aux;
41 with Sem_Ch2; use Sem_Ch2;
42 with Sem_Ch3; use Sem_Ch3;
43 with Sem_Ch4; use Sem_Ch4;
44 with Sem_Ch5; use Sem_Ch5;
45 with Sem_Ch6; use Sem_Ch6;
46 with Sem_Ch7; use Sem_Ch7;
47 with Sem_Ch8; use Sem_Ch8;
48 with Sem_Ch9; use Sem_Ch9;
49 with Sem_Ch10; use Sem_Ch10;
50 with Sem_Ch11; use Sem_Ch11;
51 with Sem_Ch12; use Sem_Ch12;
52 with Sem_Ch13; use Sem_Ch13;
53 with Sem_Prag; use Sem_Prag;
54 with Sem_Util; use Sem_Util;
55 with Sinfo; use Sinfo;
56 with Stand; use Stand;
57 with Stylesw; use Stylesw;
58 with Uintp; use Uintp;
59 with Uname; use Uname;
60
61 with Unchecked_Deallocation;
62
63 pragma Warnings (Off, Sem_Util);
64 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
65
66 package body Sem is
67
68 Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW;
69 -- Controls debugging printouts for Walk_Library_Items
70
71 Outer_Generic_Scope : Entity_Id := Empty;
72 -- Global reference to the outer scope that is generic. In a non-generic
73 -- context, it is empty. At the moment, it is only used for avoiding
74 -- freezing of external references in generics.
75
76 Comp_Unit_List : Elist_Id := No_Elist;
77 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
78 -- processed by Semantics, in an appropriate order. Initialized to
79 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
80 -- to New_Elmt_List on first use.
81
82 generic
83 with procedure Action (Withed_Unit : Node_Id);
84 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean);
85 -- Walk all the with clauses of CU, and call Action for the with'ed unit.
86 -- Ignore limited withs, unless Include_Limited is True. CU must be an
87 -- N_Compilation_Unit.
88
89 generic
90 with procedure Action (Withed_Unit : Node_Id);
91 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean);
92 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
93 -- of this unit, since they count as dependences on their parent library
94 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
95
96 -------------
97 -- Analyze --
98 -------------
99
100 procedure Analyze (N : Node_Id) is
101 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
102
103 begin
104 Debug_A_Entry ("analyzing ", N);
105
106 -- Immediate return if already analyzed
107
108 if Analyzed (N) then
109 Debug_A_Exit ("analyzing ", N, " (done, analyzed already)");
110 return;
111 end if;
112
113 -- A declaration may be subject to pragma Ghost. Set the mode now to
114 -- ensure that any nodes generated during analysis and expansion are
115 -- marked as Ghost.
116
117 if Is_Declaration (N) then
118 Set_Ghost_Mode (N);
119 end if;
120
121 -- Otherwise processing depends on the node kind
122
123 case Nkind (N) is
124 when N_Abort_Statement =>
125 Analyze_Abort_Statement (N);
126
127 when N_Abstract_Subprogram_Declaration =>
128 Analyze_Abstract_Subprogram_Declaration (N);
129
130 when N_Accept_Alternative =>
131 Analyze_Accept_Alternative (N);
132
133 when N_Accept_Statement =>
134 Analyze_Accept_Statement (N);
135
136 when N_Aggregate =>
137 Analyze_Aggregate (N);
138
139 when N_Allocator =>
140 Analyze_Allocator (N);
141
142 when N_And_Then =>
143 Analyze_Short_Circuit (N);
144
145 when N_Assignment_Statement =>
146 Analyze_Assignment (N);
147
148 when N_Asynchronous_Select =>
149 Analyze_Asynchronous_Select (N);
150
151 when N_At_Clause =>
152 Analyze_At_Clause (N);
153
154 when N_Attribute_Reference =>
155 Analyze_Attribute (N);
156
157 when N_Attribute_Definition_Clause =>
158 Analyze_Attribute_Definition_Clause (N);
159
160 when N_Block_Statement =>
161 Analyze_Block_Statement (N);
162
163 when N_Case_Expression =>
164 Analyze_Case_Expression (N);
165
166 when N_Case_Statement =>
167 Analyze_Case_Statement (N);
168
169 when N_Character_Literal =>
170 Analyze_Character_Literal (N);
171
172 when N_Code_Statement =>
173 Analyze_Code_Statement (N);
174
175 when N_Compilation_Unit =>
176 Analyze_Compilation_Unit (N);
177
178 when N_Component_Declaration =>
179 Analyze_Component_Declaration (N);
180
181 when N_Compound_Statement =>
182 Analyze_Compound_Statement (N);
183
184 when N_Conditional_Entry_Call =>
185 Analyze_Conditional_Entry_Call (N);
186
187 when N_Delay_Alternative =>
188 Analyze_Delay_Alternative (N);
189
190 when N_Delay_Relative_Statement =>
191 Analyze_Delay_Relative (N);
192
193 when N_Delay_Until_Statement =>
194 Analyze_Delay_Until (N);
195
196 when N_Entry_Body =>
197 Analyze_Entry_Body (N);
198
199 when N_Entry_Body_Formal_Part =>
200 Analyze_Entry_Body_Formal_Part (N);
201
202 when N_Entry_Call_Alternative =>
203 Analyze_Entry_Call_Alternative (N);
204
205 when N_Entry_Declaration =>
206 Analyze_Entry_Declaration (N);
207
208 when N_Entry_Index_Specification =>
209 Analyze_Entry_Index_Specification (N);
210
211 when N_Enumeration_Representation_Clause =>
212 Analyze_Enumeration_Representation_Clause (N);
213
214 when N_Exception_Declaration =>
215 Analyze_Exception_Declaration (N);
216
217 when N_Exception_Renaming_Declaration =>
218 Analyze_Exception_Renaming (N);
219
220 when N_Exit_Statement =>
221 Analyze_Exit_Statement (N);
222
223 when N_Expanded_Name =>
224 Analyze_Expanded_Name (N);
225
226 when N_Explicit_Dereference =>
227 Analyze_Explicit_Dereference (N);
228
229 when N_Expression_Function =>
230 Analyze_Expression_Function (N);
231
232 when N_Expression_With_Actions =>
233 Analyze_Expression_With_Actions (N);
234
235 when N_Extended_Return_Statement =>
236 Analyze_Extended_Return_Statement (N);
237
238 when N_Extension_Aggregate =>
239 Analyze_Aggregate (N);
240
241 when N_Formal_Object_Declaration =>
242 Analyze_Formal_Object_Declaration (N);
243
244 when N_Formal_Package_Declaration =>
245 Analyze_Formal_Package_Declaration (N);
246
247 when N_Formal_Subprogram_Declaration =>
248 Analyze_Formal_Subprogram_Declaration (N);
249
250 when N_Formal_Type_Declaration =>
251 Analyze_Formal_Type_Declaration (N);
252
253 when N_Free_Statement =>
254 Analyze_Free_Statement (N);
255
256 when N_Freeze_Entity =>
257 Analyze_Freeze_Entity (N);
258
259 when N_Freeze_Generic_Entity =>
260 Analyze_Freeze_Generic_Entity (N);
261
262 when N_Full_Type_Declaration =>
263 Analyze_Full_Type_Declaration (N);
264
265 when N_Function_Call =>
266 Analyze_Function_Call (N);
267
268 when N_Function_Instantiation =>
269 Analyze_Function_Instantiation (N);
270
271 when N_Generic_Function_Renaming_Declaration =>
272 Analyze_Generic_Function_Renaming (N);
273
274 when N_Generic_Package_Declaration =>
275 Analyze_Generic_Package_Declaration (N);
276
277 when N_Generic_Package_Renaming_Declaration =>
278 Analyze_Generic_Package_Renaming (N);
279
280 when N_Generic_Procedure_Renaming_Declaration =>
281 Analyze_Generic_Procedure_Renaming (N);
282
283 when N_Generic_Subprogram_Declaration =>
284 Analyze_Generic_Subprogram_Declaration (N);
285
286 when N_Goto_Statement =>
287 Analyze_Goto_Statement (N);
288
289 when N_Handled_Sequence_Of_Statements =>
290 Analyze_Handled_Statements (N);
291
292 when N_Identifier =>
293 Analyze_Identifier (N);
294
295 when N_If_Expression =>
296 Analyze_If_Expression (N);
297
298 when N_If_Statement =>
299 Analyze_If_Statement (N);
300
301 when N_Implicit_Label_Declaration =>
302 Analyze_Implicit_Label_Declaration (N);
303
304 when N_In =>
305 Analyze_Membership_Op (N);
306
307 when N_Incomplete_Type_Declaration =>
308 Analyze_Incomplete_Type_Decl (N);
309
310 when N_Indexed_Component =>
311 Analyze_Indexed_Component_Form (N);
312
313 when N_Integer_Literal =>
314 Analyze_Integer_Literal (N);
315
316 when N_Iterator_Specification =>
317 Analyze_Iterator_Specification (N);
318
319 when N_Itype_Reference =>
320 Analyze_Itype_Reference (N);
321
322 when N_Label =>
323 Analyze_Label (N);
324
325 when N_Loop_Parameter_Specification =>
326 Analyze_Loop_Parameter_Specification (N);
327
328 when N_Loop_Statement =>
329 Analyze_Loop_Statement (N);
330
331 when N_Not_In =>
332 Analyze_Membership_Op (N);
333
334 when N_Null =>
335 Analyze_Null (N);
336
337 when N_Null_Statement =>
338 Analyze_Null_Statement (N);
339
340 when N_Number_Declaration =>
341 Analyze_Number_Declaration (N);
342
343 when N_Object_Declaration =>
344 Analyze_Object_Declaration (N);
345
346 when N_Object_Renaming_Declaration =>
347 Analyze_Object_Renaming (N);
348
349 when N_Operator_Symbol =>
350 Analyze_Operator_Symbol (N);
351
352 when N_Op_Abs =>
353 Analyze_Unary_Op (N);
354
355 when N_Op_Add =>
356 Analyze_Arithmetic_Op (N);
357
358 when N_Op_And =>
359 Analyze_Logical_Op (N);
360
361 when N_Op_Concat =>
362 Analyze_Concatenation (N);
363
364 when N_Op_Divide =>
365 Analyze_Arithmetic_Op (N);
366
367 when N_Op_Eq =>
368 Analyze_Equality_Op (N);
369
370 when N_Op_Expon =>
371 Analyze_Arithmetic_Op (N);
372
373 when N_Op_Ge =>
374 Analyze_Comparison_Op (N);
375
376 when N_Op_Gt =>
377 Analyze_Comparison_Op (N);
378
379 when N_Op_Le =>
380 Analyze_Comparison_Op (N);
381
382 when N_Op_Lt =>
383 Analyze_Comparison_Op (N);
384
385 when N_Op_Minus =>
386 Analyze_Unary_Op (N);
387
388 when N_Op_Mod =>
389 Analyze_Mod (N);
390
391 when N_Op_Multiply =>
392 Analyze_Arithmetic_Op (N);
393
394 when N_Op_Ne =>
395 Analyze_Equality_Op (N);
396
397 when N_Op_Not =>
398 Analyze_Negation (N);
399
400 when N_Op_Or =>
401 Analyze_Logical_Op (N);
402
403 when N_Op_Plus =>
404 Analyze_Unary_Op (N);
405
406 when N_Op_Rem =>
407 Analyze_Arithmetic_Op (N);
408
409 when N_Op_Rotate_Left =>
410 Analyze_Arithmetic_Op (N);
411
412 when N_Op_Rotate_Right =>
413 Analyze_Arithmetic_Op (N);
414
415 when N_Op_Shift_Left =>
416 Analyze_Arithmetic_Op (N);
417
418 when N_Op_Shift_Right =>
419 Analyze_Arithmetic_Op (N);
420
421 when N_Op_Shift_Right_Arithmetic =>
422 Analyze_Arithmetic_Op (N);
423
424 when N_Op_Subtract =>
425 Analyze_Arithmetic_Op (N);
426
427 when N_Op_Xor =>
428 Analyze_Logical_Op (N);
429
430 when N_Or_Else =>
431 Analyze_Short_Circuit (N);
432
433 when N_Others_Choice =>
434 Analyze_Others_Choice (N);
435
436 when N_Package_Body =>
437 Analyze_Package_Body (N);
438
439 when N_Package_Body_Stub =>
440 Analyze_Package_Body_Stub (N);
441
442 when N_Package_Declaration =>
443 Analyze_Package_Declaration (N);
444
445 when N_Package_Instantiation =>
446 Analyze_Package_Instantiation (N);
447
448 when N_Package_Renaming_Declaration =>
449 Analyze_Package_Renaming (N);
450
451 when N_Package_Specification =>
452 Analyze_Package_Specification (N);
453
454 when N_Parameter_Association =>
455 Analyze_Parameter_Association (N);
456
457 when N_Pragma =>
458 Analyze_Pragma (N);
459
460 when N_Private_Extension_Declaration =>
461 Analyze_Private_Extension_Declaration (N);
462
463 when N_Private_Type_Declaration =>
464 Analyze_Private_Type_Declaration (N);
465
466 when N_Procedure_Call_Statement =>
467 Analyze_Procedure_Call (N);
468
469 when N_Procedure_Instantiation =>
470 Analyze_Procedure_Instantiation (N);
471
472 when N_Protected_Body =>
473 Analyze_Protected_Body (N);
474
475 when N_Protected_Body_Stub =>
476 Analyze_Protected_Body_Stub (N);
477
478 when N_Protected_Definition =>
479 Analyze_Protected_Definition (N);
480
481 when N_Protected_Type_Declaration =>
482 Analyze_Protected_Type_Declaration (N);
483
484 when N_Qualified_Expression =>
485 Analyze_Qualified_Expression (N);
486
487 when N_Quantified_Expression =>
488 Analyze_Quantified_Expression (N);
489
490 when N_Raise_Expression =>
491 Analyze_Raise_Expression (N);
492
493 when N_Raise_Statement =>
494 Analyze_Raise_Statement (N);
495
496 when N_Raise_xxx_Error =>
497 Analyze_Raise_xxx_Error (N);
498
499 when N_Range =>
500 Analyze_Range (N);
501
502 when N_Range_Constraint =>
503 Analyze_Range (Range_Expression (N));
504
505 when N_Real_Literal =>
506 Analyze_Real_Literal (N);
507
508 when N_Record_Representation_Clause =>
509 Analyze_Record_Representation_Clause (N);
510
511 when N_Reference =>
512 Analyze_Reference (N);
513
514 when N_Requeue_Statement =>
515 Analyze_Requeue (N);
516
517 when N_Simple_Return_Statement =>
518 Analyze_Simple_Return_Statement (N);
519
520 when N_Selected_Component =>
521 Find_Selected_Component (N);
522 -- ??? why not Analyze_Selected_Component, needs comments
523
524 when N_Selective_Accept =>
525 Analyze_Selective_Accept (N);
526
527 when N_Single_Protected_Declaration =>
528 Analyze_Single_Protected_Declaration (N);
529
530 when N_Single_Task_Declaration =>
531 Analyze_Single_Task_Declaration (N);
532
533 when N_Slice =>
534 Analyze_Slice (N);
535
536 when N_String_Literal =>
537 Analyze_String_Literal (N);
538
539 when N_Subprogram_Body =>
540 Analyze_Subprogram_Body (N);
541
542 when N_Subprogram_Body_Stub =>
543 Analyze_Subprogram_Body_Stub (N);
544
545 when N_Subprogram_Declaration =>
546 Analyze_Subprogram_Declaration (N);
547
548 when N_Subprogram_Renaming_Declaration =>
549 Analyze_Subprogram_Renaming (N);
550
551 when N_Subtype_Declaration =>
552 Analyze_Subtype_Declaration (N);
553
554 when N_Subtype_Indication =>
555 Analyze_Subtype_Indication (N);
556
557 when N_Subunit =>
558 Analyze_Subunit (N);
559
560 when N_Task_Body =>
561 Analyze_Task_Body (N);
562
563 when N_Task_Body_Stub =>
564 Analyze_Task_Body_Stub (N);
565
566 when N_Task_Definition =>
567 Analyze_Task_Definition (N);
568
569 when N_Task_Type_Declaration =>
570 Analyze_Task_Type_Declaration (N);
571
572 when N_Terminate_Alternative =>
573 Analyze_Terminate_Alternative (N);
574
575 when N_Timed_Entry_Call =>
576 Analyze_Timed_Entry_Call (N);
577
578 when N_Triggering_Alternative =>
579 Analyze_Triggering_Alternative (N);
580
581 when N_Type_Conversion =>
582 Analyze_Type_Conversion (N);
583
584 when N_Unchecked_Expression =>
585 Analyze_Unchecked_Expression (N);
586
587 when N_Unchecked_Type_Conversion =>
588 Analyze_Unchecked_Type_Conversion (N);
589
590 when N_Use_Package_Clause =>
591 Analyze_Use_Package (N);
592
593 when N_Use_Type_Clause =>
594 Analyze_Use_Type (N);
595
596 when N_Validate_Unchecked_Conversion =>
597 null;
598
599 when N_Variant_Part =>
600 Analyze_Variant_Part (N);
601
602 when N_With_Clause =>
603 Analyze_With_Clause (N);
604
605 -- A call to analyze the Empty node is an error, but most likely it
606 -- is an error caused by an attempt to analyze a malformed piece of
607 -- tree caused by some other error, so if there have been any other
608 -- errors, we just ignore it, otherwise it is a real internal error
609 -- which we complain about.
610
611 -- We must also consider the case of call to a runtime function that
612 -- is not available in the configurable runtime.
613
614 when N_Empty =>
615 pragma Assert (Serious_Errors_Detected /= 0
616 or else Configurable_Run_Time_Violations /= 0);
617 null;
618
619 -- A call to analyze the error node is simply ignored, to avoid
620 -- causing cascaded errors (happens of course only in error cases)
621 -- Disable expansion in case it is still enabled, to prevent other
622 -- subsequent compiler glitches.
623
624 when N_Error =>
625 Expander_Mode_Save_And_Set (False);
626 null;
627
628 -- Push/Pop nodes normally don't come through an analyze call. An
629 -- exception is the dummy ones bracketing a subprogram body. In any
630 -- case there is nothing to be done to analyze such nodes.
631
632 when N_Push_Pop_xxx_Label =>
633 null;
634
635 -- SCIL nodes don't need analysis because they are decorated when
636 -- they are built. They are added to the tree by Insert_Actions and
637 -- the call to analyze them is generated when the full list is
638 -- analyzed.
639
640 when N_SCIL_Dispatch_Table_Tag_Init |
641 N_SCIL_Dispatching_Call |
642 N_SCIL_Membership_Test =>
643 null;
644
645 -- For the remaining node types, we generate compiler abort, because
646 -- these nodes are always analyzed within the Sem_Chn routines and
647 -- there should never be a case of making a call to the main Analyze
648 -- routine for these node kinds. For example, an N_Access_Definition
649 -- node appears only in the context of a type declaration, and is
650 -- processed by the analyze routine for type declarations.
651
652 when N_Abortable_Part |
653 N_Access_Definition |
654 N_Access_Function_Definition |
655 N_Access_Procedure_Definition |
656 N_Access_To_Object_Definition |
657 N_Aspect_Specification |
658 N_Case_Expression_Alternative |
659 N_Case_Statement_Alternative |
660 N_Compilation_Unit_Aux |
661 N_Component_Association |
662 N_Component_Clause |
663 N_Component_Definition |
664 N_Component_List |
665 N_Constrained_Array_Definition |
666 N_Contract |
667 N_Decimal_Fixed_Point_Definition |
668 N_Defining_Character_Literal |
669 N_Defining_Identifier |
670 N_Defining_Operator_Symbol |
671 N_Defining_Program_Unit_Name |
672 N_Delta_Constraint |
673 N_Derived_Type_Definition |
674 N_Designator |
675 N_Digits_Constraint |
676 N_Discriminant_Association |
677 N_Discriminant_Specification |
678 N_Elsif_Part |
679 N_Entry_Call_Statement |
680 N_Enumeration_Type_Definition |
681 N_Exception_Handler |
682 N_Floating_Point_Definition |
683 N_Formal_Decimal_Fixed_Point_Definition |
684 N_Formal_Derived_Type_Definition |
685 N_Formal_Discrete_Type_Definition |
686 N_Formal_Floating_Point_Definition |
687 N_Formal_Modular_Type_Definition |
688 N_Formal_Ordinary_Fixed_Point_Definition |
689 N_Formal_Private_Type_Definition |
690 N_Formal_Incomplete_Type_Definition |
691 N_Formal_Signed_Integer_Type_Definition |
692 N_Function_Specification |
693 N_Generic_Association |
694 N_Index_Or_Discriminant_Constraint |
695 N_Iteration_Scheme |
696 N_Mod_Clause |
697 N_Modular_Type_Definition |
698 N_Ordinary_Fixed_Point_Definition |
699 N_Parameter_Specification |
700 N_Pragma_Argument_Association |
701 N_Procedure_Specification |
702 N_Real_Range_Specification |
703 N_Record_Definition |
704 N_Signed_Integer_Type_Definition |
705 N_Unconstrained_Array_Definition |
706 N_Unused_At_Start |
707 N_Unused_At_End |
708 N_Variant =>
709 raise Program_Error;
710 end case;
711
712 Debug_A_Exit ("analyzing ", N, " (done)");
713
714 -- Now that we have analyzed the node, we call the expander to perform
715 -- possible expansion. We skip this for subexpressions, because we don't
716 -- have the type yet, and the expander will need to know the type before
717 -- it can do its job. For subexpression nodes, the call to the expander
718 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
719 -- which can appear in a statement context, and needs expanding now in
720 -- the case (distinguished by Etype, as documented in Sinfo).
721
722 -- The Analyzed flag is also set at this point for non-subexpression
723 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
724 -- since resolution and expansion have not yet been completed). Note
725 -- that for N_Raise_xxx_Error we have to distinguish the expression
726 -- case from the statement case.
727
728 if Nkind (N) not in N_Subexpr
729 or else (Nkind (N) in N_Raise_xxx_Error
730 and then Etype (N) = Standard_Void_Type)
731 then
732 Expand (N);
733
734 -- Replace a reference to a renaming with the renamed object for SPARK.
735 -- In general this modification is performed by Expand_SPARK, however
736 -- certain constructs may not reach the resolution or expansion phase
737 -- and thus remain unchanged. The replacement is not performed when the
738 -- construct is overloaded as resolution must first take place. This is
739 -- also not done when analyzing a generic to preserve the original tree
740 -- and because the reference may become overloaded in the instance.
741
742 elsif GNATprove_Mode
743 and then Nkind_In (N, N_Expanded_Name, N_Identifier)
744 and then not Is_Overloaded (N)
745 and then not Inside_A_Generic
746 then
747 Expand_SPARK_Potential_Renaming (N);
748 end if;
749
750 Ghost_Mode := Save_Ghost_Mode;
751 end Analyze;
752
753 -- Version with check(s) suppressed
754
755 procedure Analyze (N : Node_Id; Suppress : Check_Id) is
756 begin
757 if Suppress = All_Checks then
758 declare
759 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
760 begin
761 Scope_Suppress.Suppress := (others => True);
762 Analyze (N);
763 Scope_Suppress.Suppress := Svs;
764 end;
765
766 elsif Suppress = Overflow_Check then
767 declare
768 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
769 begin
770 Scope_Suppress.Suppress (Suppress) := True;
771 Analyze (N);
772 Scope_Suppress.Suppress (Suppress) := Svg;
773 end;
774 end if;
775 end Analyze;
776
777 ------------------
778 -- Analyze_List --
779 ------------------
780
781 procedure Analyze_List (L : List_Id) is
782 Node : Node_Id;
783
784 begin
785 Node := First (L);
786 while Present (Node) loop
787 Analyze (Node);
788 Next (Node);
789 end loop;
790 end Analyze_List;
791
792 -- Version with check(s) suppressed
793
794 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
795 begin
796 if Suppress = All_Checks then
797 declare
798 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
799 begin
800 Scope_Suppress.Suppress := (others => True);
801 Analyze_List (L);
802 Scope_Suppress.Suppress := Svs;
803 end;
804
805 else
806 declare
807 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
808 begin
809 Scope_Suppress.Suppress (Suppress) := True;
810 Analyze_List (L);
811 Scope_Suppress.Suppress (Suppress) := Svg;
812 end;
813 end if;
814 end Analyze_List;
815
816 --------------------------
817 -- Copy_Suppress_Status --
818 --------------------------
819
820 procedure Copy_Suppress_Status
821 (C : Check_Id;
822 From : Entity_Id;
823 To : Entity_Id)
824 is
825 Found : Boolean;
826 pragma Warnings (Off, Found);
827
828 procedure Search_Stack
829 (Top : Suppress_Stack_Entry_Ptr;
830 Found : out Boolean);
831 -- Search given suppress stack for matching entry for entity. If found
832 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
833 -- entry for To onto the local suppress stack.
834
835 ------------------
836 -- Search_Stack --
837 ------------------
838
839 procedure Search_Stack
840 (Top : Suppress_Stack_Entry_Ptr;
841 Found : out Boolean)
842 is
843 Ptr : Suppress_Stack_Entry_Ptr;
844
845 begin
846 Ptr := Top;
847 while Ptr /= null loop
848 if Ptr.Entity = From
849 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
850 then
851 if Ptr.Suppress then
852 Set_Checks_May_Be_Suppressed (To, True);
853 Push_Local_Suppress_Stack_Entry
854 (Entity => To,
855 Check => C,
856 Suppress => True);
857 Found := True;
858 return;
859 end if;
860 end if;
861
862 Ptr := Ptr.Prev;
863 end loop;
864
865 Found := False;
866 return;
867 end Search_Stack;
868
869 -- Start of processing for Copy_Suppress_Status
870
871 begin
872 if not Checks_May_Be_Suppressed (From) then
873 return;
874 end if;
875
876 -- First search the global entity suppress table for a matching entry.
877 -- We also search this in reverse order so that if there are multiple
878 -- pragmas for the same entity, the last one applies.
879
880 Search_Stack (Global_Suppress_Stack_Top, Found);
881
882 if Found then
883 return;
884 end if;
885
886 -- Now search the local entity suppress stack, we search this in
887 -- reverse order so that we get the innermost entry that applies to
888 -- this case if there are nested entries. Note that for the purpose
889 -- of this procedure we are ONLY looking for entries corresponding
890 -- to a two-argument Suppress, where the second argument matches From.
891
892 Search_Stack (Local_Suppress_Stack_Top, Found);
893 end Copy_Suppress_Status;
894
895 -------------------------
896 -- Enter_Generic_Scope --
897 -------------------------
898
899 procedure Enter_Generic_Scope (S : Entity_Id) is
900 begin
901 if No (Outer_Generic_Scope) then
902 Outer_Generic_Scope := S;
903 end if;
904 end Enter_Generic_Scope;
905
906 ------------------------
907 -- Exit_Generic_Scope --
908 ------------------------
909
910 procedure Exit_Generic_Scope (S : Entity_Id) is
911 begin
912 if S = Outer_Generic_Scope then
913 Outer_Generic_Scope := Empty;
914 end if;
915 end Exit_Generic_Scope;
916
917 -----------------------
918 -- Explicit_Suppress --
919 -----------------------
920
921 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
922 Ptr : Suppress_Stack_Entry_Ptr;
923
924 begin
925 if not Checks_May_Be_Suppressed (E) then
926 return False;
927
928 else
929 Ptr := Global_Suppress_Stack_Top;
930 while Ptr /= null loop
931 if Ptr.Entity = E
932 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
933 then
934 return Ptr.Suppress;
935 end if;
936
937 Ptr := Ptr.Prev;
938 end loop;
939 end if;
940
941 return False;
942 end Explicit_Suppress;
943
944 -----------------------------
945 -- External_Ref_In_Generic --
946 -----------------------------
947
948 function External_Ref_In_Generic (E : Entity_Id) return Boolean is
949 Scop : Entity_Id;
950
951 begin
952 -- Entity is global if defined outside of current outer_generic_scope:
953 -- Either the entity has a smaller depth that the outer generic, or it
954 -- is in a different compilation unit, or it is defined within a unit
955 -- in the same compilation, that is not within the outer_generic.
956
957 if No (Outer_Generic_Scope) then
958 return False;
959
960 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
961 or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
962 then
963 return True;
964
965 else
966 Scop := Scope (E);
967 while Present (Scop) loop
968 if Scop = Outer_Generic_Scope then
969 return False;
970 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
971 return True;
972 else
973 Scop := Scope (Scop);
974 end if;
975 end loop;
976
977 return True;
978 end if;
979 end External_Ref_In_Generic;
980
981 ----------------
982 -- Initialize --
983 ----------------
984
985 procedure Initialize is
986 Next : Suppress_Stack_Entry_Ptr;
987
988 procedure Free is new Unchecked_Deallocation
989 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
990
991 begin
992 -- Free any global suppress stack entries from a previous invocation
993 -- of the compiler (in the normal case this loop does nothing).
994
995 while Suppress_Stack_Entries /= null loop
996 Next := Suppress_Stack_Entries.Next;
997 Free (Suppress_Stack_Entries);
998 Suppress_Stack_Entries := Next;
999 end loop;
1000
1001 Local_Suppress_Stack_Top := null;
1002 Global_Suppress_Stack_Top := null;
1003
1004 -- Clear scope stack, and reset global variables
1005
1006 Scope_Stack.Init;
1007 Unloaded_Subunits := False;
1008 end Initialize;
1009
1010 ------------------------------
1011 -- Insert_After_And_Analyze --
1012 ------------------------------
1013
1014 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
1015 Node : Node_Id;
1016
1017 begin
1018 if Present (M) then
1019
1020 -- If we are not at the end of the list, then the easiest
1021 -- coding is simply to insert before our successor.
1022
1023 if Present (Next (N)) then
1024 Insert_Before_And_Analyze (Next (N), M);
1025
1026 -- Case of inserting at the end of the list
1027
1028 else
1029 -- Capture the Node_Id of the node to be inserted. This Node_Id
1030 -- will still be the same after the insert operation.
1031
1032 Node := M;
1033 Insert_After (N, M);
1034
1035 -- Now just analyze from the inserted node to the end of
1036 -- the new list (note that this properly handles the case
1037 -- where any of the analyze calls result in the insertion of
1038 -- nodes after the analyzed node, expecting analysis).
1039
1040 while Present (Node) loop
1041 Analyze (Node);
1042 Mark_Rewrite_Insertion (Node);
1043 Next (Node);
1044 end loop;
1045 end if;
1046 end if;
1047 end Insert_After_And_Analyze;
1048
1049 -- Version with check(s) suppressed
1050
1051 procedure Insert_After_And_Analyze
1052 (N : Node_Id;
1053 M : Node_Id;
1054 Suppress : Check_Id)
1055 is
1056 begin
1057 if Suppress = All_Checks then
1058 declare
1059 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1060 begin
1061 Scope_Suppress.Suppress := (others => True);
1062 Insert_After_And_Analyze (N, M);
1063 Scope_Suppress.Suppress := Svs;
1064 end;
1065
1066 else
1067 declare
1068 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1069 begin
1070 Scope_Suppress.Suppress (Suppress) := True;
1071 Insert_After_And_Analyze (N, M);
1072 Scope_Suppress.Suppress (Suppress) := Svg;
1073 end;
1074 end if;
1075 end Insert_After_And_Analyze;
1076
1077 -------------------------------
1078 -- Insert_Before_And_Analyze --
1079 -------------------------------
1080
1081 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
1082 Node : Node_Id;
1083
1084 begin
1085 if Present (M) then
1086
1087 -- Capture the Node_Id of the first list node to be inserted.
1088 -- This will still be the first node after the insert operation,
1089 -- since Insert_List_After does not modify the Node_Id values.
1090
1091 Node := M;
1092 Insert_Before (N, M);
1093
1094 -- The insertion does not change the Id's of any of the nodes in
1095 -- the list, and they are still linked, so we can simply loop from
1096 -- the original first node until we meet the node before which the
1097 -- insertion is occurring. Note that this properly handles the case
1098 -- where any of the analyzed nodes insert nodes after themselves,
1099 -- expecting them to get analyzed.
1100
1101 while Node /= N loop
1102 Analyze (Node);
1103 Mark_Rewrite_Insertion (Node);
1104 Next (Node);
1105 end loop;
1106 end if;
1107 end Insert_Before_And_Analyze;
1108
1109 -- Version with check(s) suppressed
1110
1111 procedure Insert_Before_And_Analyze
1112 (N : Node_Id;
1113 M : Node_Id;
1114 Suppress : Check_Id)
1115 is
1116 begin
1117 if Suppress = All_Checks then
1118 declare
1119 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1120 begin
1121 Scope_Suppress.Suppress := (others => True);
1122 Insert_Before_And_Analyze (N, M);
1123 Scope_Suppress.Suppress := Svs;
1124 end;
1125
1126 else
1127 declare
1128 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1129 begin
1130 Scope_Suppress.Suppress (Suppress) := True;
1131 Insert_Before_And_Analyze (N, M);
1132 Scope_Suppress.Suppress (Suppress) := Svg;
1133 end;
1134 end if;
1135 end Insert_Before_And_Analyze;
1136
1137 -----------------------------------
1138 -- Insert_List_After_And_Analyze --
1139 -----------------------------------
1140
1141 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
1142 After : constant Node_Id := Next (N);
1143 Node : Node_Id;
1144
1145 begin
1146 if Is_Non_Empty_List (L) then
1147
1148 -- Capture the Node_Id of the first list node to be inserted.
1149 -- This will still be the first node after the insert operation,
1150 -- since Insert_List_After does not modify the Node_Id values.
1151
1152 Node := First (L);
1153 Insert_List_After (N, L);
1154
1155 -- Now just analyze from the original first node until we get to the
1156 -- successor of the original insertion point (which may be Empty if
1157 -- the insertion point was at the end of the list). Note that this
1158 -- properly handles the case where any of the analyze calls result in
1159 -- the insertion of nodes after the analyzed node (possibly calling
1160 -- this routine recursively).
1161
1162 while Node /= After loop
1163 Analyze (Node);
1164 Mark_Rewrite_Insertion (Node);
1165 Next (Node);
1166 end loop;
1167 end if;
1168 end Insert_List_After_And_Analyze;
1169
1170 -- Version with check(s) suppressed
1171
1172 procedure Insert_List_After_And_Analyze
1173 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1174 is
1175 begin
1176 if Suppress = All_Checks then
1177 declare
1178 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1179 begin
1180 Scope_Suppress.Suppress := (others => True);
1181 Insert_List_After_And_Analyze (N, L);
1182 Scope_Suppress.Suppress := Svs;
1183 end;
1184
1185 else
1186 declare
1187 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1188 begin
1189 Scope_Suppress.Suppress (Suppress) := True;
1190 Insert_List_After_And_Analyze (N, L);
1191 Scope_Suppress.Suppress (Suppress) := Svg;
1192 end;
1193 end if;
1194 end Insert_List_After_And_Analyze;
1195
1196 ------------------------------------
1197 -- Insert_List_Before_And_Analyze --
1198 ------------------------------------
1199
1200 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
1201 Node : Node_Id;
1202
1203 begin
1204 if Is_Non_Empty_List (L) then
1205
1206 -- Capture the Node_Id of the first list node to be inserted. This
1207 -- will still be the first node after the insert operation, since
1208 -- Insert_List_After does not modify the Node_Id values.
1209
1210 Node := First (L);
1211 Insert_List_Before (N, L);
1212
1213 -- The insertion does not change the Id's of any of the nodes in
1214 -- the list, and they are still linked, so we can simply loop from
1215 -- the original first node until we meet the node before which the
1216 -- insertion is occurring. Note that this properly handles the case
1217 -- where any of the analyzed nodes insert nodes after themselves,
1218 -- expecting them to get analyzed.
1219
1220 while Node /= N loop
1221 Analyze (Node);
1222 Mark_Rewrite_Insertion (Node);
1223 Next (Node);
1224 end loop;
1225 end if;
1226 end Insert_List_Before_And_Analyze;
1227
1228 -- Version with check(s) suppressed
1229
1230 procedure Insert_List_Before_And_Analyze
1231 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1232 is
1233 begin
1234 if Suppress = All_Checks then
1235 declare
1236 Svs : constant Suppress_Array := Scope_Suppress.Suppress;
1237 begin
1238 Scope_Suppress.Suppress := (others => True);
1239 Insert_List_Before_And_Analyze (N, L);
1240 Scope_Suppress.Suppress := Svs;
1241 end;
1242
1243 else
1244 declare
1245 Svg : constant Boolean := Scope_Suppress.Suppress (Suppress);
1246 begin
1247 Scope_Suppress.Suppress (Suppress) := True;
1248 Insert_List_Before_And_Analyze (N, L);
1249 Scope_Suppress.Suppress (Suppress) := Svg;
1250 end;
1251 end if;
1252 end Insert_List_Before_And_Analyze;
1253
1254 ----------
1255 -- Lock --
1256 ----------
1257
1258 procedure Lock is
1259 begin
1260 Scope_Stack.Locked := True;
1261 Scope_Stack.Release;
1262 end Lock;
1263
1264 ----------------
1265 -- Preanalyze --
1266 ----------------
1267
1268 procedure Preanalyze (N : Node_Id) is
1269 Save_Full_Analysis : constant Boolean := Full_Analysis;
1270
1271 begin
1272 Full_Analysis := False;
1273 Expander_Mode_Save_And_Set (False);
1274
1275 Analyze (N);
1276
1277 Expander_Mode_Restore;
1278 Full_Analysis := Save_Full_Analysis;
1279 end Preanalyze;
1280
1281 --------------------------------------
1282 -- Push_Global_Suppress_Stack_Entry --
1283 --------------------------------------
1284
1285 procedure Push_Global_Suppress_Stack_Entry
1286 (Entity : Entity_Id;
1287 Check : Check_Id;
1288 Suppress : Boolean)
1289 is
1290 begin
1291 Global_Suppress_Stack_Top :=
1292 new Suppress_Stack_Entry'
1293 (Entity => Entity,
1294 Check => Check,
1295 Suppress => Suppress,
1296 Prev => Global_Suppress_Stack_Top,
1297 Next => Suppress_Stack_Entries);
1298 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1299 return;
1300 end Push_Global_Suppress_Stack_Entry;
1301
1302 -------------------------------------
1303 -- Push_Local_Suppress_Stack_Entry --
1304 -------------------------------------
1305
1306 procedure Push_Local_Suppress_Stack_Entry
1307 (Entity : Entity_Id;
1308 Check : Check_Id;
1309 Suppress : Boolean)
1310 is
1311 begin
1312 Local_Suppress_Stack_Top :=
1313 new Suppress_Stack_Entry'
1314 (Entity => Entity,
1315 Check => Check,
1316 Suppress => Suppress,
1317 Prev => Local_Suppress_Stack_Top,
1318 Next => Suppress_Stack_Entries);
1319 Suppress_Stack_Entries := Local_Suppress_Stack_Top;
1320
1321 return;
1322 end Push_Local_Suppress_Stack_Entry;
1323
1324 ---------------
1325 -- Semantics --
1326 ---------------
1327
1328 procedure Semantics (Comp_Unit : Node_Id) is
1329 procedure Do_Analyze;
1330 -- Perform the analysis of the compilation unit
1331
1332 ----------------
1333 -- Do_Analyze --
1334 ----------------
1335
1336 procedure Do_Analyze is
1337 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
1338
1339 -- Generally style checks are preserved across compilations, with
1340 -- one exception: s-oscons.ads, which allows arbitrary long lines
1341 -- unconditionally, and has no restore mechanism, because it is
1342 -- intended as a lowest-level Pure package.
1343
1344 Save_Max_Line : constant Int := Style_Max_Line_Length;
1345
1346 List : Elist_Id;
1347
1348 begin
1349 List := Save_Scope_Stack;
1350 Push_Scope (Standard_Standard);
1351
1352 -- Set up a clean environment before analyzing
1353
1354 Ghost_Mode := None;
1355 Outer_Generic_Scope := Empty;
1356 Scope_Suppress := Suppress_Options;
1357 Scope_Stack.Table
1358 (Scope_Stack.Last).Component_Alignment_Default :=
1359 Configuration_Component_Alignment;
1360 Scope_Stack.Table
1361 (Scope_Stack.Last).Is_Active_Stack_Base := True;
1362
1363 -- Now analyze the top level compilation unit node
1364
1365 Analyze (Comp_Unit);
1366
1367 -- Check for scope mismatch on exit from compilation
1368
1369 pragma Assert (Current_Scope = Standard_Standard
1370 or else Comp_Unit = Cunit (Main_Unit));
1371
1372 -- Then pop entry for Standard, and pop implicit types
1373
1374 Pop_Scope;
1375 Restore_Scope_Stack (List);
1376 Ghost_Mode := Save_Ghost_Mode;
1377 Style_Max_Line_Length := Save_Max_Line;
1378 end Do_Analyze;
1379
1380 -- Local variables
1381
1382 -- The following locations save the corresponding global flags and
1383 -- variables so that they can be restored on completion. This is needed
1384 -- so that calls to Rtsfind start with the proper default values for
1385 -- these variables, and also that such calls do not disturb the settings
1386 -- for units being analyzed at a higher level.
1387
1388 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
1389 S_Full_Analysis : constant Boolean := Full_Analysis;
1390 S_GNAT_Mode : constant Boolean := GNAT_Mode;
1391 S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
1392 S_In_Assertion_Expr : constant Nat := In_Assertion_Expr;
1393 S_In_Default_Expr : constant Boolean := In_Default_Expr;
1394 S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
1395 S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
1396 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
1397 S_Style_Check : constant Boolean := Style_Check;
1398
1399 Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
1400
1401 Curunit : constant Unit_Number_Type := Get_Cunit_Unit_Number (Comp_Unit);
1402 -- New value of Current_Sem_Unit
1403
1404 Generic_Main : constant Boolean :=
1405 Nkind (Unit (Cunit (Main_Unit))) in N_Generic_Declaration;
1406 -- If the main unit is generic, every compiled unit, including its
1407 -- context, is compiled with expansion disabled.
1408
1409 Is_Main_Unit_Or_Main_Unit_Spec : constant Boolean :=
1410 Curunit = Main_Unit
1411 or else
1412 (Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
1413 and then Library_Unit (Cunit (Main_Unit)) = Cunit (Curunit));
1414 -- Configuration flags have special settings when compiling a predefined
1415 -- file as a main unit. This applies to its spec as well.
1416
1417 Ext_Main_Source_Unit : constant Boolean :=
1418 In_Extended_Main_Source_Unit (Comp_Unit);
1419 -- Determine if unit is in extended main source unit
1420
1421 Save_Config_Switches : Config_Switches_Type;
1422 -- Variable used to save values of config switches while we analyze the
1423 -- new unit, to be restored on exit for proper recursive behavior.
1424
1425 Save_Cunit_Restrictions : Save_Cunit_Boolean_Restrictions;
1426 -- Used to save non-partition wide restrictions before processing new
1427 -- unit. All with'ed units are analyzed with config restrictions reset
1428 -- and we need to restore these saved values at the end.
1429
1430 -- Start of processing for Semantics
1431
1432 begin
1433 if Debug_Unit_Walk then
1434 if Already_Analyzed then
1435 Write_Str ("(done)");
1436 end if;
1437
1438 Write_Unit_Info
1439 (Get_Cunit_Unit_Number (Comp_Unit),
1440 Unit (Comp_Unit),
1441 Prefix => "--> ");
1442 Indent;
1443 end if;
1444
1445 Compiler_State := Analyzing;
1446 Current_Sem_Unit := Curunit;
1447
1448 -- Compile predefined units with GNAT_Mode set to True, to properly
1449 -- process the categorization stuff. However, do not set GNAT_Mode
1450 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1451 -- Sequential_IO) as this would prevent pragma Extend_System from being
1452 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1453
1454 if Is_Predefined_File_Name
1455 (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
1456 then
1457 GNAT_Mode := True;
1458 end if;
1459
1460 -- For generic main, never do expansion
1461
1462 if Generic_Main then
1463 Expander_Mode_Save_And_Set (False);
1464
1465 -- Non generic case
1466
1467 else
1468 Expander_Mode_Save_And_Set
1469
1470 -- Turn on expansion if generating code
1471
1472 (Operating_Mode = Generate_Code
1473
1474 -- Or if special debug flag -gnatdx is set
1475
1476 or else Debug_Flag_X
1477
1478 -- Or if in configuration run-time mode. We do this so we get
1479 -- error messages about missing entities in the run-time even
1480 -- if we are compiling in -gnatc (no code generation) mode.
1481 -- Similar processing applies to No_Run_Time_Mode. However,
1482 -- don't do this if debug flag -gnatd.Z is set or when we are
1483 -- compiling a separate unit (this is to handle a situation
1484 -- where this new processing causes trouble).
1485
1486 or else ((Configurable_Run_Time_Mode or No_Run_Time_Mode)
1487 and not Debug_Flag_Dot_ZZ
1488 and Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit));
1489 end if;
1490
1491 Full_Analysis := True;
1492 Inside_A_Generic := False;
1493 In_Assertion_Expr := 0;
1494 In_Default_Expr := False;
1495 In_Spec_Expression := False;
1496 Set_Comes_From_Source_Default (False);
1497
1498 -- Save current config switches and reset then appropriately
1499
1500 Save_Opt_Config_Switches (Save_Config_Switches);
1501 Set_Opt_Config_Switches
1502 (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
1503 Is_Main_Unit_Or_Main_Unit_Spec);
1504
1505 -- Save current non-partition-wide restrictions
1506
1507 Save_Cunit_Restrictions := Cunit_Boolean_Restrictions_Save;
1508
1509 -- For unit in main extended unit, we reset the configuration values
1510 -- for the non-partition-wide restrictions. For other units reset them.
1511
1512 if Ext_Main_Source_Unit then
1513 Restore_Config_Cunit_Boolean_Restrictions;
1514 else
1515 Reset_Cunit_Boolean_Restrictions;
1516 end if;
1517
1518 -- Turn off style checks for unit that is not in the extended main
1519 -- source unit. This improves processing efficiency for such units
1520 -- (for which we don't want style checks anyway, and where they will
1521 -- get suppressed), and is definitely needed to stop some style checks
1522 -- from invading the run-time units (e.g. overriding checks).
1523
1524 if not Ext_Main_Source_Unit then
1525 Style_Check := False;
1526
1527 -- If this is part of the extended main source unit, set style check
1528 -- mode to match the style check mode of the main source unit itself.
1529
1530 else
1531 Style_Check := Style_Check_Main;
1532 end if;
1533
1534 -- Only do analysis of unit that has not already been analyzed
1535
1536 if not Analyzed (Comp_Unit) then
1537 Initialize_Version (Current_Sem_Unit);
1538
1539 -- Do analysis, and then append the compilation unit onto the
1540 -- Comp_Unit_List, if appropriate. This is done after analysis,
1541 -- so if this unit depends on some others, they have already been
1542 -- appended. We ignore bodies, except for the main unit itself, and
1543 -- for subprogram bodies that act as specs. We have also to guard
1544 -- against ill-formed subunits that have an improper context.
1545
1546 Do_Analyze;
1547
1548 if Present (Comp_Unit)
1549 and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
1550 and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body
1551 or else not Acts_As_Spec (Comp_Unit))
1552 and then not In_Extended_Main_Source_Unit (Comp_Unit)
1553 then
1554 null;
1555
1556 else
1557 Append_New_Elmt (Comp_Unit, To => Comp_Unit_List);
1558
1559 if Debug_Unit_Walk then
1560 Write_Str ("Appending ");
1561 Write_Unit_Info
1562 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
1563 end if;
1564 end if;
1565 end if;
1566
1567 -- Save indication of dynamic elaboration checks for ALI file
1568
1569 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
1570
1571 -- Restore settings of saved switches to entry values
1572
1573 Current_Sem_Unit := S_Current_Sem_Unit;
1574 Full_Analysis := S_Full_Analysis;
1575 Global_Discard_Names := S_Global_Dis_Names;
1576 GNAT_Mode := S_GNAT_Mode;
1577 In_Assertion_Expr := S_In_Assertion_Expr;
1578 In_Default_Expr := S_In_Default_Expr;
1579 In_Spec_Expression := S_In_Spec_Expr;
1580 Inside_A_Generic := S_Inside_A_Generic;
1581 Outer_Generic_Scope := S_Outer_Gen_Scope;
1582 Style_Check := S_Style_Check;
1583
1584 Restore_Opt_Config_Switches (Save_Config_Switches);
1585
1586 -- Deal with restore of restrictions
1587
1588 Cunit_Boolean_Restrictions_Restore (Save_Cunit_Restrictions);
1589
1590 Expander_Mode_Restore;
1591
1592 if Debug_Unit_Walk then
1593 Outdent;
1594
1595 if Already_Analyzed then
1596 Write_Str ("(done)");
1597 end if;
1598
1599 Write_Unit_Info
1600 (Get_Cunit_Unit_Number (Comp_Unit),
1601 Unit (Comp_Unit),
1602 Prefix => "<-- ");
1603 end if;
1604 end Semantics;
1605
1606 --------
1607 -- ss --
1608 --------
1609
1610 function ss (Index : Int) return Scope_Stack_Entry is
1611 begin
1612 return Scope_Stack.Table (Index);
1613 end ss;
1614
1615 ---------
1616 -- sst --
1617 ---------
1618
1619 function sst return Scope_Stack_Entry is
1620 begin
1621 return ss (Scope_Stack.Last);
1622 end sst;
1623
1624 ------------------------
1625 -- Walk_Library_Items --
1626 ------------------------
1627
1628 procedure Walk_Library_Items is
1629 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
1630 pragma Pack (Unit_Number_Set);
1631
1632 Main_CU : constant Node_Id := Cunit (Main_Unit);
1633
1634 Seen, Done : Unit_Number_Set := (others => False);
1635 -- Seen (X) is True after we have seen unit X in the walk. This is used
1636 -- to prevent processing the same unit more than once. Done (X) is True
1637 -- after we have fully processed X, and is used only for debugging
1638 -- printouts and assertions.
1639
1640 Do_Main : Boolean := False;
1641 -- Flag to delay processing the main body until after all other units.
1642 -- This is needed because the spec of the main unit may appear in the
1643 -- context of some other unit. We do not want this to force processing
1644 -- of the main body before all other units have been processed.
1645 --
1646 -- Another circularity pattern occurs when the main unit is a child unit
1647 -- and the body of an ancestor has a with-clause of the main unit or on
1648 -- one of its children. In both cases the body in question has a with-
1649 -- clause on the main unit, and must be excluded from the traversal. In
1650 -- some convoluted cases this may lead to a CodePeer error because the
1651 -- spec of a subprogram declared in an instance within the parent will
1652 -- not be seen in the main unit.
1653
1654 function Depends_On_Main (CU : Node_Id) return Boolean;
1655 -- The body of a unit that is withed by the spec of the main unit may in
1656 -- turn have a with_clause on that spec. In that case do not traverse
1657 -- the body, to prevent loops. It can also happen that the main body has
1658 -- a with_clause on a child, which of course has an implicit with on its
1659 -- parent. It's OK to traverse the child body if the main spec has been
1660 -- processed, otherwise we also have a circularity to avoid.
1661
1662 procedure Do_Action (CU : Node_Id; Item : Node_Id);
1663 -- Calls Action, with some validity checks
1664
1665 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id);
1666 -- Calls Do_Action, first on the units with'ed by this one, then on
1667 -- this unit. If it's an instance body, do the spec first. If it is
1668 -- an instance spec, do the body last.
1669
1670 procedure Do_Withed_Unit (Withed_Unit : Node_Id);
1671 -- Apply Do_Unit_And_Dependents to a unit in a context clause
1672
1673 procedure Process_Bodies_In_Context (Comp : Node_Id);
1674 -- The main unit and its spec may depend on bodies that contain generics
1675 -- that are instantiated in them. Iterate through the corresponding
1676 -- contexts before processing main (spec/body) itself, to process bodies
1677 -- that may be present, together with their context. The spec of main
1678 -- is processed wherever it appears in the list of units, while the body
1679 -- is processed as the last unit in the list.
1680
1681 ---------------------
1682 -- Depends_On_Main --
1683 ---------------------
1684
1685 function Depends_On_Main (CU : Node_Id) return Boolean is
1686 CL : Node_Id;
1687 MCU : constant Node_Id := Unit (Main_CU);
1688
1689 begin
1690 CL := First (Context_Items (CU));
1691
1692 -- Problem does not arise with main subprograms
1693
1694 if
1695 not Nkind_In (MCU, N_Package_Body, N_Package_Declaration)
1696 then
1697 return False;
1698 end if;
1699
1700 while Present (CL) loop
1701 if Nkind (CL) = N_With_Clause
1702 and then Library_Unit (CL) = Main_CU
1703 and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL)))
1704 then
1705 return True;
1706 end if;
1707
1708 Next (CL);
1709 end loop;
1710
1711 return False;
1712 end Depends_On_Main;
1713
1714 ---------------
1715 -- Do_Action --
1716 ---------------
1717
1718 procedure Do_Action (CU : Node_Id; Item : Node_Id) is
1719 begin
1720 -- This calls Action at the end. All the preceding code is just
1721 -- assertions and debugging output.
1722
1723 pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
1724
1725 case Nkind (Item) is
1726 when N_Generic_Subprogram_Declaration |
1727 N_Generic_Package_Declaration |
1728 N_Package_Declaration |
1729 N_Subprogram_Declaration |
1730 N_Subprogram_Renaming_Declaration |
1731 N_Package_Renaming_Declaration |
1732 N_Generic_Function_Renaming_Declaration |
1733 N_Generic_Package_Renaming_Declaration |
1734 N_Generic_Procedure_Renaming_Declaration =>
1735
1736 -- Specs are OK
1737
1738 null;
1739
1740 when N_Package_Body =>
1741
1742 -- Package bodies are processed separately if the main unit
1743 -- depends on them.
1744
1745 null;
1746
1747 when N_Subprogram_Body =>
1748
1749 -- A subprogram body must be the main unit
1750
1751 pragma Assert (Acts_As_Spec (CU)
1752 or else CU = Cunit (Main_Unit));
1753 null;
1754
1755 when N_Function_Instantiation |
1756 N_Procedure_Instantiation |
1757 N_Package_Instantiation =>
1758
1759 -- Can only happen if some generic body (needed for gnat2scil
1760 -- traversal, but not by GNAT) is not available, ignore.
1761
1762 null;
1763
1764 -- All other cases cannot happen
1765
1766 when N_Subunit =>
1767 pragma Assert (False, "subunit");
1768 null;
1769
1770 when others =>
1771 pragma Assert (False);
1772 null;
1773 end case;
1774
1775 if Present (CU) then
1776 pragma Assert (Item /= Stand.Standard_Package_Node);
1777 pragma Assert (Item = Unit (CU));
1778
1779 declare
1780 Unit_Num : constant Unit_Number_Type :=
1781 Get_Cunit_Unit_Number (CU);
1782
1783 procedure Assert_Done (Withed_Unit : Node_Id);
1784 -- Assert Withed_Unit is already Done, unless it's a body. It
1785 -- might seem strange for a with_clause to refer to a body, but
1786 -- this happens in the case of a generic instantiation, which
1787 -- gets transformed into the instance body (and the instance
1788 -- spec is also created). With clauses pointing to the
1789 -- instantiation end up pointing to the instance body.
1790
1791 -----------------
1792 -- Assert_Done --
1793 -----------------
1794
1795 procedure Assert_Done (Withed_Unit : Node_Id) is
1796 begin
1797 if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
1798 if not Nkind_In
1799 (Unit (Withed_Unit),
1800 N_Generic_Package_Declaration,
1801 N_Package_Body,
1802 N_Package_Renaming_Declaration,
1803 N_Subprogram_Body)
1804 then
1805 Write_Unit_Name
1806 (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit)));
1807 Write_Str (" not yet walked!");
1808
1809 if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
1810 Write_Str (" (self-ref)");
1811 end if;
1812
1813 Write_Eol;
1814
1815 pragma Assert (False);
1816 end if;
1817 end if;
1818 end Assert_Done;
1819
1820 procedure Assert_Withed_Units_Done is
1821 new Walk_Withs (Assert_Done);
1822
1823 begin
1824 if Debug_Unit_Walk then
1825 Write_Unit_Info (Unit_Num, Item, Withs => True);
1826 end if;
1827
1828 -- Main unit should come last, except in the case where we
1829 -- skipped System_Aux_Id, in which case we missed the things it
1830 -- depends on, and in the case of parent bodies if present.
1831
1832 pragma Assert
1833 (not Done (Main_Unit)
1834 or else Present (System_Aux_Id)
1835 or else Nkind (Item) = N_Package_Body);
1836
1837 -- We shouldn't do the same thing twice
1838
1839 pragma Assert (not Done (Unit_Num));
1840
1841 -- Everything we depend upon should already be done
1842
1843 pragma Debug
1844 (Assert_Withed_Units_Done (CU, Include_Limited => False));
1845 end;
1846
1847 else
1848 -- Must be Standard, which has no entry in the units table
1849
1850 pragma Assert (Item = Stand.Standard_Package_Node);
1851
1852 if Debug_Unit_Walk then
1853 Write_Line ("Standard");
1854 end if;
1855 end if;
1856
1857 Action (Item);
1858 end Do_Action;
1859
1860 --------------------
1861 -- Do_Withed_Unit --
1862 --------------------
1863
1864 procedure Do_Withed_Unit (Withed_Unit : Node_Id) is
1865 begin
1866 Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit));
1867
1868 -- If the unit in the with_clause is a generic instance, the clause
1869 -- now denotes the instance body. Traverse the corresponding spec
1870 -- because there may be no other dependence that will force the
1871 -- traversal of its own context.
1872
1873 if Nkind (Unit (Withed_Unit)) = N_Package_Body
1874 and then Is_Generic_Instance
1875 (Defining_Entity (Unit (Library_Unit (Withed_Unit))))
1876 then
1877 Do_Withed_Unit (Library_Unit (Withed_Unit));
1878 end if;
1879 end Do_Withed_Unit;
1880
1881 ----------------------------
1882 -- Do_Unit_And_Dependents --
1883 ----------------------------
1884
1885 procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
1886 Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU);
1887 Child : Node_Id;
1888 Body_U : Unit_Number_Type;
1889 Parent_CU : Node_Id;
1890
1891 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
1892
1893 begin
1894 if not Seen (Unit_Num) then
1895
1896 -- Process the with clauses
1897
1898 Do_Withed_Units (CU, Include_Limited => False);
1899
1900 -- Process the unit if it is a spec or the main unit, if it
1901 -- has no previous spec or we have done all other units.
1902
1903 if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
1904 or else Acts_As_Spec (CU)
1905 then
1906 if CU = Cunit (Main_Unit)
1907 and then not Do_Main
1908 then
1909 Seen (Unit_Num) := False;
1910
1911 else
1912 Seen (Unit_Num) := True;
1913
1914 if CU = Library_Unit (Main_CU) then
1915 Process_Bodies_In_Context (CU);
1916
1917 -- If main is a child unit, examine parent unit contexts
1918 -- to see if they include instantiated units. Also, if
1919 -- the parent itself is an instance, process its body
1920 -- because it may contain subprograms that are called
1921 -- in the main unit.
1922
1923 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
1924 Child := Cunit_Entity (Main_Unit);
1925 while Is_Child_Unit (Child) loop
1926 Parent_CU :=
1927 Cunit
1928 (Get_Cunit_Entity_Unit_Number (Scope (Child)));
1929 Process_Bodies_In_Context (Parent_CU);
1930
1931 if Nkind (Unit (Parent_CU)) = N_Package_Body
1932 and then
1933 Nkind (Original_Node (Unit (Parent_CU)))
1934 = N_Package_Instantiation
1935 and then
1936 not Seen (Get_Cunit_Unit_Number (Parent_CU))
1937 then
1938 Body_U := Get_Cunit_Unit_Number (Parent_CU);
1939 Seen (Body_U) := True;
1940 Do_Action (Parent_CU, Unit (Parent_CU));
1941 Done (Body_U) := True;
1942 end if;
1943
1944 Child := Scope (Child);
1945 end loop;
1946 end if;
1947 end if;
1948
1949 Do_Action (CU, Item);
1950 Done (Unit_Num) := True;
1951 end if;
1952 end if;
1953 end if;
1954 end Do_Unit_And_Dependents;
1955
1956 -------------------------------
1957 -- Process_Bodies_In_Context --
1958 -------------------------------
1959
1960 procedure Process_Bodies_In_Context (Comp : Node_Id) is
1961 Body_CU : Node_Id;
1962 Body_U : Unit_Number_Type;
1963 Clause : Node_Id;
1964 Spec : Node_Id;
1965
1966 procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
1967
1968 -- Start of processing for Process_Bodies_In_Context
1969
1970 begin
1971 Clause := First (Context_Items (Comp));
1972 while Present (Clause) loop
1973 if Nkind (Clause) = N_With_Clause then
1974 Spec := Library_Unit (Clause);
1975 Body_CU := Library_Unit (Spec);
1976
1977 -- If we are processing the spec of the main unit, load bodies
1978 -- only if the with_clause indicates that it forced the loading
1979 -- of the body for a generic instantiation. Note that bodies of
1980 -- parents that are instances have been loaded already.
1981
1982 if Present (Body_CU)
1983 and then Body_CU /= Cunit (Main_Unit)
1984 and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body
1985 and then (Nkind (Unit (Comp)) /= N_Package_Declaration
1986 or else Present (Withed_Body (Clause)))
1987 then
1988 Body_U := Get_Cunit_Unit_Number (Body_CU);
1989
1990 if not Seen (Body_U)
1991 and then not Depends_On_Main (Body_CU)
1992 then
1993 Seen (Body_U) := True;
1994 Do_Withed_Units (Body_CU, Include_Limited => False);
1995 Do_Action (Body_CU, Unit (Body_CU));
1996 Done (Body_U) := True;
1997 end if;
1998 end if;
1999 end if;
2000
2001 Next (Clause);
2002 end loop;
2003 end Process_Bodies_In_Context;
2004
2005 -- Local Declarations
2006
2007 Cur : Elmt_Id;
2008
2009 -- Start of processing for Walk_Library_Items
2010
2011 begin
2012 if Debug_Unit_Walk then
2013 Write_Line ("Walk_Library_Items:");
2014 Indent;
2015 end if;
2016
2017 -- Do Standard first, then walk the Comp_Unit_List
2018
2019 Do_Action (Empty, Standard_Package_Node);
2020
2021 -- First place the context of all instance bodies on the corresponding
2022 -- spec, because it may be needed to analyze the code at the place of
2023 -- the instantiation.
2024
2025 Cur := First_Elmt (Comp_Unit_List);
2026 while Present (Cur) loop
2027 declare
2028 CU : constant Node_Id := Node (Cur);
2029 N : constant Node_Id := Unit (CU);
2030
2031 begin
2032 if Nkind (N) = N_Package_Body
2033 and then Is_Generic_Instance (Defining_Entity (N))
2034 then
2035 Append_List
2036 (Context_Items (CU), Context_Items (Library_Unit (CU)));
2037 end if;
2038
2039 Next_Elmt (Cur);
2040 end;
2041 end loop;
2042
2043 -- Now traverse compilation units (specs) in order
2044
2045 Cur := First_Elmt (Comp_Unit_List);
2046 while Present (Cur) loop
2047 declare
2048 CU : constant Node_Id := Node (Cur);
2049 N : constant Node_Id := Unit (CU);
2050 Par : Entity_Id;
2051
2052 begin
2053 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2054
2055 case Nkind (N) is
2056
2057 -- If it is a subprogram body, process it if it has no
2058 -- separate spec.
2059
2060 -- If it's a package body, ignore it, unless it is a body
2061 -- created for an instance that is the main unit. In the case
2062 -- of subprograms, the body is the wrapper package. In case of
2063 -- a package, the original file carries the body, and the spec
2064 -- appears as a later entry in the units list.
2065
2066 -- Otherwise bodies appear in the list only because of inlining
2067 -- or instantiations, and they are processed only if relevant.
2068 -- The flag Withed_Body on a context clause indicates that a
2069 -- unit contains an instantiation that may be needed later,
2070 -- and therefore the body that contains the generic body (and
2071 -- its context) must be traversed immediately after the
2072 -- corresponding spec (see Do_Unit_And_Dependents).
2073
2074 -- The main unit itself is processed separately after all other
2075 -- specs, and relevant bodies are examined in Process_Main.
2076
2077 when N_Subprogram_Body =>
2078 if Acts_As_Spec (N) then
2079 Do_Unit_And_Dependents (CU, N);
2080 end if;
2081
2082 when N_Package_Body =>
2083 if CU = Main_CU
2084 and then Nkind (Original_Node (Unit (Main_CU))) in
2085 N_Generic_Instantiation
2086 and then Present (Library_Unit (Main_CU))
2087 then
2088 Do_Unit_And_Dependents
2089 (Library_Unit (Main_CU),
2090 Unit (Library_Unit (Main_CU)));
2091 end if;
2092
2093 -- It's a spec, process it, and the units it depends on,
2094 -- unless it is a descendant of the main unit. This can
2095 -- happen when the body of a parent depends on some other
2096 -- descendant.
2097
2098 when others =>
2099 Par := Scope (Defining_Entity (Unit (CU)));
2100
2101 if Is_Child_Unit (Defining_Entity (Unit (CU))) then
2102 while Present (Par)
2103 and then Par /= Standard_Standard
2104 and then Par /= Cunit_Entity (Main_Unit)
2105 loop
2106 Par := Scope (Par);
2107 end loop;
2108 end if;
2109
2110 if Par /= Cunit_Entity (Main_Unit) then
2111 Do_Unit_And_Dependents (CU, N);
2112 end if;
2113 end case;
2114 end;
2115
2116 Next_Elmt (Cur);
2117 end loop;
2118
2119 -- Now process package bodies on which main depends, followed by bodies
2120 -- of parents, if present, and finally main itself.
2121
2122 if not Done (Main_Unit) then
2123 Do_Main := True;
2124
2125 Process_Main : declare
2126 Parent_CU : Node_Id;
2127 Body_CU : Node_Id;
2128 Body_U : Unit_Number_Type;
2129 Child : Entity_Id;
2130
2131 function Is_Subunit_Of_Main (U : Node_Id) return Boolean;
2132 -- If the main unit has subunits, their context may include
2133 -- bodies that are needed in the body of main. We must examine
2134 -- the context of the subunits, which are otherwise not made
2135 -- explicit in the main unit.
2136
2137 ------------------------
2138 -- Is_Subunit_Of_Main --
2139 ------------------------
2140
2141 function Is_Subunit_Of_Main (U : Node_Id) return Boolean is
2142 Lib : Node_Id;
2143 begin
2144 if No (U) then
2145 return False;
2146 else
2147 Lib := Library_Unit (U);
2148 return Nkind (Unit (U)) = N_Subunit
2149 and then
2150 (Lib = Cunit (Main_Unit)
2151 or else Is_Subunit_Of_Main (Lib));
2152 end if;
2153 end Is_Subunit_Of_Main;
2154
2155 -- Start of processing for Process_Main
2156
2157 begin
2158 Process_Bodies_In_Context (Main_CU);
2159
2160 for Unit_Num in Done'Range loop
2161 if Is_Subunit_Of_Main (Cunit (Unit_Num)) then
2162 Process_Bodies_In_Context (Cunit (Unit_Num));
2163 end if;
2164 end loop;
2165
2166 -- If the main unit is a child unit, parent bodies may be present
2167 -- because they export instances or inlined subprograms. Check for
2168 -- presence of these, which are not present in context clauses.
2169 -- Note that if the parents are instances, their bodies have been
2170 -- processed before the main spec, because they may be needed
2171 -- therein, so the following loop only affects non-instances.
2172
2173 if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
2174 Child := Cunit_Entity (Main_Unit);
2175 while Is_Child_Unit (Child) loop
2176 Parent_CU :=
2177 Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child)));
2178 Body_CU := Library_Unit (Parent_CU);
2179
2180 if Present (Body_CU)
2181 and then not Seen (Get_Cunit_Unit_Number (Body_CU))
2182 and then not Depends_On_Main (Body_CU)
2183 then
2184 Body_U := Get_Cunit_Unit_Number (Body_CU);
2185 Seen (Body_U) := True;
2186 Do_Action (Body_CU, Unit (Body_CU));
2187 Done (Body_U) := True;
2188 end if;
2189
2190 Child := Scope (Child);
2191 end loop;
2192 end if;
2193
2194 Do_Action (Main_CU, Unit (Main_CU));
2195 Done (Main_Unit) := True;
2196 end Process_Main;
2197 end if;
2198
2199 if Debug_Unit_Walk then
2200 if Done /= (Done'Range => True) then
2201 Write_Eol;
2202 Write_Line ("Ignored units:");
2203
2204 Indent;
2205
2206 for Unit_Num in Done'Range loop
2207 if not Done (Unit_Num) then
2208 Write_Unit_Info
2209 (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True);
2210 end if;
2211 end loop;
2212
2213 Outdent;
2214 end if;
2215 end if;
2216
2217 pragma Assert (Done (Main_Unit));
2218
2219 if Debug_Unit_Walk then
2220 Outdent;
2221 Write_Line ("end Walk_Library_Items.");
2222 end if;
2223 end Walk_Library_Items;
2224
2225 ----------------
2226 -- Walk_Withs --
2227 ----------------
2228
2229 procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is
2230 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2231 pragma Assert (Nkind (Unit (CU)) /= N_Subunit);
2232
2233 procedure Walk_Immediate is new Walk_Withs_Immediate (Action);
2234
2235 begin
2236 -- First walk the withs immediately on the library item
2237
2238 Walk_Immediate (CU, Include_Limited);
2239
2240 -- For a body, we must also check for any subunits which belong to it
2241 -- and which have context clauses of their own, since these with'ed
2242 -- units are part of its own dependencies.
2243
2244 if Nkind (Unit (CU)) in N_Unit_Body then
2245 for S in Main_Unit .. Last_Unit loop
2246
2247 -- We are only interested in subunits. For preproc. data and def.
2248 -- files, Cunit is Empty, so we need to test that first.
2249
2250 if Cunit (S) /= Empty
2251 and then Nkind (Unit (Cunit (S))) = N_Subunit
2252 then
2253 declare
2254 Pnode : Node_Id;
2255
2256 begin
2257 Pnode := Library_Unit (Cunit (S));
2258
2259 -- In -gnatc mode, the errors in the subunits will not have
2260 -- been recorded, but the analysis of the subunit may have
2261 -- failed, so just quit.
2262
2263 if No (Pnode) then
2264 exit;
2265 end if;
2266
2267 -- Find ultimate parent of the subunit
2268
2269 while Nkind (Unit (Pnode)) = N_Subunit loop
2270 Pnode := Library_Unit (Pnode);
2271 end loop;
2272
2273 -- See if it belongs to current unit, and if so, include its
2274 -- with_clauses. Do not process main unit prematurely.
2275
2276 if Pnode = CU and then CU /= Cunit (Main_Unit) then
2277 Walk_Immediate (Cunit (S), Include_Limited);
2278 end if;
2279 end;
2280 end if;
2281 end loop;
2282 end if;
2283 end Walk_Withs;
2284
2285 --------------------------
2286 -- Walk_Withs_Immediate --
2287 --------------------------
2288
2289 procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is
2290 pragma Assert (Nkind (CU) = N_Compilation_Unit);
2291
2292 Context_Item : Node_Id;
2293 Lib_Unit : Node_Id;
2294 Body_CU : Node_Id;
2295
2296 begin
2297 Context_Item := First (Context_Items (CU));
2298 while Present (Context_Item) loop
2299 if Nkind (Context_Item) = N_With_Clause
2300 and then (Include_Limited
2301 or else not Limited_Present (Context_Item))
2302 then
2303 Lib_Unit := Library_Unit (Context_Item);
2304 Action (Lib_Unit);
2305
2306 -- If the context item indicates that a package body is needed
2307 -- because of an instantiation in CU, traverse the body now, even
2308 -- if CU is not related to the main unit. If the generic itself
2309 -- appears in a package body, the context item is this body, and
2310 -- it already appears in the traversal order, so we only need to
2311 -- examine the case of a context item being a package declaration.
2312
2313 if Present (Withed_Body (Context_Item))
2314 and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration
2315 and then Present (Corresponding_Body (Unit (Lib_Unit)))
2316 then
2317 Body_CU :=
2318 Parent
2319 (Unit_Declaration_Node
2320 (Corresponding_Body (Unit (Lib_Unit))));
2321
2322 -- A body may have an implicit with on its own spec, in which
2323 -- case we must ignore this context item to prevent looping.
2324
2325 if Unit (CU) /= Unit (Body_CU) then
2326 Action (Body_CU);
2327 end if;
2328 end if;
2329 end if;
2330
2331 Context_Item := Next (Context_Item);
2332 end loop;
2333 end Walk_Withs_Immediate;
2334
2335 end Sem;