1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
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 Errout
; use Errout
;
31 with Expander
; use Expander
;
32 with Fname
; use Fname
;
35 with Lib
.Load
; use Lib
.Load
;
36 with Nlists
; use Nlists
;
37 with Sem_Attr
; use Sem_Attr
;
38 with Sem_Ch2
; use Sem_Ch2
;
39 with Sem_Ch3
; use Sem_Ch3
;
40 with Sem_Ch4
; use Sem_Ch4
;
41 with Sem_Ch5
; use Sem_Ch5
;
42 with Sem_Ch6
; use Sem_Ch6
;
43 with Sem_Ch7
; use Sem_Ch7
;
44 with Sem_Ch8
; use Sem_Ch8
;
45 with Sem_Ch9
; use Sem_Ch9
;
46 with Sem_Ch10
; use Sem_Ch10
;
47 with Sem_Ch11
; use Sem_Ch11
;
48 with Sem_Ch12
; use Sem_Ch12
;
49 with Sem_Ch13
; use Sem_Ch13
;
50 with Sem_Prag
; use Sem_Prag
;
51 with Sem_Util
; use Sem_Util
;
52 with Sinfo
; use Sinfo
;
53 with Stand
; use Stand
;
54 with Uintp
; use Uintp
;
56 with Unchecked_Deallocation
;
58 pragma Warnings
(Off
, Sem_Util
);
59 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
63 Outer_Generic_Scope
: Entity_Id
:= Empty
;
64 -- Global reference to the outer scope that is generic. In a non
65 -- generic context, it is empty. At the moment, it is only used
66 -- for avoiding freezing of external references in generics.
72 procedure Analyze
(N
: Node_Id
) is
74 Debug_A_Entry
("analyzing ", N
);
76 -- Immediate return if already analyzed
79 Debug_A_Exit
("analyzing ", N
, " (done, analyzed already)");
83 -- Otherwise processing depends on the node kind
87 when N_Abort_Statement
=>
88 Analyze_Abort_Statement
(N
);
90 when N_Abstract_Subprogram_Declaration
=>
91 Analyze_Abstract_Subprogram_Declaration
(N
);
93 when N_Accept_Alternative
=>
94 Analyze_Accept_Alternative
(N
);
96 when N_Accept_Statement
=>
97 Analyze_Accept_Statement
(N
);
100 Analyze_Aggregate
(N
);
103 Analyze_Allocator
(N
);
106 Analyze_Short_Circuit
(N
);
108 when N_Assignment_Statement
=>
109 Analyze_Assignment
(N
);
111 when N_Asynchronous_Select
=>
112 Analyze_Asynchronous_Select
(N
);
115 Analyze_At_Clause
(N
);
117 when N_Attribute_Reference
=>
118 Analyze_Attribute
(N
);
120 when N_Attribute_Definition_Clause
=>
121 Analyze_Attribute_Definition_Clause
(N
);
123 when N_Block_Statement
=>
124 Analyze_Block_Statement
(N
);
126 when N_Case_Statement
=>
127 Analyze_Case_Statement
(N
);
129 when N_Character_Literal
=>
130 Analyze_Character_Literal
(N
);
132 when N_Code_Statement
=>
133 Analyze_Code_Statement
(N
);
135 when N_Compilation_Unit
=>
136 Analyze_Compilation_Unit
(N
);
138 when N_Component_Declaration
=>
139 Analyze_Component_Declaration
(N
);
141 when N_Conditional_Expression
=>
142 Analyze_Conditional_Expression
(N
);
144 when N_Conditional_Entry_Call
=>
145 Analyze_Conditional_Entry_Call
(N
);
147 when N_Delay_Alternative
=>
148 Analyze_Delay_Alternative
(N
);
150 when N_Delay_Relative_Statement
=>
151 Analyze_Delay_Relative
(N
);
153 when N_Delay_Until_Statement
=>
154 Analyze_Delay_Until
(N
);
157 Analyze_Entry_Body
(N
);
159 when N_Entry_Body_Formal_Part
=>
160 Analyze_Entry_Body_Formal_Part
(N
);
162 when N_Entry_Call_Alternative
=>
163 Analyze_Entry_Call_Alternative
(N
);
165 when N_Entry_Declaration
=>
166 Analyze_Entry_Declaration
(N
);
168 when N_Entry_Index_Specification
=>
169 Analyze_Entry_Index_Specification
(N
);
171 when N_Enumeration_Representation_Clause
=>
172 Analyze_Enumeration_Representation_Clause
(N
);
174 when N_Exception_Declaration
=>
175 Analyze_Exception_Declaration
(N
);
177 when N_Exception_Renaming_Declaration
=>
178 Analyze_Exception_Renaming
(N
);
180 when N_Exit_Statement
=>
181 Analyze_Exit_Statement
(N
);
183 when N_Expanded_Name
=>
184 Analyze_Expanded_Name
(N
);
186 when N_Explicit_Dereference
=>
187 Analyze_Explicit_Dereference
(N
);
189 when N_Extended_Return_Statement
=>
190 Analyze_Extended_Return_Statement
(N
);
192 when N_Extension_Aggregate
=>
193 Analyze_Aggregate
(N
);
195 when N_Formal_Object_Declaration
=>
196 Analyze_Formal_Object_Declaration
(N
);
198 when N_Formal_Package_Declaration
=>
199 Analyze_Formal_Package
(N
);
201 when N_Formal_Subprogram_Declaration
=>
202 Analyze_Formal_Subprogram
(N
);
204 when N_Formal_Type_Declaration
=>
205 Analyze_Formal_Type_Declaration
(N
);
207 when N_Free_Statement
=>
208 Analyze_Free_Statement
(N
);
210 when N_Freeze_Entity
=>
211 null; -- no semantic processing required
213 when N_Full_Type_Declaration
=>
214 Analyze_Type_Declaration
(N
);
216 when N_Function_Call
=>
217 Analyze_Function_Call
(N
);
219 when N_Function_Instantiation
=>
220 Analyze_Function_Instantiation
(N
);
222 when N_Generic_Function_Renaming_Declaration
=>
223 Analyze_Generic_Function_Renaming
(N
);
225 when N_Generic_Package_Declaration
=>
226 Analyze_Generic_Package_Declaration
(N
);
228 when N_Generic_Package_Renaming_Declaration
=>
229 Analyze_Generic_Package_Renaming
(N
);
231 when N_Generic_Procedure_Renaming_Declaration
=>
232 Analyze_Generic_Procedure_Renaming
(N
);
234 when N_Generic_Subprogram_Declaration
=>
235 Analyze_Generic_Subprogram_Declaration
(N
);
237 when N_Goto_Statement
=>
238 Analyze_Goto_Statement
(N
);
240 when N_Handled_Sequence_Of_Statements
=>
241 Analyze_Handled_Statements
(N
);
244 Analyze_Identifier
(N
);
246 when N_If_Statement
=>
247 Analyze_If_Statement
(N
);
249 when N_Implicit_Label_Declaration
=>
250 Analyze_Implicit_Label_Declaration
(N
);
253 Analyze_Membership_Op
(N
);
255 when N_Incomplete_Type_Declaration
=>
256 Analyze_Incomplete_Type_Decl
(N
);
258 when N_Indexed_Component
=>
259 Analyze_Indexed_Component_Form
(N
);
261 when N_Integer_Literal
=>
262 Analyze_Integer_Literal
(N
);
264 when N_Itype_Reference
=>
265 Analyze_Itype_Reference
(N
);
270 when N_Loop_Statement
=>
271 Analyze_Loop_Statement
(N
);
274 Analyze_Membership_Op
(N
);
279 when N_Null_Statement
=>
280 Analyze_Null_Statement
(N
);
282 when N_Number_Declaration
=>
283 Analyze_Number_Declaration
(N
);
285 when N_Object_Declaration
=>
286 Analyze_Object_Declaration
(N
);
288 when N_Object_Renaming_Declaration
=>
289 Analyze_Object_Renaming
(N
);
291 when N_Operator_Symbol
=>
292 Analyze_Operator_Symbol
(N
);
295 Analyze_Unary_Op
(N
);
298 Analyze_Arithmetic_Op
(N
);
301 Analyze_Logical_Op
(N
);
304 Analyze_Concatenation
(N
);
307 Analyze_Arithmetic_Op
(N
);
310 Analyze_Equality_Op
(N
);
313 Analyze_Arithmetic_Op
(N
);
316 Analyze_Comparison_Op
(N
);
319 Analyze_Comparison_Op
(N
);
322 Analyze_Comparison_Op
(N
);
325 Analyze_Comparison_Op
(N
);
328 Analyze_Unary_Op
(N
);
331 Analyze_Arithmetic_Op
(N
);
333 when N_Op_Multiply
=>
334 Analyze_Arithmetic_Op
(N
);
337 Analyze_Equality_Op
(N
);
340 Analyze_Negation
(N
);
343 Analyze_Logical_Op
(N
);
346 Analyze_Unary_Op
(N
);
349 Analyze_Arithmetic_Op
(N
);
351 when N_Op_Rotate_Left
=>
352 Analyze_Arithmetic_Op
(N
);
354 when N_Op_Rotate_Right
=>
355 Analyze_Arithmetic_Op
(N
);
357 when N_Op_Shift_Left
=>
358 Analyze_Arithmetic_Op
(N
);
360 when N_Op_Shift_Right
=>
361 Analyze_Arithmetic_Op
(N
);
363 when N_Op_Shift_Right_Arithmetic
=>
364 Analyze_Arithmetic_Op
(N
);
366 when N_Op_Subtract
=>
367 Analyze_Arithmetic_Op
(N
);
370 Analyze_Logical_Op
(N
);
373 Analyze_Short_Circuit
(N
);
375 when N_Others_Choice
=>
376 Analyze_Others_Choice
(N
);
378 when N_Package_Body
=>
379 Analyze_Package_Body
(N
);
381 when N_Package_Body_Stub
=>
382 Analyze_Package_Body_Stub
(N
);
384 when N_Package_Declaration
=>
385 Analyze_Package_Declaration
(N
);
387 when N_Package_Instantiation
=>
388 Analyze_Package_Instantiation
(N
);
390 when N_Package_Renaming_Declaration
=>
391 Analyze_Package_Renaming
(N
);
393 when N_Package_Specification
=>
394 Analyze_Package_Specification
(N
);
396 when N_Parameter_Association
=>
397 Analyze_Parameter_Association
(N
);
402 when N_Private_Extension_Declaration
=>
403 Analyze_Private_Extension_Declaration
(N
);
405 when N_Private_Type_Declaration
=>
406 Analyze_Private_Type_Declaration
(N
);
408 when N_Procedure_Call_Statement
=>
409 Analyze_Procedure_Call
(N
);
411 when N_Procedure_Instantiation
=>
412 Analyze_Procedure_Instantiation
(N
);
414 when N_Protected_Body
=>
415 Analyze_Protected_Body
(N
);
417 when N_Protected_Body_Stub
=>
418 Analyze_Protected_Body_Stub
(N
);
420 when N_Protected_Definition
=>
421 Analyze_Protected_Definition
(N
);
423 when N_Protected_Type_Declaration
=>
424 Analyze_Protected_Type
(N
);
426 when N_Qualified_Expression
=>
427 Analyze_Qualified_Expression
(N
);
429 when N_Raise_Statement
=>
430 Analyze_Raise_Statement
(N
);
432 when N_Raise_xxx_Error
=>
433 Analyze_Raise_xxx_Error
(N
);
438 when N_Range_Constraint
=>
439 Analyze_Range
(Range_Expression
(N
));
441 when N_Real_Literal
=>
442 Analyze_Real_Literal
(N
);
444 when N_Record_Representation_Clause
=>
445 Analyze_Record_Representation_Clause
(N
);
448 Analyze_Reference
(N
);
450 when N_Requeue_Statement
=>
453 when N_Simple_Return_Statement
=>
454 Analyze_Simple_Return_Statement
(N
);
456 when N_Selected_Component
=>
457 Find_Selected_Component
(N
);
458 -- ??? why not Analyze_Selected_Component, needs comments
460 when N_Selective_Accept
=>
461 Analyze_Selective_Accept
(N
);
463 when N_Single_Protected_Declaration
=>
464 Analyze_Single_Protected
(N
);
466 when N_Single_Task_Declaration
=>
467 Analyze_Single_Task
(N
);
472 when N_String_Literal
=>
473 Analyze_String_Literal
(N
);
475 when N_Subprogram_Body
=>
476 Analyze_Subprogram_Body
(N
);
478 when N_Subprogram_Body_Stub
=>
479 Analyze_Subprogram_Body_Stub
(N
);
481 when N_Subprogram_Declaration
=>
482 Analyze_Subprogram_Declaration
(N
);
484 when N_Subprogram_Info
=>
485 Analyze_Subprogram_Info
(N
);
487 when N_Subprogram_Renaming_Declaration
=>
488 Analyze_Subprogram_Renaming
(N
);
490 when N_Subtype_Declaration
=>
491 Analyze_Subtype_Declaration
(N
);
493 when N_Subtype_Indication
=>
494 Analyze_Subtype_Indication
(N
);
500 Analyze_Task_Body
(N
);
502 when N_Task_Body_Stub
=>
503 Analyze_Task_Body_Stub
(N
);
505 when N_Task_Definition
=>
506 Analyze_Task_Definition
(N
);
508 when N_Task_Type_Declaration
=>
509 Analyze_Task_Type
(N
);
511 when N_Terminate_Alternative
=>
512 Analyze_Terminate_Alternative
(N
);
514 when N_Timed_Entry_Call
=>
515 Analyze_Timed_Entry_Call
(N
);
517 when N_Triggering_Alternative
=>
518 Analyze_Triggering_Alternative
(N
);
520 when N_Type_Conversion
=>
521 Analyze_Type_Conversion
(N
);
523 when N_Unchecked_Expression
=>
524 Analyze_Unchecked_Expression
(N
);
526 when N_Unchecked_Type_Conversion
=>
527 Analyze_Unchecked_Type_Conversion
(N
);
529 when N_Use_Package_Clause
=>
530 Analyze_Use_Package
(N
);
532 when N_Use_Type_Clause
=>
533 Analyze_Use_Type
(N
);
535 when N_Validate_Unchecked_Conversion
=>
538 when N_Variant_Part
=>
539 Analyze_Variant_Part
(N
);
541 when N_With_Clause
=>
542 Analyze_With_Clause
(N
);
544 -- A call to analyze the Empty node is an error, but most likely
545 -- it is an error caused by an attempt to analyze a malformed
546 -- piece of tree caused by some other error, so if there have
547 -- been any other errors, we just ignore it, otherwise it is
548 -- a real internal error which we complain about.
550 -- We must also consider the case of call to a runtime function
551 -- that is not available in the configurable runtime.
554 pragma Assert
(Serious_Errors_Detected
/= 0
555 or else Configurable_Run_Time_Violations
/= 0);
558 -- A call to analyze the error node is simply ignored, to avoid
559 -- causing cascaded errors (happens of course only in error cases)
564 -- Push/Pop nodes normally don't come through an analyze call. An
565 -- exception is the dummy ones bracketing a subprogram body. In any
566 -- case there is nothing to be done to analyze such nodes.
568 when N_Push_Pop_xxx_Label
=>
571 -- For the remaining node types, we generate compiler abort, because
572 -- these nodes are always analyzed within the Sem_Chn routines and
573 -- there should never be a case of making a call to the main Analyze
574 -- routine for these node kinds. For example, an N_Access_Definition
575 -- node appears only in the context of a type declaration, and is
576 -- processed by the analyze routine for type declarations.
580 N_Access_Definition |
581 N_Access_Function_Definition |
582 N_Access_Procedure_Definition |
583 N_Access_To_Object_Definition |
584 N_Case_Statement_Alternative |
585 N_Compilation_Unit_Aux |
586 N_Component_Association |
588 N_Component_Definition |
590 N_Constrained_Array_Definition |
591 N_Decimal_Fixed_Point_Definition |
592 N_Defining_Character_Literal |
593 N_Defining_Identifier |
594 N_Defining_Operator_Symbol |
595 N_Defining_Program_Unit_Name |
597 N_Derived_Type_Definition |
599 N_Digits_Constraint |
600 N_Discriminant_Association |
601 N_Discriminant_Specification |
603 N_Entry_Call_Statement |
604 N_Enumeration_Type_Definition |
605 N_Exception_Handler |
606 N_Floating_Point_Definition |
607 N_Formal_Decimal_Fixed_Point_Definition |
608 N_Formal_Derived_Type_Definition |
609 N_Formal_Discrete_Type_Definition |
610 N_Formal_Floating_Point_Definition |
611 N_Formal_Modular_Type_Definition |
612 N_Formal_Ordinary_Fixed_Point_Definition |
613 N_Formal_Private_Type_Definition |
614 N_Formal_Signed_Integer_Type_Definition |
615 N_Function_Specification |
616 N_Generic_Association |
617 N_Index_Or_Discriminant_Constraint |
619 N_Loop_Parameter_Specification |
621 N_Modular_Type_Definition |
622 N_Ordinary_Fixed_Point_Definition |
623 N_Parameter_Specification |
624 N_Pragma_Argument_Association |
625 N_Procedure_Specification |
626 N_Real_Range_Specification |
627 N_Record_Definition |
628 N_Signed_Integer_Type_Definition |
629 N_Unconstrained_Array_Definition |
637 Debug_A_Exit
("analyzing ", N
, " (done)");
639 -- Now that we have analyzed the node, we call the expander to perform
640 -- possible expansion. We skip this for subexpressions, because we don't
641 -- have the type yet, and the expander will need to know the type before
642 -- it can do its job. For subexpression nodes, the call to the expander
643 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
644 -- which can appear in a statement context, and needs expanding now in
645 -- the case (distinguished by Etype, as documented in Sinfo).
647 -- The Analyzed flag is also set at this point for non-subexpression
648 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
649 -- since resolution and expansion have not yet been completed). Note
650 -- that for N_Raise_xxx_Error we have to distinguish the expression
651 -- case from the statement case.
653 if Nkind
(N
) not in N_Subexpr
654 or else (Nkind
(N
) in N_Raise_xxx_Error
655 and then Etype
(N
) = Standard_Void_Type
)
661 -- Version with check(s) suppressed
663 procedure Analyze
(N
: Node_Id
; Suppress
: Check_Id
) is
665 if Suppress
= All_Checks
then
667 Svg
: constant Suppress_Array
:= Scope_Suppress
;
669 Scope_Suppress
:= (others => True);
671 Scope_Suppress
:= Svg
;
676 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
678 Scope_Suppress
(Suppress
) := True;
680 Scope_Suppress
(Suppress
) := Svg
;
689 procedure Analyze_List
(L
: List_Id
) is
694 while Present
(Node
) loop
700 -- Version with check(s) suppressed
702 procedure Analyze_List
(L
: List_Id
; Suppress
: Check_Id
) is
704 if Suppress
= All_Checks
then
706 Svg
: constant Suppress_Array
:= Scope_Suppress
;
708 Scope_Suppress
:= (others => True);
710 Scope_Suppress
:= Svg
;
715 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
717 Scope_Suppress
(Suppress
) := True;
719 Scope_Suppress
(Suppress
) := Svg
;
724 --------------------------
725 -- Copy_Suppress_Status --
726 --------------------------
728 procedure Copy_Suppress_Status
734 pragma Warnings
(Off
, Found
);
736 procedure Search_Stack
737 (Top
: Suppress_Stack_Entry_Ptr
;
738 Found
: out Boolean);
739 -- Search given suppress stack for matching entry for entity. If found
740 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
741 -- entry for To onto the local suppress stack.
747 procedure Search_Stack
748 (Top
: Suppress_Stack_Entry_Ptr
;
751 Ptr
: Suppress_Stack_Entry_Ptr
;
755 while Ptr
/= null loop
757 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
760 Set_Checks_May_Be_Suppressed
(To
, True);
761 Push_Local_Suppress_Stack_Entry
777 -- Start of processing for Copy_Suppress_Status
780 if not Checks_May_Be_Suppressed
(From
) then
784 -- First search the local entity suppress stack, we search this in
785 -- reverse order so that we get the innermost entry that applies to
786 -- this case if there are nested entries. Note that for the purpose
787 -- of this procedure we are ONLY looking for entries corresponding
788 -- to a two-argument Suppress, where the second argument matches From.
790 Search_Stack
(Global_Suppress_Stack_Top
, Found
);
796 -- Now search the global entity suppress table for a matching entry
797 -- We also search this in reverse order so that if there are multiple
798 -- pragmas for the same entity, the last one applies.
800 Search_Stack
(Local_Suppress_Stack_Top
, Found
);
801 end Copy_Suppress_Status
;
803 -------------------------
804 -- Enter_Generic_Scope --
805 -------------------------
807 procedure Enter_Generic_Scope
(S
: Entity_Id
) is
809 if No
(Outer_Generic_Scope
) then
810 Outer_Generic_Scope
:= S
;
812 end Enter_Generic_Scope
;
814 ------------------------
815 -- Exit_Generic_Scope --
816 ------------------------
818 procedure Exit_Generic_Scope
(S
: Entity_Id
) is
820 if S
= Outer_Generic_Scope
then
821 Outer_Generic_Scope
:= Empty
;
823 end Exit_Generic_Scope
;
825 -----------------------
826 -- Explicit_Suppress --
827 -----------------------
829 function Explicit_Suppress
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
830 Ptr
: Suppress_Stack_Entry_Ptr
;
833 if not Checks_May_Be_Suppressed
(E
) then
837 Ptr
:= Global_Suppress_Stack_Top
;
838 while Ptr
/= null loop
840 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
850 end Explicit_Suppress
;
852 -----------------------------
853 -- External_Ref_In_Generic --
854 -----------------------------
856 function External_Ref_In_Generic
(E
: Entity_Id
) return Boolean is
860 -- Entity is global if defined outside of current outer_generic_scope:
861 -- Either the entity has a smaller depth that the outer generic, or it
862 -- is in a different compilation unit, or it is defined within a unit
863 -- in the same compilation, that is not within the outer_generic.
865 if No
(Outer_Generic_Scope
) then
868 elsif Scope_Depth
(Scope
(E
)) < Scope_Depth
(Outer_Generic_Scope
)
869 or else not In_Same_Source_Unit
(E
, Outer_Generic_Scope
)
876 while Present
(Scop
) loop
877 if Scop
= Outer_Generic_Scope
then
879 elsif Scope_Depth
(Scop
) < Scope_Depth
(Outer_Generic_Scope
) then
882 Scop
:= Scope
(Scop
);
888 end External_Ref_In_Generic
;
894 procedure Initialize
is
895 Next
: Suppress_Stack_Entry_Ptr
;
897 procedure Free
is new Unchecked_Deallocation
898 (Suppress_Stack_Entry
, Suppress_Stack_Entry_Ptr
);
901 -- Free any global suppress stack entries from a previous invocation
902 -- of the compiler (in the normal case this loop does nothing).
904 while Suppress_Stack_Entries
/= null loop
905 Next
:= Global_Suppress_Stack_Top
.Next
;
906 Free
(Suppress_Stack_Entries
);
907 Suppress_Stack_Entries
:= Next
;
910 Local_Suppress_Stack_Top
:= null;
911 Global_Suppress_Stack_Top
:= null;
913 -- Clear scope stack, and reset global variables
916 Unloaded_Subunits
:= False;
919 ------------------------------
920 -- Insert_After_And_Analyze --
921 ------------------------------
923 procedure Insert_After_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
929 -- If we are not at the end of the list, then the easiest
930 -- coding is simply to insert before our successor
932 if Present
(Next
(N
)) then
933 Insert_Before_And_Analyze
(Next
(N
), M
);
935 -- Case of inserting at the end of the list
938 -- Capture the Node_Id of the node to be inserted. This Node_Id
939 -- will still be the same after the insert operation.
944 -- Now just analyze from the inserted node to the end of
945 -- the new list (note that this properly handles the case
946 -- where any of the analyze calls result in the insertion of
947 -- nodes after the analyzed node, expecting analysis).
949 while Present
(Node
) loop
951 Mark_Rewrite_Insertion
(Node
);
956 end Insert_After_And_Analyze
;
958 -- Version with check(s) suppressed
960 procedure Insert_After_And_Analyze
966 if Suppress
= All_Checks
then
968 Svg
: constant Suppress_Array
:= Scope_Suppress
;
970 Scope_Suppress
:= (others => True);
971 Insert_After_And_Analyze
(N
, M
);
972 Scope_Suppress
:= Svg
;
977 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
979 Scope_Suppress
(Suppress
) := True;
980 Insert_After_And_Analyze
(N
, M
);
981 Scope_Suppress
(Suppress
) := Svg
;
984 end Insert_After_And_Analyze
;
986 -------------------------------
987 -- Insert_Before_And_Analyze --
988 -------------------------------
990 procedure Insert_Before_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
996 -- Capture the Node_Id of the first list node to be inserted.
997 -- This will still be the first node after the insert operation,
998 -- since Insert_List_After does not modify the Node_Id values.
1001 Insert_Before
(N
, M
);
1003 -- The insertion does not change the Id's of any of the nodes in
1004 -- the list, and they are still linked, so we can simply loop from
1005 -- the original first node until we meet the node before which the
1006 -- insertion is occurring. Note that this properly handles the case
1007 -- where any of the analyzed nodes insert nodes after themselves,
1008 -- expecting them to get analyzed.
1010 while Node
/= N
loop
1012 Mark_Rewrite_Insertion
(Node
);
1016 end Insert_Before_And_Analyze
;
1018 -- Version with check(s) suppressed
1020 procedure Insert_Before_And_Analyze
1023 Suppress
: Check_Id
)
1026 if Suppress
= All_Checks
then
1028 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1030 Scope_Suppress
:= (others => True);
1031 Insert_Before_And_Analyze
(N
, M
);
1032 Scope_Suppress
:= Svg
;
1037 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1039 Scope_Suppress
(Suppress
) := True;
1040 Insert_Before_And_Analyze
(N
, M
);
1041 Scope_Suppress
(Suppress
) := Svg
;
1044 end Insert_Before_And_Analyze
;
1046 -----------------------------------
1047 -- Insert_List_After_And_Analyze --
1048 -----------------------------------
1050 procedure Insert_List_After_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1051 After
: constant Node_Id
:= Next
(N
);
1055 if Is_Non_Empty_List
(L
) then
1057 -- Capture the Node_Id of the first list node to be inserted.
1058 -- This will still be the first node after the insert operation,
1059 -- since Insert_List_After does not modify the Node_Id values.
1062 Insert_List_After
(N
, L
);
1064 -- Now just analyze from the original first node until we get to
1065 -- the successor of the original insertion point (which may be
1066 -- Empty if the insertion point was at the end of the list). Note
1067 -- that this properly handles the case where any of the analyze
1068 -- calls result in the insertion of nodes after the analyzed
1069 -- node (possibly calling this routine recursively).
1071 while Node
/= After
loop
1073 Mark_Rewrite_Insertion
(Node
);
1077 end Insert_List_After_And_Analyze
;
1079 -- Version with check(s) suppressed
1081 procedure Insert_List_After_And_Analyze
1082 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1085 if Suppress
= All_Checks
then
1087 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1089 Scope_Suppress
:= (others => True);
1090 Insert_List_After_And_Analyze
(N
, L
);
1091 Scope_Suppress
:= Svg
;
1096 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1098 Scope_Suppress
(Suppress
) := True;
1099 Insert_List_After_And_Analyze
(N
, L
);
1100 Scope_Suppress
(Suppress
) := Svg
;
1103 end Insert_List_After_And_Analyze
;
1105 ------------------------------------
1106 -- Insert_List_Before_And_Analyze --
1107 ------------------------------------
1109 procedure Insert_List_Before_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1113 if Is_Non_Empty_List
(L
) then
1115 -- Capture the Node_Id of the first list node to be inserted.
1116 -- This will still be the first node after the insert operation,
1117 -- since Insert_List_After does not modify the Node_Id values.
1120 Insert_List_Before
(N
, L
);
1122 -- The insertion does not change the Id's of any of the nodes in
1123 -- the list, and they are still linked, so we can simply loop from
1124 -- the original first node until we meet the node before which the
1125 -- insertion is occurring. Note that this properly handles the case
1126 -- where any of the analyzed nodes insert nodes after themselves,
1127 -- expecting them to get analyzed.
1129 while Node
/= N
loop
1131 Mark_Rewrite_Insertion
(Node
);
1135 end Insert_List_Before_And_Analyze
;
1137 -- Version with check(s) suppressed
1139 procedure Insert_List_Before_And_Analyze
1140 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1143 if Suppress
= All_Checks
then
1145 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1147 Scope_Suppress
:= (others => True);
1148 Insert_List_Before_And_Analyze
(N
, L
);
1149 Scope_Suppress
:= Svg
;
1154 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1156 Scope_Suppress
(Suppress
) := True;
1157 Insert_List_Before_And_Analyze
(N
, L
);
1158 Scope_Suppress
(Suppress
) := Svg
;
1161 end Insert_List_Before_And_Analyze
;
1163 -------------------------
1164 -- Is_Check_Suppressed --
1165 -------------------------
1167 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
1169 Ptr
: Suppress_Stack_Entry_Ptr
;
1172 -- First search the local entity suppress stack, we search this from the
1173 -- top of the stack down, so that we get the innermost entry that
1174 -- applies to this case if there are nested entries.
1176 Ptr
:= Local_Suppress_Stack_Top
;
1177 while Ptr
/= null loop
1178 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
1179 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
1181 return Ptr
.Suppress
;
1187 -- Now search the global entity suppress table for a matching entry
1188 -- We also search this from the top down so that if there are multiple
1189 -- pragmas for the same entity, the last one applies (not clear what
1190 -- or whether the RM specifies this handling, but it seems reasonable).
1192 Ptr
:= Global_Suppress_Stack_Top
;
1193 while Ptr
/= null loop
1194 if (Ptr
.Entity
= Empty
or else Ptr
.Entity
= E
)
1195 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
1197 return Ptr
.Suppress
;
1203 -- If we did not find a matching entry, then use the normal scope
1204 -- suppress value after all (actually this will be the global setting
1205 -- since it clearly was not overridden at any point). For a predefined
1206 -- check, we test the specific flag. For a user defined check, we check
1207 -- the All_Checks flag.
1209 if C
in Predefined_Check_Id
then
1210 return Scope_Suppress
(C
);
1212 return Scope_Suppress
(All_Checks
);
1214 end Is_Check_Suppressed
;
1222 Scope_Stack
.Locked
:= True;
1223 Scope_Stack
.Release
;
1226 --------------------------------------
1227 -- Push_Global_Suppress_Stack_Entry --
1228 --------------------------------------
1230 procedure Push_Global_Suppress_Stack_Entry
1231 (Entity
: Entity_Id
;
1236 Global_Suppress_Stack_Top
:=
1237 new Suppress_Stack_Entry
'
1240 Suppress => Suppress,
1241 Prev => Global_Suppress_Stack_Top,
1242 Next => Suppress_Stack_Entries);
1243 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1246 end Push_Global_Suppress_Stack_Entry;
1248 -------------------------------------
1249 -- Push_Local_Suppress_Stack_Entry --
1250 -------------------------------------
1252 procedure Push_Local_Suppress_Stack_Entry
1253 (Entity : Entity_Id;
1258 Local_Suppress_Stack_Top :=
1259 new Suppress_Stack_Entry'
1262 Suppress
=> Suppress
,
1263 Prev
=> Local_Suppress_Stack_Top
,
1264 Next
=> Suppress_Stack_Entries
);
1265 Suppress_Stack_Entries
:= Local_Suppress_Stack_Top
;
1268 end Push_Local_Suppress_Stack_Entry
;
1274 procedure Semantics
(Comp_Unit
: Node_Id
) is
1276 -- The following locations save the corresponding global flags and
1277 -- variables so that they can be restored on completion. This is
1278 -- needed so that calls to Rtsfind start with the proper default
1279 -- values for these variables, and also that such calls do not
1280 -- disturb the settings for units being analyzed at a higher level.
1282 S_Current_Sem_Unit
: constant Unit_Number_Type
:= Current_Sem_Unit
;
1283 S_Full_Analysis
: constant Boolean := Full_Analysis
;
1284 S_GNAT_Mode
: constant Boolean := GNAT_Mode
;
1285 S_Global_Dis_Names
: constant Boolean := Global_Discard_Names
;
1286 S_In_Spec_Expr
: constant Boolean := In_Spec_Expression
;
1287 S_Inside_A_Generic
: constant Boolean := Inside_A_Generic
;
1288 S_New_Nodes_OK
: constant Int
:= New_Nodes_OK
;
1289 S_Outer_Gen_Scope
: constant Entity_Id
:= Outer_Generic_Scope
;
1291 Generic_Main
: constant Boolean :=
1292 Nkind
(Unit
(Cunit
(Main_Unit
)))
1293 in N_Generic_Declaration
;
1294 -- If the main unit is generic, every compiled unit, including its
1295 -- context, is compiled with expansion disabled.
1297 Save_Config_Switches
: Config_Switches_Type
;
1298 -- Variable used to save values of config switches while we analyze
1299 -- the new unit, to be restored on exit for proper recursive behavior.
1301 procedure Do_Analyze
;
1302 -- Procedure to analyze the compilation unit. This is called more
1303 -- than once when the high level optimizer is activated.
1309 procedure Do_Analyze
is
1312 Push_Scope
(Standard_Standard
);
1313 Scope_Suppress
:= Suppress_Options
;
1315 (Scope_Stack
.Last
).Component_Alignment_Default
:= Calign_Default
;
1317 (Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
1318 Outer_Generic_Scope
:= Empty
;
1320 -- Now analyze the top level compilation unit node
1322 Analyze
(Comp_Unit
);
1324 -- Check for scope mismatch on exit from compilation
1326 pragma Assert
(Current_Scope
= Standard_Standard
1327 or else Comp_Unit
= Cunit
(Main_Unit
));
1329 -- Then pop entry for Standard, and pop implicit types
1332 Restore_Scope_Stack
;
1335 -- Start of processing for Semantics
1338 Compiler_State
:= Analyzing
;
1339 Current_Sem_Unit
:= Get_Cunit_Unit_Number
(Comp_Unit
);
1341 -- Compile predefined units with GNAT_Mode set to True, to properly
1342 -- process the categorization stuff. However, do not set set GNAT_Mode
1343 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1344 -- Sequential_IO) as this would prevent pragma System_Extend to be
1345 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1347 -- Cleaner might be to do the kludge at the point of excluding the
1348 -- pragma (do not exclude for renamings ???)
1352 or else Is_Predefined_File_Name
1353 (Unit_File_Name
(Current_Sem_Unit
),
1354 Renamings_Included
=> False);
1356 if Generic_Main
then
1357 Expander_Mode_Save_And_Set
(False);
1359 Expander_Mode_Save_And_Set
1360 (Operating_Mode
= Generate_Code
or Debug_Flag_X
);
1363 Full_Analysis
:= True;
1364 Inside_A_Generic
:= False;
1365 In_Spec_Expression
:= False;
1367 Set_Comes_From_Source_Default
(False);
1368 Save_Opt_Config_Switches
(Save_Config_Switches
);
1369 Set_Opt_Config_Switches
1370 (Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
)),
1371 Current_Sem_Unit
= Main_Unit
);
1373 -- Only do analysis of unit that has not already been analyzed
1375 if not Analyzed
(Comp_Unit
) then
1376 Initialize_Version
(Current_Sem_Unit
);
1378 Expander_Mode_Save_And_Set
(False);
1381 Reset_Analyzed_Flags
(Comp_Unit
);
1382 Expander_Mode_Restore
;
1383 High_Level_Optimize
(Comp_Unit
);
1390 -- Save indication of dynamic elaboration checks for ALI file
1392 Set_Dynamic_Elab
(Current_Sem_Unit
, Dynamic_Elaboration_Checks
);
1394 -- Restore settings of saved switches to entry values
1396 Current_Sem_Unit
:= S_Current_Sem_Unit
;
1397 Full_Analysis
:= S_Full_Analysis
;
1398 Global_Discard_Names
:= S_Global_Dis_Names
;
1399 GNAT_Mode
:= S_GNAT_Mode
;
1400 In_Spec_Expression
:= S_In_Spec_Expr
;
1401 Inside_A_Generic
:= S_Inside_A_Generic
;
1402 New_Nodes_OK
:= S_New_Nodes_OK
;
1403 Outer_Generic_Scope
:= S_Outer_Gen_Scope
;
1405 Restore_Opt_Config_Switches
(Save_Config_Switches
);
1406 Expander_Mode_Restore
;