[multiple changes]
[gcc.git] / gcc / ada / sem.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S E M --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2009, 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. --
17 -- --
18 -- You should have received a copy of the GNU General Public License along --
19 -- with this program; see file COPYING3. If not see --
20 -- <http://www.gnu.org/licenses/>. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
26
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Debug_A; use Debug_A;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Expander; use Expander;
33 with Fname; use Fname;
34 with HLO; use HLO;
35 with Lib; use Lib;
36 with Lib.Load; use Lib.Load;
37 with Nlists; use Nlists;
38 with Output; use Output;
39 with Sem_Attr; use Sem_Attr;
40 with Sem_Ch2; use Sem_Ch2;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch4; use Sem_Ch4;
43 with Sem_Ch5; use Sem_Ch5;
44 with Sem_Ch6; use Sem_Ch6;
45 with Sem_Ch7; use Sem_Ch7;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Ch9; use Sem_Ch9;
48 with Sem_Ch10; use Sem_Ch10;
49 with Sem_Ch11; use Sem_Ch11;
50 with Sem_Ch12; use Sem_Ch12;
51 with Sem_Ch13; use Sem_Ch13;
52 with Sem_Prag; use Sem_Prag;
53 with Sem_Util; use Sem_Util;
54 with Sinfo; use Sinfo;
55 with Stand; use Stand;
56 with Uintp; use Uintp;
57 with Uname; use Uname;
58
59 with Unchecked_Deallocation;
60
61 pragma Warnings (Off, Sem_Util);
62 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
63
64 package body Sem is
65
66 Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW;
67 -- Controls debugging printouts for Walk_Library_Items
68
69 Outer_Generic_Scope : Entity_Id := Empty;
70 -- Global reference to the outer scope that is generic. In a non
71 -- generic context, it is empty. At the moment, it is only used
72 -- for avoiding freezing of external references in generics.
73
74 Comp_Unit_List : Elist_Id := No_Elist;
75 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
76 -- processed by Semantics, in an appropriate order. Initialized to
77 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
78 -- to New_Elmt_List on first use.
79
80 Ignore_Comp_Units : Boolean := False;
81 -- If True, we suppress appending compilation units onto the
82 -- Comp_Unit_List.
83
84 procedure Write_Unit_Info
85 (Unit_Num : Unit_Number_Type;
86 Item : Node_Id;
87 Prefix : String := "");
88 -- Print out debugging information about the unit
89
90 -------------
91 -- Analyze --
92 -------------
93
94 procedure Analyze (N : Node_Id) is
95 begin
96 Debug_A_Entry ("analyzing ", N);
97
98 -- Immediate return if already analyzed
99
100 if Analyzed (N) then
101 Debug_A_Exit ("analyzing ", N, " (done, analyzed already)");
102 return;
103 end if;
104
105 -- Otherwise processing depends on the node kind
106
107 case Nkind (N) is
108
109 when N_Abort_Statement =>
110 Analyze_Abort_Statement (N);
111
112 when N_Abstract_Subprogram_Declaration =>
113 Analyze_Abstract_Subprogram_Declaration (N);
114
115 when N_Accept_Alternative =>
116 Analyze_Accept_Alternative (N);
117
118 when N_Accept_Statement =>
119 Analyze_Accept_Statement (N);
120
121 when N_Aggregate =>
122 Analyze_Aggregate (N);
123
124 when N_Allocator =>
125 Analyze_Allocator (N);
126
127 when N_And_Then =>
128 Analyze_Short_Circuit (N);
129
130 when N_Assignment_Statement =>
131 Analyze_Assignment (N);
132
133 when N_Asynchronous_Select =>
134 Analyze_Asynchronous_Select (N);
135
136 when N_At_Clause =>
137 Analyze_At_Clause (N);
138
139 when N_Attribute_Reference =>
140 Analyze_Attribute (N);
141
142 when N_Attribute_Definition_Clause =>
143 Analyze_Attribute_Definition_Clause (N);
144
145 when N_Block_Statement =>
146 Analyze_Block_Statement (N);
147
148 when N_Case_Statement =>
149 Analyze_Case_Statement (N);
150
151 when N_Character_Literal =>
152 Analyze_Character_Literal (N);
153
154 when N_Code_Statement =>
155 Analyze_Code_Statement (N);
156
157 when N_Compilation_Unit =>
158 Analyze_Compilation_Unit (N);
159
160 when N_Component_Declaration =>
161 Analyze_Component_Declaration (N);
162
163 when N_Conditional_Expression =>
164 Analyze_Conditional_Expression (N);
165
166 when N_Conditional_Entry_Call =>
167 Analyze_Conditional_Entry_Call (N);
168
169 when N_Delay_Alternative =>
170 Analyze_Delay_Alternative (N);
171
172 when N_Delay_Relative_Statement =>
173 Analyze_Delay_Relative (N);
174
175 when N_Delay_Until_Statement =>
176 Analyze_Delay_Until (N);
177
178 when N_Entry_Body =>
179 Analyze_Entry_Body (N);
180
181 when N_Entry_Body_Formal_Part =>
182 Analyze_Entry_Body_Formal_Part (N);
183
184 when N_Entry_Call_Alternative =>
185 Analyze_Entry_Call_Alternative (N);
186
187 when N_Entry_Declaration =>
188 Analyze_Entry_Declaration (N);
189
190 when N_Entry_Index_Specification =>
191 Analyze_Entry_Index_Specification (N);
192
193 when N_Enumeration_Representation_Clause =>
194 Analyze_Enumeration_Representation_Clause (N);
195
196 when N_Exception_Declaration =>
197 Analyze_Exception_Declaration (N);
198
199 when N_Exception_Renaming_Declaration =>
200 Analyze_Exception_Renaming (N);
201
202 when N_Exit_Statement =>
203 Analyze_Exit_Statement (N);
204
205 when N_Expanded_Name =>
206 Analyze_Expanded_Name (N);
207
208 when N_Explicit_Dereference =>
209 Analyze_Explicit_Dereference (N);
210
211 when N_Extended_Return_Statement =>
212 Analyze_Extended_Return_Statement (N);
213
214 when N_Extension_Aggregate =>
215 Analyze_Aggregate (N);
216
217 when N_Formal_Object_Declaration =>
218 Analyze_Formal_Object_Declaration (N);
219
220 when N_Formal_Package_Declaration =>
221 Analyze_Formal_Package (N);
222
223 when N_Formal_Subprogram_Declaration =>
224 Analyze_Formal_Subprogram (N);
225
226 when N_Formal_Type_Declaration =>
227 Analyze_Formal_Type_Declaration (N);
228
229 when N_Free_Statement =>
230 Analyze_Free_Statement (N);
231
232 when N_Freeze_Entity =>
233 null; -- no semantic processing required
234
235 when N_Full_Type_Declaration =>
236 Analyze_Type_Declaration (N);
237
238 when N_Function_Call =>
239 Analyze_Function_Call (N);
240
241 when N_Function_Instantiation =>
242 Analyze_Function_Instantiation (N);
243
244 when N_Generic_Function_Renaming_Declaration =>
245 Analyze_Generic_Function_Renaming (N);
246
247 when N_Generic_Package_Declaration =>
248 Analyze_Generic_Package_Declaration (N);
249
250 when N_Generic_Package_Renaming_Declaration =>
251 Analyze_Generic_Package_Renaming (N);
252
253 when N_Generic_Procedure_Renaming_Declaration =>
254 Analyze_Generic_Procedure_Renaming (N);
255
256 when N_Generic_Subprogram_Declaration =>
257 Analyze_Generic_Subprogram_Declaration (N);
258
259 when N_Goto_Statement =>
260 Analyze_Goto_Statement (N);
261
262 when N_Handled_Sequence_Of_Statements =>
263 Analyze_Handled_Statements (N);
264
265 when N_Identifier =>
266 Analyze_Identifier (N);
267
268 when N_If_Statement =>
269 Analyze_If_Statement (N);
270
271 when N_Implicit_Label_Declaration =>
272 Analyze_Implicit_Label_Declaration (N);
273
274 when N_In =>
275 Analyze_Membership_Op (N);
276
277 when N_Incomplete_Type_Declaration =>
278 Analyze_Incomplete_Type_Decl (N);
279
280 when N_Indexed_Component =>
281 Analyze_Indexed_Component_Form (N);
282
283 when N_Integer_Literal =>
284 Analyze_Integer_Literal (N);
285
286 when N_Itype_Reference =>
287 Analyze_Itype_Reference (N);
288
289 when N_Label =>
290 Analyze_Label (N);
291
292 when N_Loop_Statement =>
293 Analyze_Loop_Statement (N);
294
295 when N_Not_In =>
296 Analyze_Membership_Op (N);
297
298 when N_Null =>
299 Analyze_Null (N);
300
301 when N_Null_Statement =>
302 Analyze_Null_Statement (N);
303
304 when N_Number_Declaration =>
305 Analyze_Number_Declaration (N);
306
307 when N_Object_Declaration =>
308 Analyze_Object_Declaration (N);
309
310 when N_Object_Renaming_Declaration =>
311 Analyze_Object_Renaming (N);
312
313 when N_Operator_Symbol =>
314 Analyze_Operator_Symbol (N);
315
316 when N_Op_Abs =>
317 Analyze_Unary_Op (N);
318
319 when N_Op_Add =>
320 Analyze_Arithmetic_Op (N);
321
322 when N_Op_And =>
323 Analyze_Logical_Op (N);
324
325 when N_Op_Concat =>
326 Analyze_Concatenation (N);
327
328 when N_Op_Divide =>
329 Analyze_Arithmetic_Op (N);
330
331 when N_Op_Eq =>
332 Analyze_Equality_Op (N);
333
334 when N_Op_Expon =>
335 Analyze_Arithmetic_Op (N);
336
337 when N_Op_Ge =>
338 Analyze_Comparison_Op (N);
339
340 when N_Op_Gt =>
341 Analyze_Comparison_Op (N);
342
343 when N_Op_Le =>
344 Analyze_Comparison_Op (N);
345
346 when N_Op_Lt =>
347 Analyze_Comparison_Op (N);
348
349 when N_Op_Minus =>
350 Analyze_Unary_Op (N);
351
352 when N_Op_Mod =>
353 Analyze_Arithmetic_Op (N);
354
355 when N_Op_Multiply =>
356 Analyze_Arithmetic_Op (N);
357
358 when N_Op_Ne =>
359 Analyze_Equality_Op (N);
360
361 when N_Op_Not =>
362 Analyze_Negation (N);
363
364 when N_Op_Or =>
365 Analyze_Logical_Op (N);
366
367 when N_Op_Plus =>
368 Analyze_Unary_Op (N);
369
370 when N_Op_Rem =>
371 Analyze_Arithmetic_Op (N);
372
373 when N_Op_Rotate_Left =>
374 Analyze_Arithmetic_Op (N);
375
376 when N_Op_Rotate_Right =>
377 Analyze_Arithmetic_Op (N);
378
379 when N_Op_Shift_Left =>
380 Analyze_Arithmetic_Op (N);
381
382 when N_Op_Shift_Right =>
383 Analyze_Arithmetic_Op (N);
384
385 when N_Op_Shift_Right_Arithmetic =>
386 Analyze_Arithmetic_Op (N);
387
388 when N_Op_Subtract =>
389 Analyze_Arithmetic_Op (N);
390
391 when N_Op_Xor =>
392 Analyze_Logical_Op (N);
393
394 when N_Or_Else =>
395 Analyze_Short_Circuit (N);
396
397 when N_Others_Choice =>
398 Analyze_Others_Choice (N);
399
400 when N_Package_Body =>
401 Analyze_Package_Body (N);
402
403 when N_Package_Body_Stub =>
404 Analyze_Package_Body_Stub (N);
405
406 when N_Package_Declaration =>
407 Analyze_Package_Declaration (N);
408
409 when N_Package_Instantiation =>
410 Analyze_Package_Instantiation (N);
411
412 when N_Package_Renaming_Declaration =>
413 Analyze_Package_Renaming (N);
414
415 when N_Package_Specification =>
416 Analyze_Package_Specification (N);
417
418 when N_Parameter_Association =>
419 Analyze_Parameter_Association (N);
420
421 when N_Pragma =>
422 Analyze_Pragma (N);
423
424 when N_Private_Extension_Declaration =>
425 Analyze_Private_Extension_Declaration (N);
426
427 when N_Private_Type_Declaration =>
428 Analyze_Private_Type_Declaration (N);
429
430 when N_Procedure_Call_Statement =>
431 Analyze_Procedure_Call (N);
432
433 when N_Procedure_Instantiation =>
434 Analyze_Procedure_Instantiation (N);
435
436 when N_Protected_Body =>
437 Analyze_Protected_Body (N);
438
439 when N_Protected_Body_Stub =>
440 Analyze_Protected_Body_Stub (N);
441
442 when N_Protected_Definition =>
443 Analyze_Protected_Definition (N);
444
445 when N_Protected_Type_Declaration =>
446 Analyze_Protected_Type (N);
447
448 when N_Qualified_Expression =>
449 Analyze_Qualified_Expression (N);
450
451 when N_Raise_Statement =>
452 Analyze_Raise_Statement (N);
453
454 when N_Raise_xxx_Error =>
455 Analyze_Raise_xxx_Error (N);
456
457 when N_Range =>
458 Analyze_Range (N);
459
460 when N_Range_Constraint =>
461 Analyze_Range (Range_Expression (N));
462
463 when N_Real_Literal =>
464 Analyze_Real_Literal (N);
465
466 when N_Record_Representation_Clause =>
467 Analyze_Record_Representation_Clause (N);
468
469 when N_Reference =>
470 Analyze_Reference (N);
471
472 when N_Requeue_Statement =>
473 Analyze_Requeue (N);
474
475 when N_Simple_Return_Statement =>
476 Analyze_Simple_Return_Statement (N);
477
478 when N_Selected_Component =>
479 Find_Selected_Component (N);
480 -- ??? why not Analyze_Selected_Component, needs comments
481
482 when N_Selective_Accept =>
483 Analyze_Selective_Accept (N);
484
485 when N_Single_Protected_Declaration =>
486 Analyze_Single_Protected (N);
487
488 when N_Single_Task_Declaration =>
489 Analyze_Single_Task (N);
490
491 when N_Slice =>
492 Analyze_Slice (N);
493
494 when N_String_Literal =>
495 Analyze_String_Literal (N);
496
497 when N_Subprogram_Body =>
498 Analyze_Subprogram_Body (N);
499
500 when N_Subprogram_Body_Stub =>
501 Analyze_Subprogram_Body_Stub (N);
502
503 when N_Subprogram_Declaration =>
504 Analyze_Subprogram_Declaration (N);
505
506 when N_Subprogram_Info =>
507 Analyze_Subprogram_Info (N);
508
509 when N_Subprogram_Renaming_Declaration =>
510 Analyze_Subprogram_Renaming (N);
511
512 when N_Subtype_Declaration =>
513 Analyze_Subtype_Declaration (N);
514
515 when N_Subtype_Indication =>
516 Analyze_Subtype_Indication (N);
517
518 when N_Subunit =>
519 Analyze_Subunit (N);
520
521 when N_Task_Body =>
522 Analyze_Task_Body (N);
523
524 when N_Task_Body_Stub =>
525 Analyze_Task_Body_Stub (N);
526
527 when N_Task_Definition =>
528 Analyze_Task_Definition (N);
529
530 when N_Task_Type_Declaration =>
531 Analyze_Task_Type (N);
532
533 when N_Terminate_Alternative =>
534 Analyze_Terminate_Alternative (N);
535
536 when N_Timed_Entry_Call =>
537 Analyze_Timed_Entry_Call (N);
538
539 when N_Triggering_Alternative =>
540 Analyze_Triggering_Alternative (N);
541
542 when N_Type_Conversion =>
543 Analyze_Type_Conversion (N);
544
545 when N_Unchecked_Expression =>
546 Analyze_Unchecked_Expression (N);
547
548 when N_Unchecked_Type_Conversion =>
549 Analyze_Unchecked_Type_Conversion (N);
550
551 when N_Use_Package_Clause =>
552 Analyze_Use_Package (N);
553
554 when N_Use_Type_Clause =>
555 Analyze_Use_Type (N);
556
557 when N_Validate_Unchecked_Conversion =>
558 null;
559
560 when N_Variant_Part =>
561 Analyze_Variant_Part (N);
562
563 when N_With_Clause =>
564 Analyze_With_Clause (N);
565
566 -- A call to analyze the Empty node is an error, but most likely
567 -- it is an error caused by an attempt to analyze a malformed
568 -- piece of tree caused by some other error, so if there have
569 -- been any other errors, we just ignore it, otherwise it is
570 -- a real internal error which we complain about.
571
572 -- We must also consider the case of call to a runtime function
573 -- that is not available in the configurable runtime.
574
575 when N_Empty =>
576 pragma Assert (Serious_Errors_Detected /= 0
577 or else Configurable_Run_Time_Violations /= 0);
578 null;
579
580 -- A call to analyze the error node is simply ignored, to avoid
581 -- causing cascaded errors (happens of course only in error cases)
582
583 when N_Error =>
584 null;
585
586 -- Push/Pop nodes normally don't come through an analyze call. An
587 -- exception is the dummy ones bracketing a subprogram body. In any
588 -- case there is nothing to be done to analyze such nodes.
589
590 when N_Push_Pop_xxx_Label =>
591 null;
592
593 -- For the remaining node types, we generate compiler abort, because
594 -- these nodes are always analyzed within the Sem_Chn routines and
595 -- there should never be a case of making a call to the main Analyze
596 -- routine for these node kinds. For example, an N_Access_Definition
597 -- node appears only in the context of a type declaration, and is
598 -- processed by the analyze routine for type declarations.
599
600 when
601 N_Abortable_Part |
602 N_Access_Definition |
603 N_Access_Function_Definition |
604 N_Access_Procedure_Definition |
605 N_Access_To_Object_Definition |
606 N_Case_Statement_Alternative |
607 N_Compilation_Unit_Aux |
608 N_Component_Association |
609 N_Component_Clause |
610 N_Component_Definition |
611 N_Component_List |
612 N_Constrained_Array_Definition |
613 N_Decimal_Fixed_Point_Definition |
614 N_Defining_Character_Literal |
615 N_Defining_Identifier |
616 N_Defining_Operator_Symbol |
617 N_Defining_Program_Unit_Name |
618 N_Delta_Constraint |
619 N_Derived_Type_Definition |
620 N_Designator |
621 N_Digits_Constraint |
622 N_Discriminant_Association |
623 N_Discriminant_Specification |
624 N_Elsif_Part |
625 N_Entry_Call_Statement |
626 N_Enumeration_Type_Definition |
627 N_Exception_Handler |
628 N_Floating_Point_Definition |
629 N_Formal_Decimal_Fixed_Point_Definition |
630 N_Formal_Derived_Type_Definition |
631 N_Formal_Discrete_Type_Definition |
632 N_Formal_Floating_Point_Definition |
633 N_Formal_Modular_Type_Definition |
634 N_Formal_Ordinary_Fixed_Point_Definition |
635 N_Formal_Private_Type_Definition |
636 N_Formal_Signed_Integer_Type_Definition |
637 N_Function_Specification |
638 N_Generic_Association |
639 N_Index_Or_Discriminant_Constraint |
640 N_Iteration_Scheme |
641 N_Loop_Parameter_Specification |
642 N_Mod_Clause |
643 N_Modular_Type_Definition |
644 N_Ordinary_Fixed_Point_Definition |
645 N_Parameter_Specification |
646 N_Pragma_Argument_Association |
647 N_Procedure_Specification |
648 N_Real_Range_Specification |
649 N_Record_Definition |
650 N_Signed_Integer_Type_Definition |
651 N_Unconstrained_Array_Definition |
652 N_Unused_At_Start |
653 N_Unused_At_End |
654 N_Variant =>
655
656 raise Program_Error;
657 end case;
658
659 Debug_A_Exit ("analyzing ", N, " (done)");
660
661 -- Now that we have analyzed the node, we call the expander to perform
662 -- possible expansion. We skip this for subexpressions, because we don't
663 -- have the type yet, and the expander will need to know the type before
664 -- it can do its job. For subexpression nodes, the call to the expander
665 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
666 -- which can appear in a statement context, and needs expanding now in
667 -- the case (distinguished by Etype, as documented in Sinfo).
668
669 -- The Analyzed flag is also set at this point for non-subexpression
670 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
671 -- since resolution and expansion have not yet been completed). Note
672 -- that for N_Raise_xxx_Error we have to distinguish the expression
673 -- case from the statement case.
674
675 if Nkind (N) not in N_Subexpr
676 or else (Nkind (N) in N_Raise_xxx_Error
677 and then Etype (N) = Standard_Void_Type)
678 then
679 Expand (N);
680 end if;
681 end Analyze;
682
683 -- Version with check(s) suppressed
684
685 procedure Analyze (N : Node_Id; Suppress : Check_Id) is
686 begin
687 if Suppress = All_Checks then
688 declare
689 Svg : constant Suppress_Array := Scope_Suppress;
690 begin
691 Scope_Suppress := (others => True);
692 Analyze (N);
693 Scope_Suppress := Svg;
694 end;
695
696 else
697 declare
698 Svg : constant Boolean := Scope_Suppress (Suppress);
699 begin
700 Scope_Suppress (Suppress) := True;
701 Analyze (N);
702 Scope_Suppress (Suppress) := Svg;
703 end;
704 end if;
705 end Analyze;
706
707 ------------------
708 -- Analyze_List --
709 ------------------
710
711 procedure Analyze_List (L : List_Id) is
712 Node : Node_Id;
713
714 begin
715 Node := First (L);
716 while Present (Node) loop
717 Analyze (Node);
718 Next (Node);
719 end loop;
720 end Analyze_List;
721
722 -- Version with check(s) suppressed
723
724 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
725 begin
726 if Suppress = All_Checks then
727 declare
728 Svg : constant Suppress_Array := Scope_Suppress;
729 begin
730 Scope_Suppress := (others => True);
731 Analyze_List (L);
732 Scope_Suppress := Svg;
733 end;
734
735 else
736 declare
737 Svg : constant Boolean := Scope_Suppress (Suppress);
738 begin
739 Scope_Suppress (Suppress) := True;
740 Analyze_List (L);
741 Scope_Suppress (Suppress) := Svg;
742 end;
743 end if;
744 end Analyze_List;
745
746 --------------------------
747 -- Copy_Suppress_Status --
748 --------------------------
749
750 procedure Copy_Suppress_Status
751 (C : Check_Id;
752 From : Entity_Id;
753 To : Entity_Id)
754 is
755 Found : Boolean;
756 pragma Warnings (Off, Found);
757
758 procedure Search_Stack
759 (Top : Suppress_Stack_Entry_Ptr;
760 Found : out Boolean);
761 -- Search given suppress stack for matching entry for entity. If found
762 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
763 -- entry for To onto the local suppress stack.
764
765 ------------------
766 -- Search_Stack --
767 ------------------
768
769 procedure Search_Stack
770 (Top : Suppress_Stack_Entry_Ptr;
771 Found : out Boolean)
772 is
773 Ptr : Suppress_Stack_Entry_Ptr;
774
775 begin
776 Ptr := Top;
777 while Ptr /= null loop
778 if Ptr.Entity = From
779 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
780 then
781 if Ptr.Suppress then
782 Set_Checks_May_Be_Suppressed (To, True);
783 Push_Local_Suppress_Stack_Entry
784 (Entity => To,
785 Check => C,
786 Suppress => True);
787 Found := True;
788 return;
789 end if;
790 end if;
791
792 Ptr := Ptr.Prev;
793 end loop;
794
795 Found := False;
796 return;
797 end Search_Stack;
798
799 -- Start of processing for Copy_Suppress_Status
800
801 begin
802 if not Checks_May_Be_Suppressed (From) then
803 return;
804 end if;
805
806 -- First search the local entity suppress stack, we search this in
807 -- reverse order so that we get the innermost entry that applies to
808 -- this case if there are nested entries. Note that for the purpose
809 -- of this procedure we are ONLY looking for entries corresponding
810 -- to a two-argument Suppress, where the second argument matches From.
811
812 Search_Stack (Global_Suppress_Stack_Top, Found);
813
814 if Found then
815 return;
816 end if;
817
818 -- Now search the global entity suppress table for a matching entry
819 -- We also search this in reverse order so that if there are multiple
820 -- pragmas for the same entity, the last one applies.
821
822 Search_Stack (Local_Suppress_Stack_Top, Found);
823 end Copy_Suppress_Status;
824
825 -------------------------
826 -- Enter_Generic_Scope --
827 -------------------------
828
829 procedure Enter_Generic_Scope (S : Entity_Id) is
830 begin
831 if No (Outer_Generic_Scope) then
832 Outer_Generic_Scope := S;
833 end if;
834 end Enter_Generic_Scope;
835
836 ------------------------
837 -- Exit_Generic_Scope --
838 ------------------------
839
840 procedure Exit_Generic_Scope (S : Entity_Id) is
841 begin
842 if S = Outer_Generic_Scope then
843 Outer_Generic_Scope := Empty;
844 end if;
845 end Exit_Generic_Scope;
846
847 -----------------------
848 -- Explicit_Suppress --
849 -----------------------
850
851 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
852 Ptr : Suppress_Stack_Entry_Ptr;
853
854 begin
855 if not Checks_May_Be_Suppressed (E) then
856 return False;
857
858 else
859 Ptr := Global_Suppress_Stack_Top;
860 while Ptr /= null loop
861 if Ptr.Entity = E
862 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
863 then
864 return Ptr.Suppress;
865 end if;
866
867 Ptr := Ptr.Prev;
868 end loop;
869 end if;
870
871 return False;
872 end Explicit_Suppress;
873
874 -----------------------------
875 -- External_Ref_In_Generic --
876 -----------------------------
877
878 function External_Ref_In_Generic (E : Entity_Id) return Boolean is
879 Scop : Entity_Id;
880
881 begin
882 -- Entity is global if defined outside of current outer_generic_scope:
883 -- Either the entity has a smaller depth that the outer generic, or it
884 -- is in a different compilation unit, or it is defined within a unit
885 -- in the same compilation, that is not within the outer_generic.
886
887 if No (Outer_Generic_Scope) then
888 return False;
889
890 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
891 or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
892 then
893 return True;
894
895 else
896 Scop := Scope (E);
897
898 while Present (Scop) loop
899 if Scop = Outer_Generic_Scope then
900 return False;
901 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
902 return True;
903 else
904 Scop := Scope (Scop);
905 end if;
906 end loop;
907
908 return True;
909 end if;
910 end External_Ref_In_Generic;
911
912 ----------------
913 -- Initialize --
914 ----------------
915
916 procedure Initialize is
917 Next : Suppress_Stack_Entry_Ptr;
918
919 procedure Free is new Unchecked_Deallocation
920 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
921
922 begin
923 -- Free any global suppress stack entries from a previous invocation
924 -- of the compiler (in the normal case this loop does nothing).
925
926 while Suppress_Stack_Entries /= null loop
927 Next := Global_Suppress_Stack_Top.Next;
928 Free (Suppress_Stack_Entries);
929 Suppress_Stack_Entries := Next;
930 end loop;
931
932 Local_Suppress_Stack_Top := null;
933 Global_Suppress_Stack_Top := null;
934
935 -- Clear scope stack, and reset global variables
936
937 Scope_Stack.Init;
938 Unloaded_Subunits := False;
939 end Initialize;
940
941 ------------------------------
942 -- Insert_After_And_Analyze --
943 ------------------------------
944
945 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
946 Node : Node_Id;
947
948 begin
949 if Present (M) then
950
951 -- If we are not at the end of the list, then the easiest
952 -- coding is simply to insert before our successor
953
954 if Present (Next (N)) then
955 Insert_Before_And_Analyze (Next (N), M);
956
957 -- Case of inserting at the end of the list
958
959 else
960 -- Capture the Node_Id of the node to be inserted. This Node_Id
961 -- will still be the same after the insert operation.
962
963 Node := M;
964 Insert_After (N, M);
965
966 -- Now just analyze from the inserted node to the end of
967 -- the new list (note that this properly handles the case
968 -- where any of the analyze calls result in the insertion of
969 -- nodes after the analyzed node, expecting analysis).
970
971 while Present (Node) loop
972 Analyze (Node);
973 Mark_Rewrite_Insertion (Node);
974 Next (Node);
975 end loop;
976 end if;
977 end if;
978 end Insert_After_And_Analyze;
979
980 -- Version with check(s) suppressed
981
982 procedure Insert_After_And_Analyze
983 (N : Node_Id;
984 M : Node_Id;
985 Suppress : Check_Id)
986 is
987 begin
988 if Suppress = All_Checks then
989 declare
990 Svg : constant Suppress_Array := Scope_Suppress;
991 begin
992 Scope_Suppress := (others => True);
993 Insert_After_And_Analyze (N, M);
994 Scope_Suppress := Svg;
995 end;
996
997 else
998 declare
999 Svg : constant Boolean := Scope_Suppress (Suppress);
1000 begin
1001 Scope_Suppress (Suppress) := True;
1002 Insert_After_And_Analyze (N, M);
1003 Scope_Suppress (Suppress) := Svg;
1004 end;
1005 end if;
1006 end Insert_After_And_Analyze;
1007
1008 -------------------------------
1009 -- Insert_Before_And_Analyze --
1010 -------------------------------
1011
1012 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
1013 Node : Node_Id;
1014
1015 begin
1016 if Present (M) then
1017
1018 -- Capture the Node_Id of the first list node to be inserted.
1019 -- This will still be the first node after the insert operation,
1020 -- since Insert_List_After does not modify the Node_Id values.
1021
1022 Node := M;
1023 Insert_Before (N, M);
1024
1025 -- The insertion does not change the Id's of any of the nodes in
1026 -- the list, and they are still linked, so we can simply loop from
1027 -- the original first node until we meet the node before which the
1028 -- insertion is occurring. Note that this properly handles the case
1029 -- where any of the analyzed nodes insert nodes after themselves,
1030 -- expecting them to get analyzed.
1031
1032 while Node /= N loop
1033 Analyze (Node);
1034 Mark_Rewrite_Insertion (Node);
1035 Next (Node);
1036 end loop;
1037 end if;
1038 end Insert_Before_And_Analyze;
1039
1040 -- Version with check(s) suppressed
1041
1042 procedure Insert_Before_And_Analyze
1043 (N : Node_Id;
1044 M : Node_Id;
1045 Suppress : Check_Id)
1046 is
1047 begin
1048 if Suppress = All_Checks then
1049 declare
1050 Svg : constant Suppress_Array := Scope_Suppress;
1051 begin
1052 Scope_Suppress := (others => True);
1053 Insert_Before_And_Analyze (N, M);
1054 Scope_Suppress := Svg;
1055 end;
1056
1057 else
1058 declare
1059 Svg : constant Boolean := Scope_Suppress (Suppress);
1060 begin
1061 Scope_Suppress (Suppress) := True;
1062 Insert_Before_And_Analyze (N, M);
1063 Scope_Suppress (Suppress) := Svg;
1064 end;
1065 end if;
1066 end Insert_Before_And_Analyze;
1067
1068 -----------------------------------
1069 -- Insert_List_After_And_Analyze --
1070 -----------------------------------
1071
1072 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
1073 After : constant Node_Id := Next (N);
1074 Node : Node_Id;
1075
1076 begin
1077 if Is_Non_Empty_List (L) then
1078
1079 -- Capture the Node_Id of the first list node to be inserted.
1080 -- This will still be the first node after the insert operation,
1081 -- since Insert_List_After does not modify the Node_Id values.
1082
1083 Node := First (L);
1084 Insert_List_After (N, L);
1085
1086 -- Now just analyze from the original first node until we get to
1087 -- the successor of the original insertion point (which may be
1088 -- Empty if the insertion point was at the end of the list). Note
1089 -- that this properly handles the case where any of the analyze
1090 -- calls result in the insertion of nodes after the analyzed
1091 -- node (possibly calling this routine recursively).
1092
1093 while Node /= After loop
1094 Analyze (Node);
1095 Mark_Rewrite_Insertion (Node);
1096 Next (Node);
1097 end loop;
1098 end if;
1099 end Insert_List_After_And_Analyze;
1100
1101 -- Version with check(s) suppressed
1102
1103 procedure Insert_List_After_And_Analyze
1104 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1105 is
1106 begin
1107 if Suppress = All_Checks then
1108 declare
1109 Svg : constant Suppress_Array := Scope_Suppress;
1110 begin
1111 Scope_Suppress := (others => True);
1112 Insert_List_After_And_Analyze (N, L);
1113 Scope_Suppress := Svg;
1114 end;
1115
1116 else
1117 declare
1118 Svg : constant Boolean := Scope_Suppress (Suppress);
1119 begin
1120 Scope_Suppress (Suppress) := True;
1121 Insert_List_After_And_Analyze (N, L);
1122 Scope_Suppress (Suppress) := Svg;
1123 end;
1124 end if;
1125 end Insert_List_After_And_Analyze;
1126
1127 ------------------------------------
1128 -- Insert_List_Before_And_Analyze --
1129 ------------------------------------
1130
1131 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
1132 Node : Node_Id;
1133
1134 begin
1135 if Is_Non_Empty_List (L) then
1136
1137 -- Capture the Node_Id of the first list node to be inserted.
1138 -- This will still be the first node after the insert operation,
1139 -- since Insert_List_After does not modify the Node_Id values.
1140
1141 Node := First (L);
1142 Insert_List_Before (N, L);
1143
1144 -- The insertion does not change the Id's of any of the nodes in
1145 -- the list, and they are still linked, so we can simply loop from
1146 -- the original first node until we meet the node before which the
1147 -- insertion is occurring. Note that this properly handles the case
1148 -- where any of the analyzed nodes insert nodes after themselves,
1149 -- expecting them to get analyzed.
1150
1151 while Node /= N loop
1152 Analyze (Node);
1153 Mark_Rewrite_Insertion (Node);
1154 Next (Node);
1155 end loop;
1156 end if;
1157 end Insert_List_Before_And_Analyze;
1158
1159 -- Version with check(s) suppressed
1160
1161 procedure Insert_List_Before_And_Analyze
1162 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1163 is
1164 begin
1165 if Suppress = All_Checks then
1166 declare
1167 Svg : constant Suppress_Array := Scope_Suppress;
1168 begin
1169 Scope_Suppress := (others => True);
1170 Insert_List_Before_And_Analyze (N, L);
1171 Scope_Suppress := Svg;
1172 end;
1173
1174 else
1175 declare
1176 Svg : constant Boolean := Scope_Suppress (Suppress);
1177 begin
1178 Scope_Suppress (Suppress) := True;
1179 Insert_List_Before_And_Analyze (N, L);
1180 Scope_Suppress (Suppress) := Svg;
1181 end;
1182 end if;
1183 end Insert_List_Before_And_Analyze;
1184
1185 -------------------------
1186 -- Is_Check_Suppressed --
1187 -------------------------
1188
1189 function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
1190
1191 Ptr : Suppress_Stack_Entry_Ptr;
1192
1193 begin
1194 -- First search the local entity suppress stack, we search this from the
1195 -- top of the stack down, so that we get the innermost entry that
1196 -- applies to this case if there are nested entries.
1197
1198 Ptr := Local_Suppress_Stack_Top;
1199 while Ptr /= null loop
1200 if (Ptr.Entity = Empty or else Ptr.Entity = E)
1201 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1202 then
1203 return Ptr.Suppress;
1204 end if;
1205
1206 Ptr := Ptr.Prev;
1207 end loop;
1208
1209 -- Now search the global entity suppress table for a matching entry
1210 -- We also search this from the top down so that if there are multiple
1211 -- pragmas for the same entity, the last one applies (not clear what
1212 -- or whether the RM specifies this handling, but it seems reasonable).
1213
1214 Ptr := Global_Suppress_Stack_Top;
1215 while Ptr /= null loop
1216 if (Ptr.Entity = Empty or else Ptr.Entity = E)
1217 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1218 then
1219 return Ptr.Suppress;
1220 end if;
1221
1222 Ptr := Ptr.Prev;
1223 end loop;
1224
1225 -- If we did not find a matching entry, then use the normal scope
1226 -- suppress value after all (actually this will be the global setting
1227 -- since it clearly was not overridden at any point). For a predefined
1228 -- check, we test the specific flag. For a user defined check, we check
1229 -- the All_Checks flag.
1230
1231 if C in Predefined_Check_Id then
1232 return Scope_Suppress (C);
1233 else
1234 return Scope_Suppress (All_Checks);
1235 end if;
1236 end Is_Check_Suppressed;
1237
1238 ----------
1239 -- Lock --
1240 ----------
1241
1242 procedure Lock is
1243 begin
1244 Scope_Stack.Locked := True;
1245 Scope_Stack.Release;
1246 end Lock;
1247
1248 --------------------------------------
1249 -- Push_Global_Suppress_Stack_Entry --
1250 --------------------------------------
1251
1252 procedure Push_Global_Suppress_Stack_Entry
1253 (Entity : Entity_Id;
1254 Check : Check_Id;
1255 Suppress : Boolean)
1256 is
1257 begin
1258 Global_Suppress_Stack_Top :=
1259 new Suppress_Stack_Entry'
1260 (Entity => Entity,
1261 Check => Check,
1262 Suppress => Suppress,
1263 Prev => Global_Suppress_Stack_Top,
1264 Next => Suppress_Stack_Entries);
1265 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1266 return;
1267
1268 end Push_Global_Suppress_Stack_Entry;
1269
1270 -------------------------------------
1271 -- Push_Local_Suppress_Stack_Entry --
1272 -------------------------------------
1273
1274 procedure Push_Local_Suppress_Stack_Entry
1275 (Entity : Entity_Id;
1276 Check : Check_Id;
1277 Suppress : Boolean)
1278 is
1279 begin
1280 Local_Suppress_Stack_Top :=
1281 new Suppress_Stack_Entry'
1282 (Entity => Entity,
1283 Check => Check,
1284 Suppress => Suppress,
1285 Prev => Local_Suppress_Stack_Top,
1286 Next => Suppress_Stack_Entries);
1287 Suppress_Stack_Entries := Local_Suppress_Stack_Top;
1288
1289 return;
1290 end Push_Local_Suppress_Stack_Entry;
1291
1292 ---------------
1293 -- Semantics --
1294 ---------------
1295
1296 procedure Semantics (Comp_Unit : Node_Id) is
1297
1298 -- The following locations save the corresponding global flags and
1299 -- variables so that they can be restored on completion. This is
1300 -- needed so that calls to Rtsfind start with the proper default
1301 -- values for these variables, and also that such calls do not
1302 -- disturb the settings for units being analyzed at a higher level.
1303
1304 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
1305 S_Full_Analysis : constant Boolean := Full_Analysis;
1306 S_GNAT_Mode : constant Boolean := GNAT_Mode;
1307 S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
1308 S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
1309 S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
1310 S_New_Nodes_OK : constant Int := New_Nodes_OK;
1311 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
1312
1313 Generic_Main : constant Boolean :=
1314 Nkind (Unit (Cunit (Main_Unit)))
1315 in N_Generic_Declaration;
1316 -- If the main unit is generic, every compiled unit, including its
1317 -- context, is compiled with expansion disabled.
1318
1319 Save_Config_Switches : Config_Switches_Type;
1320 -- Variable used to save values of config switches while we analyze
1321 -- the new unit, to be restored on exit for proper recursive behavior.
1322
1323 procedure Do_Analyze;
1324 -- Procedure to analyze the compilation unit. This is called more
1325 -- than once when the high level optimizer is activated.
1326
1327 ----------------
1328 -- Do_Analyze --
1329 ----------------
1330
1331 procedure Do_Analyze is
1332 begin
1333 Save_Scope_Stack;
1334 Push_Scope (Standard_Standard);
1335 Scope_Suppress := Suppress_Options;
1336 Scope_Stack.Table
1337 (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
1338 Scope_Stack.Table
1339 (Scope_Stack.Last).Is_Active_Stack_Base := True;
1340 Outer_Generic_Scope := Empty;
1341
1342 -- Now analyze the top level compilation unit node
1343
1344 Analyze (Comp_Unit);
1345
1346 -- Check for scope mismatch on exit from compilation
1347
1348 pragma Assert (Current_Scope = Standard_Standard
1349 or else Comp_Unit = Cunit (Main_Unit));
1350
1351 -- Then pop entry for Standard, and pop implicit types
1352
1353 Pop_Scope;
1354 Restore_Scope_Stack;
1355 end Do_Analyze;
1356
1357 Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
1358
1359 -- Start of processing for Semantics
1360
1361 begin
1362 if Debug_Unit_Walk then
1363 if Already_Analyzed then
1364 Write_Str ("(done)");
1365 end if;
1366
1367 Write_Unit_Info
1368 (Get_Cunit_Unit_Number (Comp_Unit),
1369 Unit (Comp_Unit),
1370 Prefix => "--> ");
1371 Indent;
1372 end if;
1373
1374 Compiler_State := Analyzing;
1375 Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
1376
1377 -- Compile predefined units with GNAT_Mode set to True, to properly
1378 -- process the categorization stuff. However, do not set GNAT_Mode
1379 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1380 -- Sequential_IO) as this would prevent pragma Extend_System from being
1381 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1382
1383 -- Cleaner might be to do the kludge at the point of excluding the
1384 -- pragma (do not exclude for renamings ???)
1385
1386 if Is_Predefined_File_Name
1387 (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
1388 then
1389 GNAT_Mode := True;
1390 end if;
1391
1392 if Generic_Main then
1393 Expander_Mode_Save_And_Set (False);
1394 else
1395 Expander_Mode_Save_And_Set
1396 (Operating_Mode = Generate_Code or Debug_Flag_X);
1397 end if;
1398
1399 Full_Analysis := True;
1400 Inside_A_Generic := False;
1401 In_Spec_Expression := False;
1402
1403 Set_Comes_From_Source_Default (False);
1404 Save_Opt_Config_Switches (Save_Config_Switches);
1405 Set_Opt_Config_Switches
1406 (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
1407 Current_Sem_Unit = Main_Unit);
1408
1409 -- Only do analysis of unit that has not already been analyzed
1410
1411 if not Analyzed (Comp_Unit) then
1412 Initialize_Version (Current_Sem_Unit);
1413 if HLO_Active then
1414 Expander_Mode_Save_And_Set (False);
1415 New_Nodes_OK := 1;
1416 Do_Analyze;
1417 Reset_Analyzed_Flags (Comp_Unit);
1418 Expander_Mode_Restore;
1419 High_Level_Optimize (Comp_Unit);
1420 New_Nodes_OK := 0;
1421 end if;
1422
1423 -- Do analysis, and then append the compilation unit onto the
1424 -- Comp_Unit_List, if appropriate. This is done after analysis, so
1425 -- if this unit depends on some others, they have already been
1426 -- appended. We ignore bodies, except for the main unit itself. We
1427 -- have also to guard against ill-formed subunits that have an
1428 -- improper context.
1429
1430 Do_Analyze;
1431
1432 if Ignore_Comp_Units then
1433 null;
1434
1435 elsif Present (Comp_Unit)
1436 and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
1437 and then not In_Extended_Main_Source_Unit (Comp_Unit)
1438 then
1439 null;
1440
1441 else
1442 pragma Assert (not Ignore_Comp_Units);
1443
1444 -- Initialize if first time
1445
1446 if No (Comp_Unit_List) then
1447 Comp_Unit_List := New_Elmt_List;
1448 end if;
1449
1450 Append_Elmt (Comp_Unit, Comp_Unit_List);
1451
1452 if Debug_Unit_Walk then
1453 Write_Str ("Appending ");
1454 Write_Unit_Info
1455 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
1456 end if;
1457
1458 -- Ignore all units after main unit
1459
1460 if Comp_Unit = Cunit (Main_Unit) then
1461 Ignore_Comp_Units := True;
1462 end if;
1463 end if;
1464 end if;
1465
1466 -- Save indication of dynamic elaboration checks for ALI file
1467
1468 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
1469
1470 -- Restore settings of saved switches to entry values
1471
1472 Current_Sem_Unit := S_Current_Sem_Unit;
1473 Full_Analysis := S_Full_Analysis;
1474 Global_Discard_Names := S_Global_Dis_Names;
1475 GNAT_Mode := S_GNAT_Mode;
1476 In_Spec_Expression := S_In_Spec_Expr;
1477 Inside_A_Generic := S_Inside_A_Generic;
1478 New_Nodes_OK := S_New_Nodes_OK;
1479 Outer_Generic_Scope := S_Outer_Gen_Scope;
1480
1481 Restore_Opt_Config_Switches (Save_Config_Switches);
1482 Expander_Mode_Restore;
1483
1484 if Debug_Unit_Walk then
1485 Outdent;
1486
1487 if Already_Analyzed then
1488 Write_Str ("(done)");
1489 end if;
1490
1491 Write_Unit_Info
1492 (Get_Cunit_Unit_Number (Comp_Unit),
1493 Unit (Comp_Unit),
1494 Prefix => "<-- ");
1495 end if;
1496 end Semantics;
1497
1498 ------------------------
1499 -- Walk_Library_Items --
1500 ------------------------
1501
1502 procedure Walk_Library_Items is
1503 type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
1504 Seen : Unit_Number_Set := (others => False);
1505
1506 procedure Do_Action (CU : Node_Id; Item : Node_Id);
1507 -- Calls Action, with some validity checks
1508
1509 ---------------
1510 -- Do_Action --
1511 ---------------
1512
1513 procedure Do_Action (CU : Node_Id; Item : Node_Id) is
1514 begin
1515 -- This calls Action at the end. All the preceding code is just
1516 -- assertions and debugging output.
1517
1518 pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
1519
1520 case Nkind (Item) is
1521 when N_Generic_Subprogram_Declaration |
1522 N_Generic_Package_Declaration |
1523 N_Package_Declaration |
1524 N_Subprogram_Declaration |
1525 N_Subprogram_Renaming_Declaration |
1526 N_Package_Renaming_Declaration |
1527 N_Generic_Function_Renaming_Declaration |
1528 N_Generic_Package_Renaming_Declaration |
1529 N_Generic_Procedure_Renaming_Declaration =>
1530 null; -- Specs are OK
1531
1532 when N_Package_Body | N_Subprogram_Body =>
1533 -- A body must be the main unit
1534
1535 pragma Assert (CU = Cunit (Main_Unit));
1536 null;
1537
1538 -- All other cases cannot happen
1539
1540 when N_Function_Instantiation |
1541 N_Procedure_Instantiation |
1542 N_Package_Instantiation =>
1543 pragma Assert (False, "instantiation");
1544 null;
1545
1546 when N_Subunit =>
1547 pragma Assert (False, "subunit");
1548 null;
1549
1550 when others =>
1551 pragma Assert (False);
1552 null;
1553 end case;
1554
1555 if Present (CU) then
1556 pragma Assert (Item /= Stand.Standard_Package_Node);
1557 pragma Assert (Item = Unit (CU));
1558
1559 declare
1560 Unit_Num : constant Unit_Number_Type :=
1561 Get_Cunit_Unit_Number (CU);
1562 begin
1563 if Debug_Unit_Walk then
1564 Write_Unit_Info (Unit_Num, Item);
1565 end if;
1566
1567 -- This assertion is commented out because it fails in some
1568 -- circumstances related to library-level generic
1569 -- instantiations. We need to investigate why.
1570 -- ???pragma Assert (not Seen (Unit_Num));
1571
1572 Seen (Unit_Num) := True;
1573 end;
1574
1575 else
1576 -- Must be Standard
1577
1578 pragma Assert (Item = Stand.Standard_Package_Node);
1579
1580 if Debug_Unit_Walk then
1581 Write_Line ("Standard");
1582 end if;
1583 end if;
1584
1585 Action (Item);
1586 end Do_Action;
1587
1588 -- Local Declarations
1589
1590 Cur : Elmt_Id := First_Elmt (Comp_Unit_List);
1591
1592 -- Start of processing for Walk_Library_Items
1593
1594 begin
1595 if Debug_Unit_Walk then
1596 Write_Line ("Walk_Library_Items:");
1597 Indent;
1598 end if;
1599
1600 -- Do Standard first, then walk the Comp_Unit_List
1601
1602 Do_Action (Empty, Standard_Package_Node);
1603
1604 while Present (Cur) loop
1605 declare
1606 CU : constant Node_Id := Node (Cur);
1607 N : constant Node_Id := Unit (CU);
1608
1609 begin
1610 pragma Assert (Nkind (CU) = N_Compilation_Unit);
1611
1612 case Nkind (N) is
1613
1614 -- If it's a body, then ignore it, unless it's an instance (in
1615 -- which case we do the spec), or it's the main unit (in which
1616 -- case we do it). Note that it could be both, in which case we
1617 -- do the spec first.
1618
1619 when N_Package_Body | N_Subprogram_Body =>
1620 declare
1621 Entity : Node_Id := N;
1622
1623 begin
1624 if Nkind (N) = N_Subprogram_Body then
1625 Entity := Specification (Entity);
1626 end if;
1627
1628 Entity := Defining_Unit_Name (Entity);
1629
1630 if Nkind (Entity) not in N_Entity then
1631
1632 -- Must be N_Defining_Program_Unit_Name
1633
1634 Entity := Defining_Identifier (Entity);
1635 end if;
1636
1637 if Is_Generic_Instance (Entity) then
1638 declare
1639 Spec_Unit : constant Node_Id := Library_Unit (CU);
1640 begin
1641 Do_Action (Spec_Unit, Unit (Spec_Unit));
1642 end;
1643 end if;
1644 end;
1645
1646 if CU = Cunit (Main_Unit) then
1647
1648 -- Must come last
1649
1650 pragma Assert (No (Next_Elmt (Cur)));
1651
1652 Do_Action (CU, N);
1653 end if;
1654
1655 -- It's a spec, so just do it
1656
1657 when others =>
1658 Do_Action (CU, N);
1659 end case;
1660 end;
1661
1662 Next_Elmt (Cur);
1663 end loop;
1664
1665 if Debug_Unit_Walk then
1666 if Seen /= (Seen'Range => True) then
1667 Write_Eol;
1668 Write_Line ("Ignored units:");
1669
1670 Indent;
1671
1672 for Unit_Num in Seen'Range loop
1673 if not Seen (Unit_Num) then
1674 Write_Unit_Info (Unit_Num, Unit (Cunit (Unit_Num)));
1675 end if;
1676 end loop;
1677
1678 Outdent;
1679 end if;
1680 end if;
1681
1682 if Debug_Unit_Walk then
1683 Outdent;
1684 Write_Line ("end Walk_Library_Items.");
1685 end if;
1686 end Walk_Library_Items;
1687
1688 ---------------------
1689 -- Write_Unit_Info --
1690 ---------------------
1691
1692 procedure Write_Unit_Info
1693 (Unit_Num : Unit_Number_Type;
1694 Item : Node_Id;
1695 Prefix : String := "")
1696 is
1697 begin
1698 Write_Str (Prefix);
1699 Write_Unit_Name (Unit_Name (Unit_Num));
1700 Write_Str (", unit ");
1701 Write_Int (Int (Unit_Num));
1702 Write_Str (", ");
1703 Write_Int (Int (Item));
1704 Write_Str ("=");
1705 Write_Str (Node_Kind'Image (Nkind (Item)));
1706
1707 if Item /= Original_Node (Item) then
1708 Write_Str (", orig = ");
1709 Write_Int (Int (Original_Node (Item)));
1710 Write_Str ("=");
1711 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
1712 end if;
1713
1714 Write_Eol;
1715 end Write_Unit_Info;
1716
1717 end Sem;