1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
18 -- You should have received a copy of the GNU General Public License along --
19 -- with this program; see file COPYING3. If not see --
20 -- <http://www.gnu.org/licenses/>. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Debug_A; use Debug_A;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Expander; use Expander;
33 with Fname; use Fname;
36 with Lib.Load; use Lib.Load;
37 with Nlists; use Nlists;
38 with Output; use Output;
39 with Sem_Attr; use Sem_Attr;
40 with Sem_Ch2; use Sem_Ch2;
41 with Sem_Ch3; use Sem_Ch3;
42 with Sem_Ch4; use Sem_Ch4;
43 with Sem_Ch5; use Sem_Ch5;
44 with Sem_Ch6; use Sem_Ch6;
45 with Sem_Ch7; use Sem_Ch7;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Ch9; use Sem_Ch9;
48 with Sem_Ch10; use Sem_Ch10;
49 with Sem_Ch11; use Sem_Ch11;
50 with Sem_Ch12; use Sem_Ch12;
51 with Sem_Ch13; use Sem_Ch13;
52 with Sem_Prag; use Sem_Prag;
53 with Sem_Util; use Sem_Util;
54 with Sinfo; use Sinfo;
55 with Stand; use Stand;
56 with Uintp; use Uintp;
57 with Uname; use Uname;
59 with Unchecked_Deallocation;
61 pragma Warnings (Off, Sem_Util);
62 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
66 Outer_Generic_Scope : Entity_Id := Empty;
67 -- Global reference to the outer scope that is generic. In a non
68 -- generic context, it is empty. At the moment, it is only used
69 -- for avoiding freezing of external references in generics.
71 Comp_Unit_List : Elist_Id := No_Elist;
72 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
73 -- processed by Semantics, in an appropriate order. Initialized to
74 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
75 -- to New_Elmt_List on first use.
77 Ignore_Comp_Units : Boolean := False;
78 -- If True, we suppress appending compilation units onto the
85 procedure Analyze (N : Node_Id) is
87 Debug_A_Entry ("analyzing ", N);
89 -- Immediate return if already analyzed
92 Debug_A_Exit ("analyzing ", N, " (done, analyzed already)");
96 -- Otherwise processing depends on the node kind
100 when N_Abort_Statement =>
101 Analyze_Abort_Statement (N);
103 when N_Abstract_Subprogram_Declaration =>
104 Analyze_Abstract_Subprogram_Declaration (N);
106 when N_Accept_Alternative =>
107 Analyze_Accept_Alternative (N);
109 when N_Accept_Statement =>
110 Analyze_Accept_Statement (N);
113 Analyze_Aggregate (N);
116 Analyze_Allocator (N);
119 Analyze_Short_Circuit (N);
121 when N_Assignment_Statement =>
122 Analyze_Assignment (N);
124 when N_Asynchronous_Select =>
125 Analyze_Asynchronous_Select (N);
128 Analyze_At_Clause (N);
130 when N_Attribute_Reference =>
131 Analyze_Attribute (N);
133 when N_Attribute_Definition_Clause =>
134 Analyze_Attribute_Definition_Clause (N);
136 when N_Block_Statement =>
137 Analyze_Block_Statement (N);
139 when N_Case_Statement =>
140 Analyze_Case_Statement (N);
142 when N_Character_Literal =>
143 Analyze_Character_Literal (N);
145 when N_Code_Statement =>
146 Analyze_Code_Statement (N);
148 when N_Compilation_Unit =>
149 Analyze_Compilation_Unit (N);
151 when N_Component_Declaration =>
152 Analyze_Component_Declaration (N);
154 when N_Conditional_Expression =>
155 Analyze_Conditional_Expression (N);
157 when N_Conditional_Entry_Call =>
158 Analyze_Conditional_Entry_Call (N);
160 when N_Delay_Alternative =>
161 Analyze_Delay_Alternative (N);
163 when N_Delay_Relative_Statement =>
164 Analyze_Delay_Relative (N);
166 when N_Delay_Until_Statement =>
167 Analyze_Delay_Until (N);
170 Analyze_Entry_Body (N);
172 when N_Entry_Body_Formal_Part =>
173 Analyze_Entry_Body_Formal_Part (N);
175 when N_Entry_Call_Alternative =>
176 Analyze_Entry_Call_Alternative (N);
178 when N_Entry_Declaration =>
179 Analyze_Entry_Declaration (N);
181 when N_Entry_Index_Specification =>
182 Analyze_Entry_Index_Specification (N);
184 when N_Enumeration_Representation_Clause =>
185 Analyze_Enumeration_Representation_Clause (N);
187 when N_Exception_Declaration =>
188 Analyze_Exception_Declaration (N);
190 when N_Exception_Renaming_Declaration =>
191 Analyze_Exception_Renaming (N);
193 when N_Exit_Statement =>
194 Analyze_Exit_Statement (N);
196 when N_Expanded_Name =>
197 Analyze_Expanded_Name (N);
199 when N_Explicit_Dereference =>
200 Analyze_Explicit_Dereference (N);
202 when N_Extended_Return_Statement =>
203 Analyze_Extended_Return_Statement (N);
205 when N_Extension_Aggregate =>
206 Analyze_Aggregate (N);
208 when N_Formal_Object_Declaration =>
209 Analyze_Formal_Object_Declaration (N);
211 when N_Formal_Package_Declaration =>
212 Analyze_Formal_Package (N);
214 when N_Formal_Subprogram_Declaration =>
215 Analyze_Formal_Subprogram (N);
217 when N_Formal_Type_Declaration =>
218 Analyze_Formal_Type_Declaration (N);
220 when N_Free_Statement =>
221 Analyze_Free_Statement (N);
223 when N_Freeze_Entity =>
224 null; -- no semantic processing required
226 when N_Full_Type_Declaration =>
227 Analyze_Type_Declaration (N);
229 when N_Function_Call =>
230 Analyze_Function_Call (N);
232 when N_Function_Instantiation =>
233 Analyze_Function_Instantiation (N);
235 when N_Generic_Function_Renaming_Declaration =>
236 Analyze_Generic_Function_Renaming (N);
238 when N_Generic_Package_Declaration =>
239 Analyze_Generic_Package_Declaration (N);
241 when N_Generic_Package_Renaming_Declaration =>
242 Analyze_Generic_Package_Renaming (N);
244 when N_Generic_Procedure_Renaming_Declaration =>
245 Analyze_Generic_Procedure_Renaming (N);
247 when N_Generic_Subprogram_Declaration =>
248 Analyze_Generic_Subprogram_Declaration (N);
250 when N_Goto_Statement =>
251 Analyze_Goto_Statement (N);
253 when N_Handled_Sequence_Of_Statements =>
254 Analyze_Handled_Statements (N);
257 Analyze_Identifier (N);
259 when N_If_Statement =>
260 Analyze_If_Statement (N);
262 when N_Implicit_Label_Declaration =>
263 Analyze_Implicit_Label_Declaration (N);
266 Analyze_Membership_Op (N);
268 when N_Incomplete_Type_Declaration =>
269 Analyze_Incomplete_Type_Decl (N);
271 when N_Indexed_Component =>
272 Analyze_Indexed_Component_Form (N);
274 when N_Integer_Literal =>
275 Analyze_Integer_Literal (N);
277 when N_Itype_Reference =>
278 Analyze_Itype_Reference (N);
283 when N_Loop_Statement =>
284 Analyze_Loop_Statement (N);
287 Analyze_Membership_Op (N);
292 when N_Null_Statement =>
293 Analyze_Null_Statement (N);
295 when N_Number_Declaration =>
296 Analyze_Number_Declaration (N);
298 when N_Object_Declaration =>
299 Analyze_Object_Declaration (N);
301 when N_Object_Renaming_Declaration =>
302 Analyze_Object_Renaming (N);
304 when N_Operator_Symbol =>
305 Analyze_Operator_Symbol (N);
308 Analyze_Unary_Op (N);
311 Analyze_Arithmetic_Op (N);
314 Analyze_Logical_Op (N);
317 Analyze_Concatenation (N);
320 Analyze_Arithmetic_Op (N);
323 Analyze_Equality_Op (N);
326 Analyze_Arithmetic_Op (N);
329 Analyze_Comparison_Op (N);
332 Analyze_Comparison_Op (N);
335 Analyze_Comparison_Op (N);
338 Analyze_Comparison_Op (N);
341 Analyze_Unary_Op (N);
344 Analyze_Arithmetic_Op (N);
346 when N_Op_Multiply =>
347 Analyze_Arithmetic_Op (N);
350 Analyze_Equality_Op (N);
353 Analyze_Negation (N);
356 Analyze_Logical_Op (N);
359 Analyze_Unary_Op (N);
362 Analyze_Arithmetic_Op (N);
364 when N_Op_Rotate_Left =>
365 Analyze_Arithmetic_Op (N);
367 when N_Op_Rotate_Right =>
368 Analyze_Arithmetic_Op (N);
370 when N_Op_Shift_Left =>
371 Analyze_Arithmetic_Op (N);
373 when N_Op_Shift_Right =>
374 Analyze_Arithmetic_Op (N);
376 when N_Op_Shift_Right_Arithmetic =>
377 Analyze_Arithmetic_Op (N);
379 when N_Op_Subtract =>
380 Analyze_Arithmetic_Op (N);
383 Analyze_Logical_Op (N);
386 Analyze_Short_Circuit (N);
388 when N_Others_Choice =>
389 Analyze_Others_Choice (N);
391 when N_Package_Body =>
392 Analyze_Package_Body (N);
394 when N_Package_Body_Stub =>
395 Analyze_Package_Body_Stub (N);
397 when N_Package_Declaration =>
398 Analyze_Package_Declaration (N);
400 when N_Package_Instantiation =>
401 Analyze_Package_Instantiation (N);
403 when N_Package_Renaming_Declaration =>
404 Analyze_Package_Renaming (N);
406 when N_Package_Specification =>
407 Analyze_Package_Specification (N);
409 when N_Parameter_Association =>
410 Analyze_Parameter_Association (N);
415 when N_Private_Extension_Declaration =>
416 Analyze_Private_Extension_Declaration (N);
418 when N_Private_Type_Declaration =>
419 Analyze_Private_Type_Declaration (N);
421 when N_Procedure_Call_Statement =>
422 Analyze_Procedure_Call (N);
424 when N_Procedure_Instantiation =>
425 Analyze_Procedure_Instantiation (N);
427 when N_Protected_Body =>
428 Analyze_Protected_Body (N);
430 when N_Protected_Body_Stub =>
431 Analyze_Protected_Body_Stub (N);
433 when N_Protected_Definition =>
434 Analyze_Protected_Definition (N);
436 when N_Protected_Type_Declaration =>
437 Analyze_Protected_Type (N);
439 when N_Qualified_Expression =>
440 Analyze_Qualified_Expression (N);
442 when N_Raise_Statement =>
443 Analyze_Raise_Statement (N);
445 when N_Raise_xxx_Error =>
446 Analyze_Raise_xxx_Error (N);
451 when N_Range_Constraint =>
452 Analyze_Range (Range_Expression (N));
454 when N_Real_Literal =>
455 Analyze_Real_Literal (N);
457 when N_Record_Representation_Clause =>
458 Analyze_Record_Representation_Clause (N);
461 Analyze_Reference (N);
463 when N_Requeue_Statement =>
466 when N_Simple_Return_Statement =>
467 Analyze_Simple_Return_Statement (N);
469 when N_Selected_Component =>
470 Find_Selected_Component (N);
471 -- ??? why not Analyze_Selected_Component, needs comments
473 when N_Selective_Accept =>
474 Analyze_Selective_Accept (N);
476 when N_Single_Protected_Declaration =>
477 Analyze_Single_Protected (N);
479 when N_Single_Task_Declaration =>
480 Analyze_Single_Task (N);
485 when N_String_Literal =>
486 Analyze_String_Literal (N);
488 when N_Subprogram_Body =>
489 Analyze_Subprogram_Body (N);
491 when N_Subprogram_Body_Stub =>
492 Analyze_Subprogram_Body_Stub (N);
494 when N_Subprogram_Declaration =>
495 Analyze_Subprogram_Declaration (N);
497 when N_Subprogram_Info =>
498 Analyze_Subprogram_Info (N);
500 when N_Subprogram_Renaming_Declaration =>
501 Analyze_Subprogram_Renaming (N);
503 when N_Subtype_Declaration =>
504 Analyze_Subtype_Declaration (N);
506 when N_Subtype_Indication =>
507 Analyze_Subtype_Indication (N);
513 Analyze_Task_Body (N);
515 when N_Task_Body_Stub =>
516 Analyze_Task_Body_Stub (N);
518 when N_Task_Definition =>
519 Analyze_Task_Definition (N);
521 when N_Task_Type_Declaration =>
522 Analyze_Task_Type (N);
524 when N_Terminate_Alternative =>
525 Analyze_Terminate_Alternative (N);
527 when N_Timed_Entry_Call =>
528 Analyze_Timed_Entry_Call (N);
530 when N_Triggering_Alternative =>
531 Analyze_Triggering_Alternative (N);
533 when N_Type_Conversion =>
534 Analyze_Type_Conversion (N);
536 when N_Unchecked_Expression =>
537 Analyze_Unchecked_Expression (N);
539 when N_Unchecked_Type_Conversion =>
540 Analyze_Unchecked_Type_Conversion (N);
542 when N_Use_Package_Clause =>
543 Analyze_Use_Package (N);
545 when N_Use_Type_Clause =>
546 Analyze_Use_Type (N);
548 when N_Validate_Unchecked_Conversion =>
551 when N_Variant_Part =>
552 Analyze_Variant_Part (N);
554 when N_With_Clause =>
555 Analyze_With_Clause (N);
557 -- A call to analyze the Empty node is an error, but most likely
558 -- it is an error caused by an attempt to analyze a malformed
559 -- piece of tree caused by some other error, so if there have
560 -- been any other errors, we just ignore it, otherwise it is
561 -- a real internal error which we complain about.
563 -- We must also consider the case of call to a runtime function
564 -- that is not available in the configurable runtime.
567 pragma Assert (Serious_Errors_Detected /= 0
568 or else Configurable_Run_Time_Violations /= 0);
571 -- A call to analyze the error node is simply ignored, to avoid
572 -- causing cascaded errors (happens of course only in error cases)
577 -- Push/Pop nodes normally don't come through an analyze call. An
578 -- exception is the dummy ones bracketing a subprogram body. In any
579 -- case there is nothing to be done to analyze such nodes.
581 when N_Push_Pop_xxx_Label =>
584 -- For the remaining node types, we generate compiler abort, because
585 -- these nodes are always analyzed within the Sem_Chn routines and
586 -- there should never be a case of making a call to the main Analyze
587 -- routine for these node kinds. For example, an N_Access_Definition
588 -- node appears only in the context of a type declaration, and is
589 -- processed by the analyze routine for type declarations.
593 N_Access_Definition |
594 N_Access_Function_Definition |
595 N_Access_Procedure_Definition |
596 N_Access_To_Object_Definition |
597 N_Case_Statement_Alternative |
598 N_Compilation_Unit_Aux |
599 N_Component_Association |
601 N_Component_Definition |
603 N_Constrained_Array_Definition |
604 N_Decimal_Fixed_Point_Definition |
605 N_Defining_Character_Literal |
606 N_Defining_Identifier |
607 N_Defining_Operator_Symbol |
608 N_Defining_Program_Unit_Name |
610 N_Derived_Type_Definition |
612 N_Digits_Constraint |
613 N_Discriminant_Association |
614 N_Discriminant_Specification |
616 N_Entry_Call_Statement |
617 N_Enumeration_Type_Definition |
618 N_Exception_Handler |
619 N_Floating_Point_Definition |
620 N_Formal_Decimal_Fixed_Point_Definition |
621 N_Formal_Derived_Type_Definition |
622 N_Formal_Discrete_Type_Definition |
623 N_Formal_Floating_Point_Definition |
624 N_Formal_Modular_Type_Definition |
625 N_Formal_Ordinary_Fixed_Point_Definition |
626 N_Formal_Private_Type_Definition |
627 N_Formal_Signed_Integer_Type_Definition |
628 N_Function_Specification |
629 N_Generic_Association |
630 N_Index_Or_Discriminant_Constraint |
632 N_Loop_Parameter_Specification |
634 N_Modular_Type_Definition |
635 N_Ordinary_Fixed_Point_Definition |
636 N_Parameter_Specification |
637 N_Pragma_Argument_Association |
638 N_Procedure_Specification |
639 N_Real_Range_Specification |
640 N_Record_Definition |
641 N_Signed_Integer_Type_Definition |
642 N_Unconstrained_Array_Definition |
650 Debug_A_Exit ("analyzing ", N, " (done)");
652 -- Now that we have analyzed the node, we call the expander to perform
653 -- possible expansion. We skip this for subexpressions, because we don't
654 -- have the type yet, and the expander will need to know the type before
655 -- it can do its job. For subexpression nodes, the call to the expander
656 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
657 -- which can appear in a statement context, and needs expanding now in
658 -- the case (distinguished by Etype, as documented in Sinfo).
660 -- The Analyzed flag is also set at this point for non-subexpression
661 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
662 -- since resolution and expansion have not yet been completed). Note
663 -- that for N_Raise_xxx_Error we have to distinguish the expression
664 -- case from the statement case.
666 if Nkind (N) not in N_Subexpr
667 or else (Nkind (N) in N_Raise_xxx_Error
668 and then Etype (N) = Standard_Void_Type)
674 -- Version with check(s) suppressed
676 procedure Analyze (N : Node_Id; Suppress : Check_Id) is
678 if Suppress = All_Checks then
680 Svg : constant Suppress_Array := Scope_Suppress;
682 Scope_Suppress := (others => True);
684 Scope_Suppress := Svg;
689 Svg : constant Boolean := Scope_Suppress (Suppress);
691 Scope_Suppress (Suppress) := True;
693 Scope_Suppress (Suppress) := Svg;
702 procedure Analyze_List (L : List_Id) is
707 while Present (Node) loop
713 -- Version with check(s) suppressed
715 procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
717 if Suppress = All_Checks then
719 Svg : constant Suppress_Array := Scope_Suppress;
721 Scope_Suppress := (others => True);
723 Scope_Suppress := Svg;
728 Svg : constant Boolean := Scope_Suppress (Suppress);
730 Scope_Suppress (Suppress) := True;
732 Scope_Suppress (Suppress) := Svg;
737 --------------------------
738 -- Copy_Suppress_Status --
739 --------------------------
741 procedure Copy_Suppress_Status
747 pragma Warnings (Off, Found);
749 procedure Search_Stack
750 (Top : Suppress_Stack_Entry_Ptr;
751 Found : out Boolean);
752 -- Search given suppress stack for matching entry for entity. If found
753 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
754 -- entry for To onto the local suppress stack.
760 procedure Search_Stack
761 (Top : Suppress_Stack_Entry_Ptr;
764 Ptr : Suppress_Stack_Entry_Ptr;
768 while Ptr /= null loop
770 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
773 Set_Checks_May_Be_Suppressed (To, True);
774 Push_Local_Suppress_Stack_Entry
790 -- Start of processing for Copy_Suppress_Status
793 if not Checks_May_Be_Suppressed (From) then
797 -- First search the local entity suppress stack, we search this in
798 -- reverse order so that we get the innermost entry that applies to
799 -- this case if there are nested entries. Note that for the purpose
800 -- of this procedure we are ONLY looking for entries corresponding
801 -- to a two-argument Suppress, where the second argument matches From.
803 Search_Stack (Global_Suppress_Stack_Top, Found);
809 -- Now search the global entity suppress table for a matching entry
810 -- We also search this in reverse order so that if there are multiple
811 -- pragmas for the same entity, the last one applies.
813 Search_Stack (Local_Suppress_Stack_Top, Found);
814 end Copy_Suppress_Status;
816 -------------------------
817 -- Enter_Generic_Scope --
818 -------------------------
820 procedure Enter_Generic_Scope (S : Entity_Id) is
822 if No (Outer_Generic_Scope) then
823 Outer_Generic_Scope := S;
825 end Enter_Generic_Scope;
827 ------------------------
828 -- Exit_Generic_Scope --
829 ------------------------
831 procedure Exit_Generic_Scope (S : Entity_Id) is
833 if S = Outer_Generic_Scope then
834 Outer_Generic_Scope := Empty;
836 end Exit_Generic_Scope;
838 -----------------------
839 -- Explicit_Suppress --
840 -----------------------
842 function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
843 Ptr : Suppress_Stack_Entry_Ptr;
846 if not Checks_May_Be_Suppressed (E) then
850 Ptr := Global_Suppress_Stack_Top;
851 while Ptr /= null loop
853 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
863 end Explicit_Suppress;
865 -----------------------------
866 -- External_Ref_In_Generic --
867 -----------------------------
869 function External_Ref_In_Generic (E : Entity_Id) return Boolean is
873 -- Entity is global if defined outside of current outer_generic_scope:
874 -- Either the entity has a smaller depth that the outer generic, or it
875 -- is in a different compilation unit, or it is defined within a unit
876 -- in the same compilation, that is not within the outer_generic.
878 if No (Outer_Generic_Scope) then
881 elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
882 or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
889 while Present (Scop) loop
890 if Scop = Outer_Generic_Scope then
892 elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
895 Scop := Scope (Scop);
901 end External_Ref_In_Generic;
907 procedure Initialize is
908 Next : Suppress_Stack_Entry_Ptr;
910 procedure Free is new Unchecked_Deallocation
911 (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
914 -- Free any global suppress stack entries from a previous invocation
915 -- of the compiler (in the normal case this loop does nothing).
917 while Suppress_Stack_Entries /= null loop
918 Next := Global_Suppress_Stack_Top.Next;
919 Free (Suppress_Stack_Entries);
920 Suppress_Stack_Entries := Next;
923 Local_Suppress_Stack_Top := null;
924 Global_Suppress_Stack_Top := null;
926 -- Clear scope stack, and reset global variables
929 Unloaded_Subunits := False;
932 ------------------------------
933 -- Insert_After_And_Analyze --
934 ------------------------------
936 procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
942 -- If we are not at the end of the list, then the easiest
943 -- coding is simply to insert before our successor
945 if Present (Next (N)) then
946 Insert_Before_And_Analyze (Next (N), M);
948 -- Case of inserting at the end of the list
951 -- Capture the Node_Id of the node to be inserted. This Node_Id
952 -- will still be the same after the insert operation.
957 -- Now just analyze from the inserted node to the end of
958 -- the new list (note that this properly handles the case
959 -- where any of the analyze calls result in the insertion of
960 -- nodes after the analyzed node, expecting analysis).
962 while Present (Node) loop
964 Mark_Rewrite_Insertion (Node);
969 end Insert_After_And_Analyze;
971 -- Version with check(s) suppressed
973 procedure Insert_After_And_Analyze
979 if Suppress = All_Checks then
981 Svg : constant Suppress_Array := Scope_Suppress;
983 Scope_Suppress := (others => True);
984 Insert_After_And_Analyze (N, M);
985 Scope_Suppress := Svg;
990 Svg : constant Boolean := Scope_Suppress (Suppress);
992 Scope_Suppress (Suppress) := True;
993 Insert_After_And_Analyze (N, M);
994 Scope_Suppress (Suppress) := Svg;
997 end Insert_After_And_Analyze;
999 -------------------------------
1000 -- Insert_Before_And_Analyze --
1001 -------------------------------
1003 procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
1009 -- Capture the Node_Id of the first list node to be inserted.
1010 -- This will still be the first node after the insert operation,
1011 -- since Insert_List_After does not modify the Node_Id values.
1014 Insert_Before (N, M);
1016 -- The insertion does not change the Id's of any of the nodes in
1017 -- the list, and they are still linked, so we can simply loop from
1018 -- the original first node until we meet the node before which the
1019 -- insertion is occurring. Note that this properly handles the case
1020 -- where any of the analyzed nodes insert nodes after themselves,
1021 -- expecting them to get analyzed.
1023 while Node /= N loop
1025 Mark_Rewrite_Insertion (Node);
1029 end Insert_Before_And_Analyze;
1031 -- Version with check(s) suppressed
1033 procedure Insert_Before_And_Analyze
1036 Suppress : Check_Id)
1039 if Suppress = All_Checks then
1041 Svg : constant Suppress_Array := Scope_Suppress;
1043 Scope_Suppress := (others => True);
1044 Insert_Before_And_Analyze (N, M);
1045 Scope_Suppress := Svg;
1050 Svg : constant Boolean := Scope_Suppress (Suppress);
1052 Scope_Suppress (Suppress) := True;
1053 Insert_Before_And_Analyze (N, M);
1054 Scope_Suppress (Suppress) := Svg;
1057 end Insert_Before_And_Analyze;
1059 -----------------------------------
1060 -- Insert_List_After_And_Analyze --
1061 -----------------------------------
1063 procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
1064 After : constant Node_Id := Next (N);
1068 if Is_Non_Empty_List (L) then
1070 -- Capture the Node_Id of the first list node to be inserted.
1071 -- This will still be the first node after the insert operation,
1072 -- since Insert_List_After does not modify the Node_Id values.
1075 Insert_List_After (N, L);
1077 -- Now just analyze from the original first node until we get to
1078 -- the successor of the original insertion point (which may be
1079 -- Empty if the insertion point was at the end of the list). Note
1080 -- that this properly handles the case where any of the analyze
1081 -- calls result in the insertion of nodes after the analyzed
1082 -- node (possibly calling this routine recursively).
1084 while Node /= After loop
1086 Mark_Rewrite_Insertion (Node);
1090 end Insert_List_After_And_Analyze;
1092 -- Version with check(s) suppressed
1094 procedure Insert_List_After_And_Analyze
1095 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1098 if Suppress = All_Checks then
1100 Svg : constant Suppress_Array := Scope_Suppress;
1102 Scope_Suppress := (others => True);
1103 Insert_List_After_And_Analyze (N, L);
1104 Scope_Suppress := Svg;
1109 Svg : constant Boolean := Scope_Suppress (Suppress);
1111 Scope_Suppress (Suppress) := True;
1112 Insert_List_After_And_Analyze (N, L);
1113 Scope_Suppress (Suppress) := Svg;
1116 end Insert_List_After_And_Analyze;
1118 ------------------------------------
1119 -- Insert_List_Before_And_Analyze --
1120 ------------------------------------
1122 procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
1126 if Is_Non_Empty_List (L) then
1128 -- Capture the Node_Id of the first list node to be inserted.
1129 -- This will still be the first node after the insert operation,
1130 -- since Insert_List_After does not modify the Node_Id values.
1133 Insert_List_Before (N, L);
1135 -- The insertion does not change the Id's of any of the nodes in
1136 -- the list, and they are still linked, so we can simply loop from
1137 -- the original first node until we meet the node before which the
1138 -- insertion is occurring. Note that this properly handles the case
1139 -- where any of the analyzed nodes insert nodes after themselves,
1140 -- expecting them to get analyzed.
1142 while Node /= N loop
1144 Mark_Rewrite_Insertion (Node);
1148 end Insert_List_Before_And_Analyze;
1150 -- Version with check(s) suppressed
1152 procedure Insert_List_Before_And_Analyze
1153 (N : Node_Id; L : List_Id; Suppress : Check_Id)
1156 if Suppress = All_Checks then
1158 Svg : constant Suppress_Array := Scope_Suppress;
1160 Scope_Suppress := (others => True);
1161 Insert_List_Before_And_Analyze (N, L);
1162 Scope_Suppress := Svg;
1167 Svg : constant Boolean := Scope_Suppress (Suppress);
1169 Scope_Suppress (Suppress) := True;
1170 Insert_List_Before_And_Analyze (N, L);
1171 Scope_Suppress (Suppress) := Svg;
1174 end Insert_List_Before_And_Analyze;
1176 -------------------------
1177 -- Is_Check_Suppressed --
1178 -------------------------
1180 function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
1182 Ptr : Suppress_Stack_Entry_Ptr;
1185 -- First search the local entity suppress stack, we search this from the
1186 -- top of the stack down, so that we get the innermost entry that
1187 -- applies to this case if there are nested entries.
1189 Ptr := Local_Suppress_Stack_Top;
1190 while Ptr /= null loop
1191 if (Ptr.Entity = Empty or else Ptr.Entity = E)
1192 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1194 return Ptr.Suppress;
1200 -- Now search the global entity suppress table for a matching entry
1201 -- We also search this from the top down so that if there are multiple
1202 -- pragmas for the same entity, the last one applies (not clear what
1203 -- or whether the RM specifies this handling, but it seems reasonable).
1205 Ptr := Global_Suppress_Stack_Top;
1206 while Ptr /= null loop
1207 if (Ptr.Entity = Empty or else Ptr.Entity = E)
1208 and then (Ptr.Check = All_Checks or else Ptr.Check = C)
1210 return Ptr.Suppress;
1216 -- If we did not find a matching entry, then use the normal scope
1217 -- suppress value after all (actually this will be the global setting
1218 -- since it clearly was not overridden at any point). For a predefined
1219 -- check, we test the specific flag. For a user defined check, we check
1220 -- the All_Checks flag.
1222 if C in Predefined_Check_Id then
1223 return Scope_Suppress (C);
1225 return Scope_Suppress (All_Checks);
1227 end Is_Check_Suppressed;
1235 Scope_Stack.Locked := True;
1236 Scope_Stack.Release;
1239 --------------------------------------
1240 -- Push_Global_Suppress_Stack_Entry --
1241 --------------------------------------
1243 procedure Push_Global_Suppress_Stack_Entry
1244 (Entity : Entity_Id;
1249 Global_Suppress_Stack_Top :=
1250 new Suppress_Stack_Entry'
1253 Suppress => Suppress,
1254 Prev => Global_Suppress_Stack_Top,
1255 Next => Suppress_Stack_Entries);
1256 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1259 end Push_Global_Suppress_Stack_Entry;
1261 -------------------------------------
1262 -- Push_Local_Suppress_Stack_Entry --
1263 -------------------------------------
1265 procedure Push_Local_Suppress_Stack_Entry
1266 (Entity : Entity_Id;
1271 Local_Suppress_Stack_Top :=
1272 new Suppress_Stack_Entry'
1275 Suppress => Suppress,
1276 Prev => Local_Suppress_Stack_Top,
1277 Next => Suppress_Stack_Entries);
1278 Suppress_Stack_Entries := Local_Suppress_Stack_Top;
1281 end Push_Local_Suppress_Stack_Entry;
1287 procedure Semantics (Comp_Unit : Node_Id) is
1289 -- The following locations save the corresponding global flags and
1290 -- variables so that they can be restored on completion. This is
1291 -- needed so that calls to Rtsfind start with the proper default
1292 -- values for these variables, and also that such calls do not
1293 -- disturb the settings for units being analyzed at a higher level.
1295 S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
1296 S_Full_Analysis : constant Boolean := Full_Analysis;
1297 S_GNAT_Mode : constant Boolean := GNAT_Mode;
1298 S_Global_Dis_Names : constant Boolean := Global_Discard_Names;
1299 S_In_Spec_Expr : constant Boolean := In_Spec_Expression;
1300 S_Inside_A_Generic : constant Boolean := Inside_A_Generic;
1301 S_New_Nodes_OK : constant Int := New_Nodes_OK;
1302 S_Outer_Gen_Scope : constant Entity_Id := Outer_Generic_Scope;
1304 Generic_Main : constant Boolean :=
1305 Nkind (Unit (Cunit (Main_Unit)))
1306 in N_Generic_Declaration;
1307 -- If the main unit is generic, every compiled unit, including its
1308 -- context, is compiled with expansion disabled.
1310 Save_Config_Switches : Config_Switches_Type;
1311 -- Variable used to save values of config switches while we analyze
1312 -- the new unit, to be restored on exit for proper recursive behavior.
1314 procedure Do_Analyze;
1315 -- Procedure to analyze the compilation unit. This is called more
1316 -- than once when the high level optimizer is activated.
1322 procedure Do_Analyze is
1325 Push_Scope (Standard_Standard);
1326 Scope_Suppress := Suppress_Options;
1328 (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
1330 (Scope_Stack.Last).Is_Active_Stack_Base := True;
1331 Outer_Generic_Scope := Empty;
1333 -- Now analyze the top level compilation unit node
1335 Analyze (Comp_Unit);
1337 -- Check for scope mismatch on exit from compilation
1339 pragma Assert (Current_Scope = Standard_Standard
1340 or else Comp_Unit = Cunit (Main_Unit));
1342 -- Then pop entry for Standard, and pop implicit types
1345 Restore_Scope_Stack;
1348 -- Start of processing for Semantics
1351 Compiler_State := Analyzing;
1352 Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
1354 -- Compile predefined units with GNAT_Mode set to True, to properly
1355 -- process the categorization stuff. However, do not set GNAT_Mode
1356 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1357 -- Sequential_IO) as this would prevent pragma Extend_System from being
1358 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1360 -- Cleaner might be to do the kludge at the point of excluding the
1361 -- pragma (do not exclude for renamings ???)
1365 or else Is_Predefined_File_Name
1366 (Unit_File_Name (Current_Sem_Unit),
1367 Renamings_Included => False);
1369 if Generic_Main then
1370 Expander_Mode_Save_And_Set (False);
1372 Expander_Mode_Save_And_Set
1373 (Operating_Mode = Generate_Code or Debug_Flag_X);
1376 Full_Analysis := True;
1377 Inside_A_Generic := False;
1378 In_Spec_Expression := False;
1380 Set_Comes_From_Source_Default (False);
1381 Save_Opt_Config_Switches (Save_Config_Switches);
1382 Set_Opt_Config_Switches
1383 (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
1384 Current_Sem_Unit = Main_Unit);
1386 -- Only do analysis of unit that has not already been analyzed
1388 if not Analyzed (Comp_Unit) then
1389 Initialize_Version (Current_Sem_Unit);
1391 Expander_Mode_Save_And_Set (False);
1394 Reset_Analyzed_Flags (Comp_Unit);
1395 Expander_Mode_Restore;
1396 High_Level_Optimize (Comp_Unit);
1400 -- Do analysis, and then append the compilation unit onto the
1401 -- Comp_Unit_List, if appropriate. This is done after analysis, so if
1402 -- this unit depends on some others, they have already been
1403 -- appended. We ignore bodies, except for the main unit itself, and
1404 -- everything those bodies depend upon.
1406 if Ignore_Comp_Units then
1408 pragma Assert (Ignore_Comp_Units); -- still
1410 elsif Nkind (Unit (Comp_Unit)) in N_Proper_Body
1411 and then not In_Extended_Main_Source_Unit (Comp_Unit)
1413 Ignore_Comp_Units := True;
1415 pragma Assert (Ignore_Comp_Units);
1416 Ignore_Comp_Units := False;
1420 -- pragma Assert (not Ignore_Comp_Units);
1421 -- The above assertion is *almost* true. It fails only when a
1422 -- subunit with's its parent procedure body, which has no explicit
1425 if No (Comp_Unit_List) then -- Initialize if first time
1426 Comp_Unit_List := New_Elmt_List;
1428 if not Ignore_Comp_Units then -- See above commented-out Assert
1429 Append_Elmt (Comp_Unit, Comp_Unit_List);
1432 -- Ignore all units after main unit
1434 if Comp_Unit = Cunit (Main_Unit) then
1435 Ignore_Comp_Units := True;
1440 -- Save indication of dynamic elaboration checks for ALI file
1442 Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
1444 -- Restore settings of saved switches to entry values
1446 Current_Sem_Unit := S_Current_Sem_Unit;
1447 Full_Analysis := S_Full_Analysis;
1448 Global_Discard_Names := S_Global_Dis_Names;
1449 GNAT_Mode := S_GNAT_Mode;
1450 In_Spec_Expression := S_In_Spec_Expr;
1451 Inside_A_Generic := S_Inside_A_Generic;
1452 New_Nodes_OK := S_New_Nodes_OK;
1453 Outer_Generic_Scope := S_Outer_Gen_Scope;
1455 Restore_Opt_Config_Switches (Save_Config_Switches);
1456 Expander_Mode_Restore;
1459 ------------------------
1460 -- Walk_Library_Items --
1461 ------------------------
1463 procedure Walk_Library_Items is
1464 Enable_Output : constant Boolean := False;
1465 -- Set to True to print out the items as we go (for debugging)
1467 procedure Do_Action (CU : Node_Id; Item : Node_Id);
1468 -- Calls Action, with some validity checks
1474 procedure Do_Action (CU : Node_Id; Item : Node_Id) is
1476 -- This calls Action at the end. All the preceding code is just
1477 -- assertions and debugging output.
1479 case Nkind (Item) is
1480 when N_Generic_Subprogram_Declaration |
1481 N_Generic_Package_Declaration |
1482 N_Package_Declaration |
1483 N_Subprogram_Declaration |
1484 N_Subprogram_Renaming_Declaration |
1485 N_Package_Renaming_Declaration |
1486 N_Generic_Function_Renaming_Declaration |
1487 N_Generic_Package_Renaming_Declaration |
1488 N_Generic_Procedure_Renaming_Declaration =>
1489 null; -- Specs are OK
1491 when N_Package_Body | N_Subprogram_Body =>
1492 -- A body must be the main unit
1494 pragma Assert (CU = Cunit (Main_Unit));
1497 -- All other cases cannot happen
1499 when N_Function_Instantiation |
1500 N_Procedure_Instantiation |
1501 N_Package_Instantiation =>
1502 pragma Assert (False, "instantiation");
1506 pragma Assert (False, "subunit");
1510 pragma Assert (False);
1514 if Present (CU) then
1515 pragma Assert (Item /= Stand.Standard_Package_Node);
1517 if Enable_Output then
1518 Write_Unit_Name (Unit_Name (Get_Cunit_Unit_Number (CU)));
1519 Write_Str (", Unit_Number = ");
1520 Write_Int (Int (Get_Cunit_Unit_Number (CU)));
1522 Write_Str (Node_Kind'Image (Nkind (Item)));
1524 if Item /= Original_Node (Item) then
1525 Write_Str (", orig = ");
1526 Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
1535 pragma Assert (Item = Stand.Standard_Package_Node);
1537 if Enable_Output then
1538 Write_Line ("Standard");
1545 -- Local Declarations
1547 Cur : Elmt_Id := First_Elmt (Comp_Unit_List);
1549 -- Start of processing for Walk_Library_Items
1552 if Enable_Output then
1553 Write_Line ("Walk_Library_Items:");
1557 -- Do Standard first, then walk the Comp_Unit_List
1559 Do_Action (Empty, Standard_Package_Node);
1561 while Present (Cur) loop
1563 CU : constant Node_Id := Node (Cur);
1564 N : constant Node_Id := Unit (CU);
1567 pragma Assert (Nkind (CU) = N_Compilation_Unit);
1571 -- If it's a body, then ignore it, unless it's an instance (in
1572 -- which case we do the spec), or it's the main unit (in which
1573 -- case we do it). Note that it could be both.
1575 when N_Package_Body | N_Subprogram_Body =>
1577 Entity : Node_Id := N;
1580 if Nkind (N) = N_Subprogram_Body then
1581 Entity := Specification (Entity);
1584 Entity := Defining_Unit_Name (Entity);
1586 if Nkind (Entity) not in N_Entity then
1588 -- Must be N_Defining_Program_Unit_Name
1590 Entity := Defining_Identifier (Entity);
1593 if Is_Generic_Instance (Entity) then
1594 Do_Action (CU, Unit (Library_Unit (CU)));
1598 if CU = Cunit (Main_Unit) then
1602 pragma Assert (No (Next_Elmt (Cur)));
1607 -- It's a spec, so just do it
1617 if Enable_Output then
1619 Write_Line ("end Walk_Library_Items.");
1621 end Walk_Library_Items;