1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2006, 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 pragma Warnings
(Off
, Sem_Util
);
57 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
61 Outer_Generic_Scope
: Entity_Id
:= Empty
;
62 -- Global reference to the outer scope that is generic. In a non
63 -- generic context, it is empty. At the moment, it is only used
64 -- for avoiding freezing of external references in generics.
70 procedure Analyze
(N
: Node_Id
) is
72 Debug_A_Entry
("analyzing ", N
);
74 -- Immediate return if already analyzed
77 Debug_A_Exit
("analyzing ", N
, " (done, analyzed already)");
81 -- Otherwise processing depends on the node kind
85 when N_Abort_Statement
=>
86 Analyze_Abort_Statement
(N
);
88 when N_Abstract_Subprogram_Declaration
=>
89 Analyze_Abstract_Subprogram_Declaration
(N
);
91 when N_Accept_Alternative
=>
92 Analyze_Accept_Alternative
(N
);
94 when N_Accept_Statement
=>
95 Analyze_Accept_Statement
(N
);
98 Analyze_Aggregate
(N
);
101 Analyze_Allocator
(N
);
104 Analyze_Short_Circuit
(N
);
106 when N_Assignment_Statement
=>
107 Analyze_Assignment
(N
);
109 when N_Asynchronous_Select
=>
110 Analyze_Asynchronous_Select
(N
);
113 Analyze_At_Clause
(N
);
115 when N_Attribute_Reference
=>
116 Analyze_Attribute
(N
);
118 when N_Attribute_Definition_Clause
=>
119 Analyze_Attribute_Definition_Clause
(N
);
121 when N_Block_Statement
=>
122 Analyze_Block_Statement
(N
);
124 when N_Case_Statement
=>
125 Analyze_Case_Statement
(N
);
127 when N_Character_Literal
=>
128 Analyze_Character_Literal
(N
);
130 when N_Code_Statement
=>
131 Analyze_Code_Statement
(N
);
133 when N_Compilation_Unit
=>
134 Analyze_Compilation_Unit
(N
);
136 when N_Component_Declaration
=>
137 Analyze_Component_Declaration
(N
);
139 when N_Conditional_Expression
=>
140 Analyze_Conditional_Expression
(N
);
142 when N_Conditional_Entry_Call
=>
143 Analyze_Conditional_Entry_Call
(N
);
145 when N_Delay_Alternative
=>
146 Analyze_Delay_Alternative
(N
);
148 when N_Delay_Relative_Statement
=>
149 Analyze_Delay_Relative
(N
);
151 when N_Delay_Until_Statement
=>
152 Analyze_Delay_Until
(N
);
155 Analyze_Entry_Body
(N
);
157 when N_Entry_Body_Formal_Part
=>
158 Analyze_Entry_Body_Formal_Part
(N
);
160 when N_Entry_Call_Alternative
=>
161 Analyze_Entry_Call_Alternative
(N
);
163 when N_Entry_Declaration
=>
164 Analyze_Entry_Declaration
(N
);
166 when N_Entry_Index_Specification
=>
167 Analyze_Entry_Index_Specification
(N
);
169 when N_Enumeration_Representation_Clause
=>
170 Analyze_Enumeration_Representation_Clause
(N
);
172 when N_Exception_Declaration
=>
173 Analyze_Exception_Declaration
(N
);
175 when N_Exception_Renaming_Declaration
=>
176 Analyze_Exception_Renaming
(N
);
178 when N_Exit_Statement
=>
179 Analyze_Exit_Statement
(N
);
181 when N_Expanded_Name
=>
182 Analyze_Expanded_Name
(N
);
184 when N_Explicit_Dereference
=>
185 Analyze_Explicit_Dereference
(N
);
187 when N_Extended_Return_Statement
=>
188 Analyze_Extended_Return_Statement
(N
);
190 when N_Extension_Aggregate
=>
191 Analyze_Aggregate
(N
);
193 when N_Formal_Object_Declaration
=>
194 Analyze_Formal_Object_Declaration
(N
);
196 when N_Formal_Package_Declaration
=>
197 Analyze_Formal_Package
(N
);
199 when N_Formal_Subprogram_Declaration
=>
200 Analyze_Formal_Subprogram
(N
);
202 when N_Formal_Type_Declaration
=>
203 Analyze_Formal_Type_Declaration
(N
);
205 when N_Free_Statement
=>
206 Analyze_Free_Statement
(N
);
208 when N_Freeze_Entity
=>
209 null; -- no semantic processing required
211 when N_Full_Type_Declaration
=>
212 Analyze_Type_Declaration
(N
);
214 when N_Function_Call
=>
215 Analyze_Function_Call
(N
);
217 when N_Function_Instantiation
=>
218 Analyze_Function_Instantiation
(N
);
220 when N_Generic_Function_Renaming_Declaration
=>
221 Analyze_Generic_Function_Renaming
(N
);
223 when N_Generic_Package_Declaration
=>
224 Analyze_Generic_Package_Declaration
(N
);
226 when N_Generic_Package_Renaming_Declaration
=>
227 Analyze_Generic_Package_Renaming
(N
);
229 when N_Generic_Procedure_Renaming_Declaration
=>
230 Analyze_Generic_Procedure_Renaming
(N
);
232 when N_Generic_Subprogram_Declaration
=>
233 Analyze_Generic_Subprogram_Declaration
(N
);
235 when N_Goto_Statement
=>
236 Analyze_Goto_Statement
(N
);
238 when N_Handled_Sequence_Of_Statements
=>
239 Analyze_Handled_Statements
(N
);
242 Analyze_Identifier
(N
);
244 when N_If_Statement
=>
245 Analyze_If_Statement
(N
);
247 when N_Implicit_Label_Declaration
=>
248 Analyze_Implicit_Label_Declaration
(N
);
251 Analyze_Membership_Op
(N
);
253 when N_Incomplete_Type_Declaration
=>
254 Analyze_Incomplete_Type_Decl
(N
);
256 when N_Indexed_Component
=>
257 Analyze_Indexed_Component_Form
(N
);
259 when N_Integer_Literal
=>
260 Analyze_Integer_Literal
(N
);
262 when N_Itype_Reference
=>
263 Analyze_Itype_Reference
(N
);
268 when N_Loop_Statement
=>
269 Analyze_Loop_Statement
(N
);
272 Analyze_Membership_Op
(N
);
277 when N_Null_Statement
=>
278 Analyze_Null_Statement
(N
);
280 when N_Number_Declaration
=>
281 Analyze_Number_Declaration
(N
);
283 when N_Object_Declaration
=>
284 Analyze_Object_Declaration
(N
);
286 when N_Object_Renaming_Declaration
=>
287 Analyze_Object_Renaming
(N
);
289 when N_Operator_Symbol
=>
290 Analyze_Operator_Symbol
(N
);
293 Analyze_Unary_Op
(N
);
296 Analyze_Arithmetic_Op
(N
);
299 Analyze_Logical_Op
(N
);
302 Analyze_Concatenation
(N
);
305 Analyze_Arithmetic_Op
(N
);
308 Analyze_Equality_Op
(N
);
311 Analyze_Arithmetic_Op
(N
);
314 Analyze_Comparison_Op
(N
);
317 Analyze_Comparison_Op
(N
);
320 Analyze_Comparison_Op
(N
);
323 Analyze_Comparison_Op
(N
);
326 Analyze_Unary_Op
(N
);
329 Analyze_Arithmetic_Op
(N
);
331 when N_Op_Multiply
=>
332 Analyze_Arithmetic_Op
(N
);
335 Analyze_Equality_Op
(N
);
338 Analyze_Negation
(N
);
341 Analyze_Logical_Op
(N
);
344 Analyze_Unary_Op
(N
);
347 Analyze_Arithmetic_Op
(N
);
349 when N_Op_Rotate_Left
=>
350 Analyze_Arithmetic_Op
(N
);
352 when N_Op_Rotate_Right
=>
353 Analyze_Arithmetic_Op
(N
);
355 when N_Op_Shift_Left
=>
356 Analyze_Arithmetic_Op
(N
);
358 when N_Op_Shift_Right
=>
359 Analyze_Arithmetic_Op
(N
);
361 when N_Op_Shift_Right_Arithmetic
=>
362 Analyze_Arithmetic_Op
(N
);
364 when N_Op_Subtract
=>
365 Analyze_Arithmetic_Op
(N
);
368 Analyze_Logical_Op
(N
);
371 Analyze_Short_Circuit
(N
);
373 when N_Others_Choice
=>
374 Analyze_Others_Choice
(N
);
376 when N_Package_Body
=>
377 Analyze_Package_Body
(N
);
379 when N_Package_Body_Stub
=>
380 Analyze_Package_Body_Stub
(N
);
382 when N_Package_Declaration
=>
383 Analyze_Package_Declaration
(N
);
385 when N_Package_Instantiation
=>
386 Analyze_Package_Instantiation
(N
);
388 when N_Package_Renaming_Declaration
=>
389 Analyze_Package_Renaming
(N
);
391 when N_Package_Specification
=>
392 Analyze_Package_Specification
(N
);
394 when N_Parameter_Association
=>
395 Analyze_Parameter_Association
(N
);
400 when N_Private_Extension_Declaration
=>
401 Analyze_Private_Extension_Declaration
(N
);
403 when N_Private_Type_Declaration
=>
404 Analyze_Private_Type_Declaration
(N
);
406 when N_Procedure_Call_Statement
=>
407 Analyze_Procedure_Call
(N
);
409 when N_Procedure_Instantiation
=>
410 Analyze_Procedure_Instantiation
(N
);
412 when N_Protected_Body
=>
413 Analyze_Protected_Body
(N
);
415 when N_Protected_Body_Stub
=>
416 Analyze_Protected_Body_Stub
(N
);
418 when N_Protected_Definition
=>
419 Analyze_Protected_Definition
(N
);
421 when N_Protected_Type_Declaration
=>
422 Analyze_Protected_Type
(N
);
424 when N_Qualified_Expression
=>
425 Analyze_Qualified_Expression
(N
);
427 when N_Raise_Statement
=>
428 Analyze_Raise_Statement
(N
);
430 when N_Raise_xxx_Error
=>
431 Analyze_Raise_xxx_Error
(N
);
436 when N_Range_Constraint
=>
437 Analyze_Range
(Range_Expression
(N
));
439 when N_Real_Literal
=>
440 Analyze_Real_Literal
(N
);
442 when N_Record_Representation_Clause
=>
443 Analyze_Record_Representation_Clause
(N
);
446 Analyze_Reference
(N
);
448 when N_Requeue_Statement
=>
451 when N_Return_Statement
=>
452 Analyze_Return_Statement
(N
);
454 when N_Selected_Component
=>
455 Find_Selected_Component
(N
);
456 -- ??? why not Analyze_Selected_Component, needs comments
458 when N_Selective_Accept
=>
459 Analyze_Selective_Accept
(N
);
461 when N_Single_Protected_Declaration
=>
462 Analyze_Single_Protected
(N
);
464 when N_Single_Task_Declaration
=>
465 Analyze_Single_Task
(N
);
470 when N_String_Literal
=>
471 Analyze_String_Literal
(N
);
473 when N_Subprogram_Body
=>
474 Analyze_Subprogram_Body
(N
);
476 when N_Subprogram_Body_Stub
=>
477 Analyze_Subprogram_Body_Stub
(N
);
479 when N_Subprogram_Declaration
=>
480 Analyze_Subprogram_Declaration
(N
);
482 when N_Subprogram_Info
=>
483 Analyze_Subprogram_Info
(N
);
485 when N_Subprogram_Renaming_Declaration
=>
486 Analyze_Subprogram_Renaming
(N
);
488 when N_Subtype_Declaration
=>
489 Analyze_Subtype_Declaration
(N
);
491 when N_Subtype_Indication
=>
492 Analyze_Subtype_Indication
(N
);
498 Analyze_Task_Body
(N
);
500 when N_Task_Body_Stub
=>
501 Analyze_Task_Body_Stub
(N
);
503 when N_Task_Definition
=>
504 Analyze_Task_Definition
(N
);
506 when N_Task_Type_Declaration
=>
507 Analyze_Task_Type
(N
);
509 when N_Terminate_Alternative
=>
510 Analyze_Terminate_Alternative
(N
);
512 when N_Timed_Entry_Call
=>
513 Analyze_Timed_Entry_Call
(N
);
515 when N_Triggering_Alternative
=>
516 Analyze_Triggering_Alternative
(N
);
518 when N_Type_Conversion
=>
519 Analyze_Type_Conversion
(N
);
521 when N_Unchecked_Expression
=>
522 Analyze_Unchecked_Expression
(N
);
524 when N_Unchecked_Type_Conversion
=>
525 Analyze_Unchecked_Type_Conversion
(N
);
527 when N_Use_Package_Clause
=>
528 Analyze_Use_Package
(N
);
530 when N_Use_Type_Clause
=>
531 Analyze_Use_Type
(N
);
533 when N_Validate_Unchecked_Conversion
=>
536 when N_Variant_Part
=>
537 Analyze_Variant_Part
(N
);
539 when N_With_Clause
=>
540 Analyze_With_Clause
(N
);
542 when N_With_Type_Clause
=>
543 Analyze_With_Type_Clause
(N
);
545 -- A call to analyze the Empty node is an error, but most likely
546 -- it is an error caused by an attempt to analyze a malformed
547 -- piece of tree caused by some other error, so if there have
548 -- been any other errors, we just ignore it, otherwise it is
549 -- a real internal error which we complain about.
552 pragma Assert
(Serious_Errors_Detected
/= 0);
555 -- A call to analyze the error node is simply ignored, to avoid
556 -- causing cascaded errors (happens of course only in error cases)
561 -- For the remaining node types, we generate compiler abort, because
562 -- these nodes are always analyzed within the Sem_Chn routines and
563 -- there should never be a case of making a call to the main Analyze
564 -- routine for these node kinds. For example, an N_Access_Definition
565 -- node appears only in the context of a type declaration, and is
566 -- processed by the analyze routine for type declarations.
570 N_Access_Definition |
571 N_Access_Function_Definition |
572 N_Access_Procedure_Definition |
573 N_Access_To_Object_Definition |
574 N_Case_Statement_Alternative |
575 N_Compilation_Unit_Aux |
576 N_Component_Association |
578 N_Component_Definition |
580 N_Constrained_Array_Definition |
581 N_Decimal_Fixed_Point_Definition |
582 N_Defining_Character_Literal |
583 N_Defining_Identifier |
584 N_Defining_Operator_Symbol |
585 N_Defining_Program_Unit_Name |
587 N_Derived_Type_Definition |
589 N_Digits_Constraint |
590 N_Discriminant_Association |
591 N_Discriminant_Specification |
593 N_Entry_Call_Statement |
594 N_Enumeration_Type_Definition |
595 N_Exception_Handler |
596 N_Floating_Point_Definition |
597 N_Formal_Decimal_Fixed_Point_Definition |
598 N_Formal_Derived_Type_Definition |
599 N_Formal_Discrete_Type_Definition |
600 N_Formal_Floating_Point_Definition |
601 N_Formal_Modular_Type_Definition |
602 N_Formal_Ordinary_Fixed_Point_Definition |
603 N_Formal_Private_Type_Definition |
604 N_Formal_Signed_Integer_Type_Definition |
605 N_Function_Specification |
606 N_Generic_Association |
607 N_Index_Or_Discriminant_Constraint |
609 N_Loop_Parameter_Specification |
611 N_Modular_Type_Definition |
612 N_Ordinary_Fixed_Point_Definition |
613 N_Parameter_Specification |
614 N_Pragma_Argument_Association |
615 N_Procedure_Specification |
616 N_Real_Range_Specification |
617 N_Record_Definition |
618 N_Signed_Integer_Type_Definition |
619 N_Unconstrained_Array_Definition |
627 Debug_A_Exit
("analyzing ", N
, " (done)");
629 -- Now that we have analyzed the node, we call the expander to
630 -- perform possible expansion. This is done only for nodes that
631 -- are not subexpressions, because in the case of subexpressions,
632 -- we don't have the type yet, and the expander will need to know
633 -- the type before it can do its job. For subexpression nodes, the
634 -- call to the expander happens in the Sem_Res.Resolve.
636 -- The Analyzed flag is also set at this point for non-subexpression
637 -- nodes (in the case of subexpression nodes, we can't set the flag
638 -- yet, since resolution and expansion have not yet been completed)
640 if Nkind
(N
) not in N_Subexpr
then
645 -- Version with check(s) suppressed
647 procedure Analyze
(N
: Node_Id
; Suppress
: Check_Id
) is
649 if Suppress
= All_Checks
then
651 Svg
: constant Suppress_Array
:= Scope_Suppress
;
653 Scope_Suppress
:= (others => True);
655 Scope_Suppress
:= Svg
;
660 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
662 Scope_Suppress
(Suppress
) := True;
664 Scope_Suppress
(Suppress
) := Svg
;
673 procedure Analyze_List
(L
: List_Id
) is
678 while Present
(Node
) loop
684 -- Version with check(s) suppressed
686 procedure Analyze_List
(L
: List_Id
; Suppress
: Check_Id
) is
688 if Suppress
= All_Checks
then
690 Svg
: constant Suppress_Array
:= Scope_Suppress
;
692 Scope_Suppress
:= (others => True);
694 Scope_Suppress
:= Svg
;
699 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
701 Scope_Suppress
(Suppress
) := True;
703 Scope_Suppress
(Suppress
) := Svg
;
708 --------------------------
709 -- Copy_Suppress_Status --
710 --------------------------
712 procedure Copy_Suppress_Status
718 if not Checks_May_Be_Suppressed
(From
) then
722 -- First search the local entity suppress table, we search this in
723 -- reverse order so that we get the innermost entry that applies to
724 -- this case if there are nested entries. Note that for the purpose
725 -- of this procedure we are ONLY looking for entries corresponding
726 -- to a two-argument Suppress, where the second argument matches From.
729 reverse Local_Entity_Suppress
.First
.. Local_Entity_Suppress
.Last
732 R
: Entity_Check_Suppress_Record
733 renames Local_Entity_Suppress
.Table
(J
);
737 and then (R
.Check
= All_Checks
or else R
.Check
= C
)
740 Set_Checks_May_Be_Suppressed
(To
, True);
741 Local_Entity_Suppress
.Append
751 -- Now search the global entity suppress table for a matching entry
752 -- We also search this in reverse order so that if there are multiple
753 -- pragmas for the same entity, the last one applies.
756 reverse Global_Entity_Suppress
.First
.. Global_Entity_Suppress
.Last
759 R
: Entity_Check_Suppress_Record
760 renames Global_Entity_Suppress
.Table
(J
);
764 and then (R
.Check
= All_Checks
or else R
.Check
= C
)
767 Set_Checks_May_Be_Suppressed
(To
, True);
768 Local_Entity_Suppress
.Append
776 end Copy_Suppress_Status
;
778 -------------------------
779 -- Enter_Generic_Scope --
780 -------------------------
782 procedure Enter_Generic_Scope
(S
: Entity_Id
) is
784 if No
(Outer_Generic_Scope
) then
785 Outer_Generic_Scope
:= S
;
787 end Enter_Generic_Scope
;
789 ------------------------
790 -- Exit_Generic_Scope --
791 ------------------------
793 procedure Exit_Generic_Scope
(S
: Entity_Id
) is
795 if S
= Outer_Generic_Scope
then
796 Outer_Generic_Scope
:= Empty
;
798 end Exit_Generic_Scope
;
800 -----------------------
801 -- Explicit_Suppress --
802 -----------------------
804 function Explicit_Suppress
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
806 if not Checks_May_Be_Suppressed
(E
) then
811 reverse Global_Entity_Suppress
.First
.. Global_Entity_Suppress
.Last
814 R
: Entity_Check_Suppress_Record
815 renames Global_Entity_Suppress
.Table
(J
);
819 and then (R
.Check
= All_Checks
or else R
.Check
= C
)
828 end Explicit_Suppress
;
830 -----------------------------
831 -- External_Ref_In_Generic --
832 -----------------------------
834 function External_Ref_In_Generic
(E
: Entity_Id
) return Boolean is
838 -- Entity is global if defined outside of current outer_generic_scope:
839 -- Either the entity has a smaller depth that the outer generic, or it
840 -- is in a different compilation unit, or it is defined within a unit
841 -- in the same compilation, that is not within the outer_generic.
843 if No
(Outer_Generic_Scope
) then
846 elsif Scope_Depth
(Scope
(E
)) < Scope_Depth
(Outer_Generic_Scope
)
847 or else not In_Same_Source_Unit
(E
, Outer_Generic_Scope
)
854 while Present
(Scop
) loop
855 if Scop
= Outer_Generic_Scope
then
857 elsif Scope_Depth
(Scop
) < Scope_Depth
(Outer_Generic_Scope
) then
860 Scop
:= Scope
(Scop
);
866 end External_Ref_In_Generic
;
872 procedure Initialize
is
874 Local_Entity_Suppress
.Init
;
875 Global_Entity_Suppress
.Init
;
877 Unloaded_Subunits
:= False;
880 ------------------------------
881 -- Insert_After_And_Analyze --
882 ------------------------------
884 procedure Insert_After_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
890 -- If we are not at the end of the list, then the easiest
891 -- coding is simply to insert before our successor
893 if Present
(Next
(N
)) then
894 Insert_Before_And_Analyze
(Next
(N
), M
);
896 -- Case of inserting at the end of the list
899 -- Capture the Node_Id of the node to be inserted. This Node_Id
900 -- will still be the same after the insert operation.
905 -- Now just analyze from the inserted node to the end of
906 -- the new list (note that this properly handles the case
907 -- where any of the analyze calls result in the insertion of
908 -- nodes after the analyzed node, expecting analysis).
910 while Present
(Node
) loop
912 Mark_Rewrite_Insertion
(Node
);
917 end Insert_After_And_Analyze
;
919 -- Version with check(s) suppressed
921 procedure Insert_After_And_Analyze
927 if Suppress
= All_Checks
then
929 Svg
: constant Suppress_Array
:= Scope_Suppress
;
931 Scope_Suppress
:= (others => True);
932 Insert_After_And_Analyze
(N
, M
);
933 Scope_Suppress
:= Svg
;
938 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
940 Scope_Suppress
(Suppress
) := True;
941 Insert_After_And_Analyze
(N
, M
);
942 Scope_Suppress
(Suppress
) := Svg
;
945 end Insert_After_And_Analyze
;
947 -------------------------------
948 -- Insert_Before_And_Analyze --
949 -------------------------------
951 procedure Insert_Before_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
957 -- Capture the Node_Id of the first list node to be inserted.
958 -- This will still be the first node after the insert operation,
959 -- since Insert_List_After does not modify the Node_Id values.
962 Insert_Before
(N
, M
);
964 -- The insertion does not change the Id's of any of the nodes in
965 -- the list, and they are still linked, so we can simply loop from
966 -- the original first node until we meet the node before which the
967 -- insertion is occurring. Note that this properly handles the case
968 -- where any of the analyzed nodes insert nodes after themselves,
969 -- expecting them to get analyzed.
973 Mark_Rewrite_Insertion
(Node
);
977 end Insert_Before_And_Analyze
;
979 -- Version with check(s) suppressed
981 procedure Insert_Before_And_Analyze
987 if Suppress
= All_Checks
then
989 Svg
: constant Suppress_Array
:= Scope_Suppress
;
991 Scope_Suppress
:= (others => True);
992 Insert_Before_And_Analyze
(N
, M
);
993 Scope_Suppress
:= Svg
;
998 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1000 Scope_Suppress
(Suppress
) := True;
1001 Insert_Before_And_Analyze
(N
, M
);
1002 Scope_Suppress
(Suppress
) := Svg
;
1005 end Insert_Before_And_Analyze
;
1007 -----------------------------------
1008 -- Insert_List_After_And_Analyze --
1009 -----------------------------------
1011 procedure Insert_List_After_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1012 After
: constant Node_Id
:= Next
(N
);
1016 if Is_Non_Empty_List
(L
) then
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.
1023 Insert_List_After
(N
, L
);
1025 -- Now just analyze from the original first node until we get to
1026 -- the successor of the original insertion point (which may be
1027 -- Empty if the insertion point was at the end of the list). Note
1028 -- that this properly handles the case where any of the analyze
1029 -- calls result in the insertion of nodes after the analyzed
1030 -- node (possibly calling this routine recursively).
1032 while Node
/= After
loop
1034 Mark_Rewrite_Insertion
(Node
);
1038 end Insert_List_After_And_Analyze
;
1040 -- Version with check(s) suppressed
1042 procedure Insert_List_After_And_Analyze
1043 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1046 if Suppress
= All_Checks
then
1048 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1050 Scope_Suppress
:= (others => True);
1051 Insert_List_After_And_Analyze
(N
, L
);
1052 Scope_Suppress
:= Svg
;
1057 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1059 Scope_Suppress
(Suppress
) := True;
1060 Insert_List_After_And_Analyze
(N
, L
);
1061 Scope_Suppress
(Suppress
) := Svg
;
1064 end Insert_List_After_And_Analyze
;
1066 ------------------------------------
1067 -- Insert_List_Before_And_Analyze --
1068 ------------------------------------
1070 procedure Insert_List_Before_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1074 if Is_Non_Empty_List
(L
) then
1076 -- Capture the Node_Id of the first list node to be inserted.
1077 -- This will still be the first node after the insert operation,
1078 -- since Insert_List_After does not modify the Node_Id values.
1081 Insert_List_Before
(N
, L
);
1083 -- The insertion does not change the Id's of any of the nodes in
1084 -- the list, and they are still linked, so we can simply loop from
1085 -- the original first node until we meet the node before which the
1086 -- insertion is occurring. Note that this properly handles the case
1087 -- where any of the analyzed nodes insert nodes after themselves,
1088 -- expecting them to get analyzed.
1090 while Node
/= N
loop
1092 Mark_Rewrite_Insertion
(Node
);
1096 end Insert_List_Before_And_Analyze
;
1098 -- Version with check(s) suppressed
1100 procedure Insert_List_Before_And_Analyze
1101 (N
: Node_Id
; L
: List_Id
; Suppress
: Check_Id
)
1104 if Suppress
= All_Checks
then
1106 Svg
: constant Suppress_Array
:= Scope_Suppress
;
1108 Scope_Suppress
:= (others => True);
1109 Insert_List_Before_And_Analyze
(N
, L
);
1110 Scope_Suppress
:= Svg
;
1115 Svg
: constant Boolean := Scope_Suppress
(Suppress
);
1117 Scope_Suppress
(Suppress
) := True;
1118 Insert_List_Before_And_Analyze
(N
, L
);
1119 Scope_Suppress
(Suppress
) := Svg
;
1122 end Insert_List_Before_And_Analyze
;
1124 -------------------------
1125 -- Is_Check_Suppressed --
1126 -------------------------
1128 function Is_Check_Suppressed
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
1130 -- First search the local entity suppress table, we search this in
1131 -- reverse order so that we get the innermost entry that applies to
1132 -- this case if there are nested entries.
1135 reverse Local_Entity_Suppress
.First
.. Local_Entity_Suppress
.Last
1138 R
: Entity_Check_Suppress_Record
1139 renames Local_Entity_Suppress
.Table
(J
);
1142 if (R
.Entity
= Empty
or else R
.Entity
= E
)
1143 and then (R
.Check
= All_Checks
or else R
.Check
= C
)
1150 -- Now search the global entity suppress table for a matching entry
1151 -- We also search this in reverse order so that if there are multiple
1152 -- pragmas for the same entity, the last one applies (not clear what
1153 -- or whether the RM specifies this handling, but it seems reasonable).
1156 reverse Global_Entity_Suppress
.First
.. Global_Entity_Suppress
.Last
1159 R
: Entity_Check_Suppress_Record
1160 renames Global_Entity_Suppress
.Table
(J
);
1164 and then (R
.Check
= All_Checks
or else R
.Check
= C
)
1171 -- If we did not find a matching entry, then use the normal scope
1172 -- suppress value after all (actually this will be the global setting
1173 -- since it clearly was not overridden at any point)
1175 return Scope_Suppress
(C
);
1176 end Is_Check_Suppressed
;
1184 Local_Entity_Suppress
.Locked
:= True;
1185 Global_Entity_Suppress
.Locked
:= True;
1186 Scope_Stack
.Locked
:= True;
1187 Local_Entity_Suppress
.Release
;
1188 Global_Entity_Suppress
.Release
;
1189 Scope_Stack
.Release
;
1196 procedure Semantics
(Comp_Unit
: Node_Id
) is
1198 -- The following locations save the corresponding global flags and
1199 -- variables so that they can be restored on completion. This is
1200 -- needed so that calls to Rtsfind start with the proper default
1201 -- values for these variables, and also that such calls do not
1202 -- disturb the settings for units being analyzed at a higher level.
1204 S_Full_Analysis
: constant Boolean := Full_Analysis
;
1205 S_In_Default_Expr
: constant Boolean := In_Default_Expression
;
1206 S_Inside_A_Generic
: constant Boolean := Inside_A_Generic
;
1207 S_New_Nodes_OK
: constant Int
:= New_Nodes_OK
;
1208 S_Outer_Gen_Scope
: constant Entity_Id
:= Outer_Generic_Scope
;
1209 S_Sem_Unit
: constant Unit_Number_Type
:= Current_Sem_Unit
;
1210 S_GNAT_Mode
: constant Boolean := GNAT_Mode
;
1211 Generic_Main
: constant Boolean :=
1212 Nkind
(Unit
(Cunit
(Main_Unit
)))
1213 in N_Generic_Declaration
;
1215 -- If the main unit is generic, every compiled unit, including its
1216 -- context, is compiled with expansion disabled.
1218 Save_Config_Switches
: Config_Switches_Type
;
1219 -- Variable used to save values of config switches while we analyze
1220 -- the new unit, to be restored on exit for proper recursive behavior.
1222 procedure Do_Analyze
;
1223 -- Procedure to analyze the compilation unit. This is called more
1224 -- than once when the high level optimizer is activated.
1230 procedure Do_Analyze
is
1233 New_Scope
(Standard_Standard
);
1234 Scope_Suppress
:= Suppress_Options
;
1236 (Scope_Stack
.Last
).Component_Alignment_Default
:= Calign_Default
;
1238 (Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
1239 Outer_Generic_Scope
:= Empty
;
1241 -- Now analyze the top level compilation unit node
1243 Analyze
(Comp_Unit
);
1245 -- Check for scope mismatch on exit from compilation
1247 pragma Assert
(Current_Scope
= Standard_Standard
1248 or else Comp_Unit
= Cunit
(Main_Unit
));
1250 -- Then pop entry for Standard, and pop implicit types
1253 Restore_Scope_Stack
;
1256 -- Start of processing for Semantics
1259 Compiler_State
:= Analyzing
;
1260 Current_Sem_Unit
:= Get_Cunit_Unit_Number
(Comp_Unit
);
1262 -- Compile predefined units with GNAT_Mode set to True, to properly
1263 -- process the categorization stuff. However, do not set set GNAT_Mode
1264 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1265 -- Sequential_IO) as this would prevent pragma System_Extend to be
1266 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1268 -- Cleaner might be to do the kludge at the point of excluding the
1269 -- pragma (do not exclude for renamings ???)
1273 or else Is_Predefined_File_Name
1274 (Unit_File_Name
(Current_Sem_Unit
),
1275 Renamings_Included
=> False);
1277 if Generic_Main
then
1278 Expander_Mode_Save_And_Set
(False);
1280 Expander_Mode_Save_And_Set
1281 (Operating_Mode
= Generate_Code
or Debug_Flag_X
);
1284 Full_Analysis
:= True;
1285 Inside_A_Generic
:= False;
1286 In_Default_Expression
:= False;
1288 Set_Comes_From_Source_Default
(False);
1289 Save_Opt_Config_Switches
(Save_Config_Switches
);
1290 Set_Opt_Config_Switches
1291 (Is_Internal_File_Name
(Unit_File_Name
(Current_Sem_Unit
)),
1292 Current_Sem_Unit
= Main_Unit
);
1294 -- Only do analysis of unit that has not already been analyzed
1296 if not Analyzed
(Comp_Unit
) then
1297 Initialize_Version
(Current_Sem_Unit
);
1299 Expander_Mode_Save_And_Set
(False);
1302 Reset_Analyzed_Flags
(Comp_Unit
);
1303 Expander_Mode_Restore
;
1304 High_Level_Optimize
(Comp_Unit
);
1311 -- Save indication of dynamic elaboration checks for ALI file
1313 Set_Dynamic_Elab
(Current_Sem_Unit
, Dynamic_Elaboration_Checks
);
1315 -- Restore settings of saved switches to entry values
1317 Current_Sem_Unit
:= S_Sem_Unit
;
1318 Full_Analysis
:= S_Full_Analysis
;
1319 In_Default_Expression
:= S_In_Default_Expr
;
1320 Inside_A_Generic
:= S_Inside_A_Generic
;
1321 New_Nodes_OK
:= S_New_Nodes_OK
;
1322 Outer_Generic_Scope
:= S_Outer_Gen_Scope
;
1323 GNAT_Mode
:= S_GNAT_Mode
;
1325 Restore_Opt_Config_Switches
(Save_Config_Switches
);
1326 Expander_Mode_Restore
;