Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/sem.adb @ 111:04ced10e8804

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