1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2023, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Debug_A
; use Debug_A
;
29 with Einfo
; use Einfo
;
30 with Einfo
.Entities
; use Einfo
.Entities
;
31 with Einfo
.Utils
; use Einfo
.Utils
;
32 with Elists
; use Elists
;
33 with Exp_SPARK
; use Exp_SPARK
;
34 with Expander
; use Expander
;
35 with Ghost
; use Ghost
;
37 with Lib
.Load
; use Lib
.Load
;
38 with Nlists
; use Nlists
;
39 with Output
; use Output
;
40 with Restrict
; use Restrict
;
41 with Sem_Attr
; use Sem_Attr
;
42 with Sem_Ch2
; use Sem_Ch2
;
43 with Sem_Ch3
; use Sem_Ch3
;
44 with Sem_Ch4
; use Sem_Ch4
;
45 with Sem_Ch5
; use Sem_Ch5
;
46 with Sem_Ch6
; use Sem_Ch6
;
47 with Sem_Ch7
; use Sem_Ch7
;
48 with Sem_Ch8
; use Sem_Ch8
;
49 with Sem_Ch9
; use Sem_Ch9
;
50 with Sem_Ch10
; use Sem_Ch10
;
51 with Sem_Ch11
; use Sem_Ch11
;
52 with Sem_Ch12
; use Sem_Ch12
;
53 with Sem_Ch13
; use Sem_Ch13
;
54 with Sem_Prag
; use Sem_Prag
;
55 with Sem_Util
; use Sem_Util
;
56 with Sinfo
; use Sinfo
;
57 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
58 with Sinfo
.Utils
; use Sinfo
.Utils
;
59 with Stand
; use Stand
;
60 with Stylesw
; use Stylesw
;
61 with Uintp
; use Uintp
;
62 with Uname
; use Uname
;
64 with Ada
.Unchecked_Deallocation
;
66 pragma Warnings
(Off
, Sem_Util
);
67 -- Suppress warnings of unused with for Sem_Util (used only in asserts)
71 Debug_Unit_Walk
: Boolean renames Debug_Flag_Dot_WW
;
72 -- Controls debugging printouts for Walk_Library_Items
74 Outer_Generic_Scope
: Entity_Id
:= Empty
;
75 -- Global reference to the outer scope that is generic. In a non-generic
76 -- context, it is empty. At the moment, it is only used for avoiding
77 -- freezing of external references in generics.
79 Comp_Unit_List
: Elist_Id
:= No_Elist
;
80 -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
81 -- processed by Semantics, in an appropriate order. Initialized to
82 -- No_Elist, because it's too early to call New_Elmt_List; we will set it
83 -- to New_Elmt_List on first use.
86 with procedure Action
(Withed_Unit
: Node_Id
);
87 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean);
88 -- Walk all the with clauses of CU, and call Action for the with'ed unit.
89 -- Ignore limited withs, unless Include_Limited is True. CU must be an
90 -- N_Compilation_Unit.
93 with procedure Action
(Withed_Unit
: Node_Id
);
94 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean);
95 -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
96 -- of this unit, since they count as dependences on their parent library
97 -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
103 -- WARNING: This routine manages Ghost regions. Return statements must be
104 -- replaced by gotos which jump to the end of the routine and restore the
107 procedure Analyze
(N
: Node_Id
) is
108 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
109 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
110 -- Save the Ghost-related attributes to restore on exit
113 Debug_A_Entry
("analyzing ", N
);
115 -- Immediate return if already analyzed
118 Debug_A_Exit
("analyzing ", N
, " (done, analyzed already)");
122 -- A declaration may be subject to pragma Ghost. Set the mode now to
123 -- ensure that any nodes generated during analysis and expansion are
126 if Is_Declaration
(N
) then
127 Mark_And_Set_Ghost_Declaration
(N
);
130 -- Otherwise processing depends on the node kind
133 when N_Abort_Statement
=>
134 Analyze_Abort_Statement
(N
);
136 when N_Abstract_Subprogram_Declaration
=>
137 Analyze_Abstract_Subprogram_Declaration
(N
);
139 when N_Accept_Alternative
=>
140 Analyze_Accept_Alternative
(N
);
142 when N_Accept_Statement
=>
143 Analyze_Accept_Statement
(N
);
146 Analyze_Aggregate
(N
);
149 Analyze_Allocator
(N
);
152 Analyze_Short_Circuit
(N
);
154 when N_Assignment_Statement
=>
155 Analyze_Assignment
(N
);
157 when N_Asynchronous_Select
=>
158 Analyze_Asynchronous_Select
(N
);
161 Analyze_At_Clause
(N
);
163 when N_Attribute_Reference
=>
164 Analyze_Attribute
(N
);
166 when N_Attribute_Definition_Clause
=>
167 Analyze_Attribute_Definition_Clause
(N
);
169 when N_Block_Statement
=>
170 Analyze_Block_Statement
(N
);
172 when N_Case_Expression
=>
173 Analyze_Case_Expression
(N
);
175 when N_Case_Statement
=>
176 Analyze_Case_Statement
(N
);
178 when N_Character_Literal
=>
179 Analyze_Character_Literal
(N
);
181 when N_Code_Statement
=>
182 Analyze_Code_Statement
(N
);
184 when N_Compilation_Unit
=>
185 Analyze_Compilation_Unit
(N
);
187 when N_Component_Declaration
=>
188 Analyze_Component_Declaration
(N
);
190 when N_Compound_Statement
=>
191 Analyze_Compound_Statement
(N
);
193 when N_Conditional_Entry_Call
=>
194 Analyze_Conditional_Entry_Call
(N
);
196 when N_Delay_Alternative
=>
197 Analyze_Delay_Alternative
(N
);
199 when N_Delay_Relative_Statement
=>
200 Analyze_Delay_Relative
(N
);
202 when N_Delay_Until_Statement
=>
203 Analyze_Delay_Until
(N
);
205 when N_Delta_Aggregate
=>
206 Analyze_Aggregate
(N
);
209 Analyze_Entry_Body
(N
);
211 when N_Entry_Body_Formal_Part
=>
212 Analyze_Entry_Body_Formal_Part
(N
);
214 when N_Entry_Call_Alternative
=>
215 Analyze_Entry_Call_Alternative
(N
);
217 when N_Entry_Declaration
=>
218 Analyze_Entry_Declaration
(N
);
220 when N_Entry_Index_Specification
=>
221 Analyze_Entry_Index_Specification
(N
);
223 when N_Enumeration_Representation_Clause
=>
224 Analyze_Enumeration_Representation_Clause
(N
);
226 when N_Exception_Declaration
=>
227 Analyze_Exception_Declaration
(N
);
229 when N_Exception_Renaming_Declaration
=>
230 Analyze_Exception_Renaming
(N
);
232 when N_Exit_Statement
=>
233 Analyze_Exit_Statement
(N
);
235 when N_Expanded_Name
=>
236 Analyze_Expanded_Name
(N
);
238 when N_Explicit_Dereference
=>
239 Analyze_Explicit_Dereference
(N
);
241 when N_Expression_Function
=>
242 Analyze_Expression_Function
(N
);
244 when N_Expression_With_Actions
=>
245 Analyze_Expression_With_Actions
(N
);
247 when N_Extended_Return_Statement
=>
248 Analyze_Extended_Return_Statement
(N
);
250 when N_Extension_Aggregate
=>
251 Analyze_Aggregate
(N
);
253 when N_Formal_Object_Declaration
=>
254 Analyze_Formal_Object_Declaration
(N
);
256 when N_Formal_Package_Declaration
=>
257 Analyze_Formal_Package_Declaration
(N
);
259 when N_Formal_Subprogram_Declaration
=>
260 Analyze_Formal_Subprogram_Declaration
(N
);
262 when N_Formal_Type_Declaration
=>
263 Analyze_Formal_Type_Declaration
(N
);
265 when N_Free_Statement
=>
266 Analyze_Free_Statement
(N
);
268 when N_Freeze_Entity
=>
269 Analyze_Freeze_Entity
(N
);
271 when N_Freeze_Generic_Entity
=>
272 Analyze_Freeze_Generic_Entity
(N
);
274 when N_Full_Type_Declaration
=>
275 Analyze_Full_Type_Declaration
(N
);
277 when N_Function_Call
=>
278 Analyze_Function_Call
(N
);
280 when N_Function_Instantiation
=>
281 Analyze_Function_Instantiation
(N
);
283 when N_Generic_Function_Renaming_Declaration
=>
284 Analyze_Generic_Function_Renaming
(N
);
286 when N_Generic_Package_Declaration
=>
287 Analyze_Generic_Package_Declaration
(N
);
289 when N_Generic_Package_Renaming_Declaration
=>
290 Analyze_Generic_Package_Renaming
(N
);
292 when N_Generic_Procedure_Renaming_Declaration
=>
293 Analyze_Generic_Procedure_Renaming
(N
);
295 when N_Generic_Subprogram_Declaration
=>
296 Analyze_Generic_Subprogram_Declaration
(N
);
298 when N_Goto_Statement
=>
299 Analyze_Goto_Statement
(N
);
301 when N_Goto_When_Statement
=>
302 Analyze_Goto_When_Statement
(N
);
304 when N_Handled_Sequence_Of_Statements
=>
305 Analyze_Handled_Statements
(N
);
308 Analyze_Identifier
(N
);
310 when N_If_Expression
=>
311 Analyze_If_Expression
(N
);
313 when N_If_Statement
=>
314 Analyze_If_Statement
(N
);
316 when N_Implicit_Label_Declaration
=>
317 Analyze_Implicit_Label_Declaration
(N
);
320 Analyze_Membership_Op
(N
);
322 when N_Incomplete_Type_Declaration
=>
323 Analyze_Incomplete_Type_Decl
(N
);
325 when N_Indexed_Component
=>
326 Analyze_Indexed_Component_Form
(N
);
328 when N_Integer_Literal
=>
329 Analyze_Integer_Literal
(N
);
331 when N_Iterator_Specification
=>
332 Analyze_Iterator_Specification
(N
);
334 when N_Itype_Reference
=>
335 Analyze_Itype_Reference
(N
);
340 when N_Loop_Parameter_Specification
=>
341 Analyze_Loop_Parameter_Specification
(N
);
343 when N_Loop_Statement
=>
344 Analyze_Loop_Statement
(N
);
347 Analyze_Membership_Op
(N
);
352 when N_Null_Statement
=>
353 Analyze_Null_Statement
(N
);
355 when N_Number_Declaration
=>
356 Analyze_Number_Declaration
(N
);
358 when N_Object_Declaration
=>
359 Analyze_Object_Declaration
(N
);
361 when N_Object_Renaming_Declaration
=>
362 Analyze_Object_Renaming
(N
);
364 when N_Operator_Symbol
=>
365 Analyze_Operator_Symbol
(N
);
368 Analyze_Unary_Op
(N
);
371 Analyze_Arithmetic_Op
(N
);
374 Analyze_Logical_Op
(N
);
377 Analyze_Concatenation
(N
);
380 Analyze_Arithmetic_Op
(N
);
383 Analyze_Comparison_Equality_Op
(N
);
386 Analyze_Arithmetic_Op
(N
);
389 Analyze_Comparison_Equality_Op
(N
);
392 Analyze_Comparison_Equality_Op
(N
);
395 Analyze_Comparison_Equality_Op
(N
);
398 Analyze_Comparison_Equality_Op
(N
);
401 Analyze_Unary_Op
(N
);
406 when N_Op_Multiply
=>
407 Analyze_Arithmetic_Op
(N
);
410 Analyze_Comparison_Equality_Op
(N
);
413 Analyze_Negation
(N
);
416 Analyze_Logical_Op
(N
);
419 Analyze_Unary_Op
(N
);
422 Analyze_Arithmetic_Op
(N
);
424 when N_Op_Rotate_Left
=>
425 Analyze_Arithmetic_Op
(N
);
427 when N_Op_Rotate_Right
=>
428 Analyze_Arithmetic_Op
(N
);
430 when N_Op_Shift_Left
=>
431 Analyze_Arithmetic_Op
(N
);
433 when N_Op_Shift_Right
=>
434 Analyze_Arithmetic_Op
(N
);
436 when N_Op_Shift_Right_Arithmetic
=>
437 Analyze_Arithmetic_Op
(N
);
439 when N_Op_Subtract
=>
440 Analyze_Arithmetic_Op
(N
);
443 Analyze_Logical_Op
(N
);
446 Analyze_Short_Circuit
(N
);
448 when N_Others_Choice
=>
449 Analyze_Others_Choice
(N
);
451 when N_Package_Body
=>
452 Analyze_Package_Body
(N
);
454 when N_Package_Body_Stub
=>
455 Analyze_Package_Body_Stub
(N
);
457 when N_Package_Declaration
=>
458 Analyze_Package_Declaration
(N
);
460 when N_Package_Instantiation
=>
461 Analyze_Package_Instantiation
(N
);
463 when N_Package_Renaming_Declaration
=>
464 Analyze_Package_Renaming
(N
);
466 when N_Package_Specification
=>
467 Analyze_Package_Specification
(N
);
469 when N_Parameter_Association
=>
470 Analyze_Parameter_Association
(N
);
475 when N_Private_Extension_Declaration
=>
476 Analyze_Private_Extension_Declaration
(N
);
478 when N_Private_Type_Declaration
=>
479 Analyze_Private_Type_Declaration
(N
);
481 when N_Procedure_Call_Statement
=>
482 Analyze_Procedure_Call
(N
);
484 when N_Procedure_Instantiation
=>
485 Analyze_Procedure_Instantiation
(N
);
487 when N_Protected_Body
=>
488 Analyze_Protected_Body
(N
);
490 when N_Protected_Body_Stub
=>
491 Analyze_Protected_Body_Stub
(N
);
493 when N_Protected_Definition
=>
494 Analyze_Protected_Definition
(N
);
496 when N_Protected_Type_Declaration
=>
497 Analyze_Protected_Type_Declaration
(N
);
499 when N_Qualified_Expression
=>
500 Analyze_Qualified_Expression
(N
);
502 when N_Quantified_Expression
=>
503 Analyze_Quantified_Expression
(N
);
505 when N_Raise_Expression
=>
506 Analyze_Raise_Expression
(N
);
508 when N_Raise_Statement
=>
509 Analyze_Raise_Statement
(N
);
511 when N_Raise_When_Statement
=>
512 Analyze_Raise_When_Statement
(N
);
514 when N_Raise_xxx_Error
=>
515 Analyze_Raise_xxx_Error
(N
);
520 when N_Range_Constraint
=>
521 Analyze_Range
(Range_Expression
(N
));
523 when N_Real_Literal
=>
524 Analyze_Real_Literal
(N
);
526 when N_Record_Representation_Clause
=>
527 Analyze_Record_Representation_Clause
(N
);
530 Analyze_Reference
(N
);
532 when N_Requeue_Statement
=>
535 when N_Return_When_Statement
=>
536 Analyze_Return_When_Statement
(N
);
538 when N_Simple_Return_Statement
=>
539 Analyze_Simple_Return_Statement
(N
);
541 when N_Selected_Component
=>
542 Find_Selected_Component
(N
);
543 -- ??? why not Analyze_Selected_Component, needs comments
545 when N_Selective_Accept
=>
546 Analyze_Selective_Accept
(N
);
548 when N_Single_Protected_Declaration
=>
549 Analyze_Single_Protected_Declaration
(N
);
551 when N_Single_Task_Declaration
=>
552 Analyze_Single_Task_Declaration
(N
);
557 when N_String_Literal
=>
558 Analyze_String_Literal
(N
);
560 when N_Interpolated_String_Literal
=>
561 Analyze_Interpolated_String_Literal
(N
);
563 when N_Subprogram_Body
=>
564 Analyze_Subprogram_Body
(N
);
566 when N_Subprogram_Body_Stub
=>
567 Analyze_Subprogram_Body_Stub
(N
);
569 when N_Subprogram_Declaration
=>
570 Analyze_Subprogram_Declaration
(N
);
572 when N_Subprogram_Renaming_Declaration
=>
573 Analyze_Subprogram_Renaming
(N
);
575 when N_Subtype_Declaration
=>
576 Analyze_Subtype_Declaration
(N
);
578 when N_Subtype_Indication
=>
579 Analyze_Subtype_Indication
(N
);
584 when N_Target_Name
=>
585 Analyze_Target_Name
(N
);
588 Analyze_Task_Body
(N
);
590 when N_Task_Body_Stub
=>
591 Analyze_Task_Body_Stub
(N
);
593 when N_Task_Definition
=>
594 Analyze_Task_Definition
(N
);
596 when N_Task_Type_Declaration
=>
597 Analyze_Task_Type_Declaration
(N
);
599 when N_Terminate_Alternative
=>
600 Analyze_Terminate_Alternative
(N
);
602 when N_Timed_Entry_Call
=>
603 Analyze_Timed_Entry_Call
(N
);
605 when N_Triggering_Alternative
=>
606 Analyze_Triggering_Alternative
(N
);
608 when N_Type_Conversion
=>
609 Analyze_Type_Conversion
(N
);
611 when N_Unchecked_Expression
=>
612 Analyze_Unchecked_Expression
(N
);
614 when N_Unchecked_Type_Conversion
=>
615 Analyze_Unchecked_Type_Conversion
(N
);
617 when N_Use_Package_Clause
=>
618 Analyze_Use_Package
(N
);
620 when N_Use_Type_Clause
=>
621 Analyze_Use_Type
(N
);
623 when N_Validate_Unchecked_Conversion
=>
626 when N_Variant_Part
=>
627 Analyze_Variant_Part
(N
);
629 when N_With_Clause
=>
630 Analyze_With_Clause
(N
);
632 -- A call to analyze a marker is ignored because the node does not
633 -- have any static and run-time semantics.
636 | N_Variable_Reference_Marker
640 -- A call to analyze the Empty node is an error, but most likely it
641 -- is an error caused by an attempt to analyze a malformed piece of
642 -- tree caused by some other error, so if there have been any other
643 -- errors, we just ignore it, otherwise it is a real internal error
644 -- which we complain about.
646 -- We must also consider the case of call to a runtime function that
647 -- is not available in the configurable runtime.
650 pragma Assert
(Serious_Errors_Detected
/= 0
651 or else Configurable_Run_Time_Violations
/= 0);
654 -- A call to analyze the error node is simply ignored, to avoid
655 -- causing cascaded errors (happens of course only in error cases)
656 -- Disable expansion in case it is still enabled, to prevent other
657 -- subsequent compiler glitches.
660 Expander_Mode_Save_And_Set
(False);
663 -- Push/Pop nodes normally don't come through an analyze call. An
664 -- exception is the dummy ones bracketing a subprogram body. In any
665 -- case there is nothing to be done to analyze such nodes.
667 when N_Push_Pop_xxx_Label
=>
670 -- SCIL nodes don't need analysis because they are decorated when
671 -- they are built. They are added to the tree by Insert_Actions and
672 -- the call to analyze them is generated when the full list is
675 when N_SCIL_Dispatch_Table_Tag_Init
676 | N_SCIL_Dispatching_Call
677 | N_SCIL_Membership_Test
681 -- A quantified expression with a missing "all" or "some" qualifier
682 -- looks identical to an iterated component association. By language
683 -- definition, the latter must be present within array aggregates. If
684 -- this is not the case, then the iterated component association is
685 -- really an illegal quantified expression. Diagnose this scenario.
687 when N_Iterated_Component_Association
=>
688 Diagnose_Iterated_Component_Association
(N
);
690 when N_Iterated_Element_Association
=>
691 null; -- May require a more precise error if misplaced.
693 -- For the remaining node types, we generate compiler abort, because
694 -- these nodes are always analyzed within the Sem_Chn routines and
695 -- there should never be a case of making a call to the main Analyze
696 -- routine for these node kinds. For example, an N_Access_Definition
697 -- node appears only in the context of a type declaration, and is
698 -- processed by the analyze routine for type declarations.
700 when N_Abortable_Part
701 | N_Access_Definition
702 | N_Access_Function_Definition
703 | N_Access_Procedure_Definition
704 | N_Access_To_Object_Definition
705 | N_Aspect_Specification
706 | N_Case_Expression_Alternative
707 | N_Case_Statement_Alternative
708 | N_Compilation_Unit_Aux
709 | N_Component_Association
711 | N_Component_Definition
713 | N_Constrained_Array_Definition
715 | N_Decimal_Fixed_Point_Definition
716 | N_Defining_Character_Literal
717 | N_Defining_Identifier
718 | N_Defining_Operator_Symbol
719 | N_Defining_Program_Unit_Name
721 | N_Derived_Type_Definition
723 | N_Digits_Constraint
724 | N_Discriminant_Association
725 | N_Discriminant_Specification
727 | N_Entry_Call_Statement
728 | N_Enumeration_Type_Definition
729 | N_Exception_Handler
730 | N_Floating_Point_Definition
731 | N_Formal_Decimal_Fixed_Point_Definition
732 | N_Formal_Derived_Type_Definition
733 | N_Formal_Discrete_Type_Definition
734 | N_Formal_Floating_Point_Definition
735 | N_Formal_Modular_Type_Definition
736 | N_Formal_Ordinary_Fixed_Point_Definition
737 | N_Formal_Private_Type_Definition
738 | N_Formal_Incomplete_Type_Definition
739 | N_Formal_Signed_Integer_Type_Definition
740 | N_Function_Specification
741 | N_Generic_Association
742 | N_Index_Or_Discriminant_Constraint
745 | N_Modular_Type_Definition
746 | N_Ordinary_Fixed_Point_Definition
747 | N_Parameter_Specification
748 | N_Pragma_Argument_Association
749 | N_Procedure_Specification
750 | N_Real_Range_Specification
751 | N_Record_Definition
752 | N_Signed_Integer_Type_Definition
753 | N_Unconstrained_Array_Definition
761 Debug_A_Exit
("analyzing ", N
, " (done)");
763 -- Mark relevant use-type and use-package clauses as effective
764 -- preferring the original node over the analyzed one in the case that
765 -- constant folding has occurred and removed references that need to be
766 -- examined. Also, if the node in question is overloaded then this is
767 -- deferred until resolution.
770 Operat
: Node_Id
:= Empty
;
772 -- Attempt to obtain a checkable operator node
774 if Nkind
(Original_Node
(N
)) in N_Op
then
775 Operat
:= Original_Node
(N
);
776 elsif Nkind
(N
) in N_Op
then
783 and then Present
(Entity
(Operat
))
784 and then not Is_Overloaded
(Operat
)
786 Mark_Use_Clauses
(Operat
);
790 -- Now that we have analyzed the node, we call the expander to perform
791 -- possible expansion. We skip this for subexpressions, because we don't
792 -- have the type yet, and the expander will need to know the type before
793 -- it can do its job. For subexpression nodes, the call to the expander
794 -- happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
795 -- which can appear in a statement context, and needs expanding now in
796 -- the case (distinguished by Etype, as documented in Sinfo).
798 -- The Analyzed flag is also set at this point for non-subexpression
799 -- nodes (in the case of subexpression nodes, we can't set the flag yet,
800 -- since resolution and expansion have not yet been completed). Note
801 -- that for N_Raise_xxx_Error we have to distinguish the expression
802 -- case from the statement case.
804 if Nkind
(N
) not in N_Subexpr
805 or else (Nkind
(N
) in N_Raise_xxx_Error
806 and then Etype
(N
) = Standard_Void_Type
)
810 -- Replace a reference to a renaming with the renamed object for SPARK.
811 -- In general this modification is performed by Expand_SPARK, however
812 -- certain constructs may not reach the resolution or expansion phase
813 -- and thus remain unchanged. The replacement is not performed when the
814 -- construct is overloaded as resolution must first take place. This is
815 -- also not done when analyzing a generic to preserve the original tree
816 -- and because the reference may become overloaded in the instance.
819 and then Nkind
(N
) in N_Expanded_Name | N_Identifier
820 and then not Is_Overloaded
(N
)
821 and then not Inside_A_Generic
823 Expand_SPARK_Potential_Renaming
(N
);
826 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
829 -- Version with check(s) suppressed
831 procedure Analyze
(N
: Node_Id
; Suppress
: Check_Id
) is
833 if Suppress
= All_Checks
then
835 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
837 Scope_Suppress
.Suppress
:= (others => True);
839 Scope_Suppress
.Suppress
:= Svs
;
844 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
846 Scope_Suppress
.Suppress
(Suppress
) := True;
848 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
857 procedure Analyze_List
(L
: List_Id
) is
862 while Present
(Node
) loop
868 -- Version with check(s) suppressed
870 procedure Analyze_List
(L
: List_Id
; Suppress
: Check_Id
) is
872 if Suppress
= All_Checks
then
874 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
876 Scope_Suppress
.Suppress
:= (others => True);
878 Scope_Suppress
.Suppress
:= Svs
;
883 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
885 Scope_Suppress
.Suppress
(Suppress
) := True;
887 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
892 --------------------------
893 -- Copy_Suppress_Status --
894 --------------------------
896 procedure Copy_Suppress_Status
902 pragma Warnings
(Off
, Found
);
904 procedure Search_Stack
905 (Top
: Suppress_Stack_Entry_Ptr
;
906 Found
: out Boolean);
907 -- Search given suppress stack for matching entry for entity. If found
908 -- then set Checks_May_Be_Suppressed on To, and push an appropriate
909 -- entry for To onto the local suppress stack.
915 procedure Search_Stack
916 (Top
: Suppress_Stack_Entry_Ptr
;
919 Ptr
: Suppress_Stack_Entry_Ptr
;
923 while Ptr
/= null loop
925 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
928 Set_Checks_May_Be_Suppressed
(To
, True);
929 Push_Local_Suppress_Stack_Entry
945 -- Start of processing for Copy_Suppress_Status
948 if not Checks_May_Be_Suppressed
(From
) then
952 -- First search the global entity suppress table for a matching entry.
953 -- We also search this in reverse order so that if there are multiple
954 -- pragmas for the same entity, the last one applies.
956 Search_Stack
(Global_Suppress_Stack_Top
, Found
);
962 -- Now search the local entity suppress stack, we search this in
963 -- reverse order so that we get the innermost entry that applies to
964 -- this case if there are nested entries. Note that for the purpose
965 -- of this procedure we are ONLY looking for entries corresponding
966 -- to a two-argument Suppress, where the second argument matches From.
968 Search_Stack
(Local_Suppress_Stack_Top
, Found
);
969 end Copy_Suppress_Status
;
971 -------------------------
972 -- Enter_Generic_Scope --
973 -------------------------
975 procedure Enter_Generic_Scope
(S
: Entity_Id
) is
977 if No
(Outer_Generic_Scope
) then
978 Outer_Generic_Scope
:= S
;
980 end Enter_Generic_Scope
;
982 ------------------------
983 -- Exit_Generic_Scope --
984 ------------------------
986 procedure Exit_Generic_Scope
(S
: Entity_Id
) is
988 if S
= Outer_Generic_Scope
then
989 Outer_Generic_Scope
:= Empty
;
991 end Exit_Generic_Scope
;
993 -----------------------
994 -- Explicit_Suppress --
995 -----------------------
997 function Explicit_Suppress
(E
: Entity_Id
; C
: Check_Id
) return Boolean is
998 Ptr
: Suppress_Stack_Entry_Ptr
;
1001 if not Checks_May_Be_Suppressed
(E
) then
1005 Ptr
:= Global_Suppress_Stack_Top
;
1006 while Ptr
/= null loop
1008 and then (Ptr
.Check
= All_Checks
or else Ptr
.Check
= C
)
1010 return Ptr
.Suppress
;
1018 end Explicit_Suppress
;
1020 -----------------------------
1021 -- External_Ref_In_Generic --
1022 -----------------------------
1024 function External_Ref_In_Generic
(E
: Entity_Id
) return Boolean is
1028 -- Entity is global if defined outside of current Outer_Generic_Scope:
1029 -- Either the entity has a smaller depth than the outer generic, or it
1030 -- is in a different compilation unit, or it is defined within a unit
1031 -- in the same compilation, that is not within the outer generic.
1033 if No
(Outer_Generic_Scope
) then
1036 -- It makes no sense to compare depths if not in same unit. Scope_Depth
1037 -- is not set for inherited operations.
1039 elsif not In_Same_Source_Unit
(E
, Outer_Generic_Scope
)
1040 or else not Scope_Depth_Set
(Scope
(E
))
1041 or else Scope_Depth
(Scope
(E
)) < Scope_Depth
(Outer_Generic_Scope
)
1047 while Present
(Scop
) loop
1048 if Scop
= Outer_Generic_Scope
then
1050 elsif Scope_Depth
(Scop
) < Scope_Depth
(Outer_Generic_Scope
) then
1053 Scop
:= Scope
(Scop
);
1059 end External_Ref_In_Generic
;
1065 procedure Initialize
is
1066 Next
: Suppress_Stack_Entry_Ptr
;
1068 procedure Free
is new Ada
.Unchecked_Deallocation
1069 (Suppress_Stack_Entry
, Suppress_Stack_Entry_Ptr
);
1072 -- Free any global suppress stack entries from a previous invocation
1073 -- of the compiler (in the normal case this loop does nothing).
1075 while Suppress_Stack_Entries
/= null loop
1076 Next
:= Suppress_Stack_Entries
.Next
;
1077 Free
(Suppress_Stack_Entries
);
1078 Suppress_Stack_Entries
:= Next
;
1081 Local_Suppress_Stack_Top
:= null;
1082 Global_Suppress_Stack_Top
:= null;
1084 -- Clear scope stack, and reset global variables
1087 Unloaded_Subunits
:= False;
1090 ------------------------------
1091 -- Insert_After_And_Analyze --
1092 ------------------------------
1094 procedure Insert_After_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
1100 -- If we are not at the end of the list, then the easiest
1101 -- coding is simply to insert before our successor.
1103 if Present
(Next
(N
)) then
1104 Insert_Before_And_Analyze
(Next
(N
), M
);
1106 -- Case of inserting at the end of the list
1109 -- Capture the Node_Id of the node to be inserted. This Node_Id
1110 -- will still be the same after the insert operation.
1113 Insert_After
(N
, M
);
1115 -- Now just analyze from the inserted node to the end of
1116 -- the new list (note that this properly handles the case
1117 -- where any of the analyze calls result in the insertion of
1118 -- nodes after the analyzed node, expecting analysis).
1120 while Present
(Node
) loop
1122 Mark_Rewrite_Insertion
(Node
);
1127 end Insert_After_And_Analyze
;
1129 -- Version with check(s) suppressed
1131 procedure Insert_After_And_Analyze
1134 Suppress
: Check_Id
)
1137 if Suppress
= All_Checks
then
1139 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1141 Scope_Suppress
.Suppress
:= (others => True);
1142 Insert_After_And_Analyze
(N
, M
);
1143 Scope_Suppress
.Suppress
:= Svs
;
1148 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1150 Scope_Suppress
.Suppress
(Suppress
) := True;
1151 Insert_After_And_Analyze
(N
, M
);
1152 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1155 end Insert_After_And_Analyze
;
1157 -------------------------------
1158 -- Insert_Before_And_Analyze --
1159 -------------------------------
1161 procedure Insert_Before_And_Analyze
(N
: Node_Id
; M
: Node_Id
) is
1167 -- Capture the Node_Id of the first list node to be inserted.
1168 -- This will still be the first node after the insert operation,
1169 -- since Insert_List_After does not modify the Node_Id values.
1172 Insert_Before
(N
, M
);
1174 -- The insertion does not change the Id's of any of the nodes in
1175 -- the list, and they are still linked, so we can simply loop from
1176 -- the original first node until we meet the node before which the
1177 -- insertion is occurring. Note that this properly handles the case
1178 -- where any of the analyzed nodes insert nodes after themselves,
1179 -- expecting them to get analyzed.
1181 while Node
/= N
loop
1183 Mark_Rewrite_Insertion
(Node
);
1187 end Insert_Before_And_Analyze
;
1189 -- Version with check(s) suppressed
1191 procedure Insert_Before_And_Analyze
1194 Suppress
: Check_Id
)
1197 if Suppress
= All_Checks
then
1199 Svs
: constant Suppress_Array
:= Scope_Suppress
.Suppress
;
1201 Scope_Suppress
.Suppress
:= (others => True);
1202 Insert_Before_And_Analyze
(N
, M
);
1203 Scope_Suppress
.Suppress
:= Svs
;
1208 Svg
: constant Boolean := Scope_Suppress
.Suppress
(Suppress
);
1210 Scope_Suppress
.Suppress
(Suppress
) := True;
1211 Insert_Before_And_Analyze
(N
, M
);
1212 Scope_Suppress
.Suppress
(Suppress
) := Svg
;
1215 end Insert_Before_And_Analyze
;
1217 --------------------------------------------
1218 -- Insert_Before_First_Source_Declaration --
1219 --------------------------------------------
1221 procedure Insert_Before_First_Source_Declaration
1227 -- Inspect the declarations of the related subprogram body looking for
1228 -- the first source declaration.
1230 pragma Assert
(Present
(Decls
));
1232 Decl
:= First
(Decls
);
1233 while Present
(Decl
) loop
1234 if Comes_From_Source
(Decl
) then
1235 Insert_Before
(Decl
, Stmt
);
1242 -- If we get there, then the subprogram body lacks any source
1243 -- declarations. The body of _Postconditions now acts as the
1244 -- last declaration.
1246 Append
(Stmt
, Decls
);
1247 end Insert_Before_First_Source_Declaration
;
1249 -----------------------------------
1250 -- Insert_List_After_And_Analyze --
1251 -----------------------------------
1253 procedure Insert_List_After_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1254 After
: constant Node_Id
:= Next
(N
);
1258 if Is_Non_Empty_List
(L
) then
1260 -- Capture the Node_Id of the first list node to be inserted.
1261 -- This will still be the first node after the insert operation,
1262 -- since Insert_List_After does not modify the Node_Id values.
1265 Insert_List_After
(N
, L
);
1267 -- Now just analyze from the original first node until we get to the
1268 -- successor of the original insertion point (which may be Empty if
1269 -- the insertion point was at the end of the list). Note that this
1270 -- properly handles the case where any of the analyze calls result in
1271 -- the insertion of nodes after the analyzed node (possibly calling
1272 -- this routine recursively).
1274 while Node
/= After
loop
1276 Mark_Rewrite_Insertion
(Node
);
1280 end Insert_List_After_And_Analyze
;
1282 ------------------------------------
1283 -- Insert_List_Before_And_Analyze --
1284 ------------------------------------
1286 procedure Insert_List_Before_And_Analyze
(N
: Node_Id
; L
: List_Id
) is
1290 if Is_Non_Empty_List
(L
) then
1292 -- Capture the Node_Id of the first list node to be inserted. This
1293 -- will still be the first node after the insert operation, since
1294 -- Insert_List_After does not modify the Node_Id values.
1297 Insert_List_Before
(N
, L
);
1299 -- The insertion does not change the Id's of any of the nodes in
1300 -- the list, and they are still linked, so we can simply loop from
1301 -- the original first node until we meet the node before which the
1302 -- insertion is occurring. Note that this properly handles the case
1303 -- where any of the analyzed nodes insert nodes after themselves,
1304 -- expecting them to get analyzed.
1306 while Node
/= N
loop
1308 Mark_Rewrite_Insertion
(Node
);
1312 end Insert_List_Before_And_Analyze
;
1320 Scope_Stack
.Release
;
1321 Scope_Stack
.Locked
:= True;
1324 ------------------------
1325 -- Preanalysis_Active --
1326 ------------------------
1328 function Preanalysis_Active
return Boolean is
1330 return not Full_Analysis
and not Expander_Active
;
1331 end Preanalysis_Active
;
1337 procedure Preanalyze
(N
: Node_Id
) is
1338 Save_Full_Analysis
: constant Boolean := Full_Analysis
;
1341 Full_Analysis
:= False;
1342 Expander_Mode_Save_And_Set
(False);
1344 -- See comment in sem_res.adb for Preanalyze_And_Resolve
1347 or else Nkind
(Parent
(N
)) = N_Simple_Return_Statement
1351 Analyze
(N
, Suppress
=> All_Checks
);
1354 Expander_Mode_Restore
;
1355 Full_Analysis
:= Save_Full_Analysis
;
1358 --------------------------------------
1359 -- Push_Global_Suppress_Stack_Entry --
1360 --------------------------------------
1362 procedure Push_Global_Suppress_Stack_Entry
1363 (Entity
: Entity_Id
;
1368 Global_Suppress_Stack_Top
:=
1369 new Suppress_Stack_Entry
'
1372 Suppress => Suppress,
1373 Prev => Global_Suppress_Stack_Top,
1374 Next => Suppress_Stack_Entries);
1375 Suppress_Stack_Entries := Global_Suppress_Stack_Top;
1377 end Push_Global_Suppress_Stack_Entry;
1379 -------------------------------------
1380 -- Push_Local_Suppress_Stack_Entry --
1381 -------------------------------------
1383 procedure Push_Local_Suppress_Stack_Entry
1384 (Entity : Entity_Id;
1389 Local_Suppress_Stack_Top :=
1390 new Suppress_Stack_Entry'
1393 Suppress
=> Suppress
,
1394 Prev
=> Local_Suppress_Stack_Top
,
1395 Next
=> Suppress_Stack_Entries
);
1396 Suppress_Stack_Entries
:= Local_Suppress_Stack_Top
;
1399 end Push_Local_Suppress_Stack_Entry
;
1405 procedure Semantics
(Comp_Unit
: Node_Id
) is
1406 procedure Do_Analyze
;
1407 -- Perform the analysis of the compilation unit
1413 -- WARNING: This routine manages Ghost regions. Return statements must
1414 -- be replaced by gotos which jump to the end of the routine and restore
1417 procedure Do_Analyze
is
1418 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
1419 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
1420 Saved_ISMP
: constant Boolean :=
1421 Ignore_SPARK_Mode_Pragmas_In_Instance
;
1422 -- Save Ghost and SPARK mode-related data to restore on exit
1424 -- Generally style checks are preserved across compilations, with
1425 -- one exception: s-oscons.ads, which allows arbitrary long lines
1426 -- unconditionally, and has no restore mechanism, because it is
1427 -- intended as a lowest-level Pure package.
1429 Saved_ML
: constant Int
:= Style_Max_Line_Length
;
1430 Saved_CML
: constant Boolean := Style_Check_Max_Line_Length
;
1435 List
:= Save_Scope_Stack
;
1436 Push_Scope
(Standard_Standard
);
1438 -- Set up a clean environment before analyzing
1440 Install_Ghost_Region
(None
, Empty
);
1441 Ignore_SPARK_Mode_Pragmas_In_Instance
:= False;
1443 Outer_Generic_Scope
:= Empty
;
1444 Scope_Suppress
:= Suppress_Options
;
1446 (Scope_Stack
.Last
).Component_Alignment_Default
:=
1447 Configuration_Component_Alignment
;
1449 (Scope_Stack
.Last
).Is_Active_Stack_Base
:= True;
1451 -- Now analyze the top level compilation unit node
1453 Analyze
(Comp_Unit
);
1455 -- Check for scope mismatch on exit from compilation
1457 pragma Assert
(Current_Scope
= Standard_Standard
1458 or else Comp_Unit
= Cunit
(Main_Unit
));
1460 -- Then pop entry for Standard, and pop implicit types
1463 Restore_Scope_Stack
(List
);
1464 Style_Max_Line_Length
:= Saved_ML
;
1465 Style_Check_Max_Line_Length
:= Saved_CML
;
1467 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
1468 Ignore_SPARK_Mode_Pragmas_In_Instance
:= Saved_ISMP
;
1473 -- The following locations save the corresponding global flags and
1474 -- variables so that they can be restored on completion. This is needed
1475 -- so that calls to Rtsfind start with the proper default values for
1476 -- these variables, and also that such calls do not disturb the settings
1477 -- for units being analyzed at a higher level.
1479 S_Current_Sem_Unit
: constant Unit_Number_Type
:= Current_Sem_Unit
;
1480 S_Full_Analysis
: constant Boolean := Full_Analysis
;
1481 S_GNAT_Mode
: constant Boolean := GNAT_Mode
;
1482 S_Global_Dis_Names
: constant Boolean := Global_Discard_Names
;
1483 S_In_Assertion_Expr
: constant Nat
:= In_Assertion_Expr
;
1484 S_In_Declare_Expr
: constant Nat
:= In_Declare_Expr
;
1485 S_In_Default_Expr
: constant Boolean := In_Default_Expr
;
1486 S_In_Spec_Expr
: constant Boolean := In_Spec_Expression
;
1487 S_Inside_A_Generic
: constant Boolean := Inside_A_Generic
;
1488 S_Outer_Gen_Scope
: constant Entity_Id
:= Outer_Generic_Scope
;
1489 S_Style_Check
: constant Boolean := Style_Check
;
1491 Already_Analyzed
: constant Boolean := Analyzed
(Comp_Unit
);
1493 Curunit
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(Comp_Unit
);
1494 -- New value of Current_Sem_Unit
1496 Generic_Main
: constant Boolean :=
1497 Nkind
(Unit
(Cunit
(Main_Unit
))) in N_Generic_Declaration
;
1498 -- If the main unit is generic, every compiled unit, including its
1499 -- context, is compiled with expansion disabled.
1501 Is_Main_Unit_Or_Main_Unit_Spec
: constant Boolean :=
1504 (Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
1505 and then Library_Unit
(Cunit
(Main_Unit
)) = Cunit
(Curunit
));
1506 -- Configuration flags have special settings when compiling a predefined
1507 -- file as a main unit. This applies to its spec as well.
1509 Ext_Main_Source_Unit
: constant Boolean :=
1510 In_Extended_Main_Source_Unit
(Comp_Unit
);
1511 -- Determine if unit is in extended main source unit
1513 Save_Config_Attrs
: Config_Switches_Type
;
1514 -- Variable used to save values of config switches while we analyze the
1515 -- new unit, to be restored on exit for proper recursive behavior.
1517 Save_Cunit_Restrictions
: Save_Cunit_Boolean_Restrictions
;
1518 -- Used to save non-partition wide restrictions before processing new
1519 -- unit. All with'ed units are analyzed with config restrictions reset
1520 -- and we need to restore these saved values at the end.
1522 Save_Preanalysis_Counter
: constant Nat
:=
1523 Inside_Preanalysis_Without_Freezing
;
1524 -- Saves the preanalysis nesting-level counter; required since we may
1525 -- need to analyze a unit as a consequence of the preanalysis of an
1526 -- expression without freezing (and the loaded unit must be fully
1529 -- Start of processing for Semantics
1532 Inside_Preanalysis_Without_Freezing
:= 0;
1534 if Debug_Unit_Walk
then
1535 if Already_Analyzed
then
1536 Write_Str
("(done)");
1540 (Get_Cunit_Unit_Number
(Comp_Unit
),
1546 Compiler_State
:= Analyzing
;
1547 Current_Sem_Unit
:= Curunit
;
1549 -- Compile predefined units with GNAT_Mode set to True, to properly
1550 -- process the categorization stuff. However, do not set GNAT_Mode
1551 -- to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
1552 -- Sequential_IO) as this would prevent pragma Extend_System from being
1553 -- taken into account, for example when Text_IO is renaming DEC.Text_IO.
1555 if Is_Predefined_Unit
(Current_Sem_Unit
)
1556 and then not Is_Predefined_Renaming
(Current_Sem_Unit
)
1561 -- For generic main, never do expansion
1563 if Generic_Main
then
1564 Expander_Mode_Save_And_Set
(False);
1569 Expander_Mode_Save_And_Set
1571 -- Turn on expansion if generating code
1573 (Operating_Mode
= Generate_Code
1575 -- Or if special debug flag -gnatdx is set
1577 or else Debug_Flag_X
1579 -- Or if in configuration run-time mode. We do this so we get
1580 -- error messages about missing entities in the run-time even
1581 -- if we are compiling in -gnatc (no code generation) mode.
1582 -- Similar processing applies to No_Run_Time_Mode. However,
1583 -- don't do this if debug flag -gnatd.Z is set or when we are
1584 -- compiling a separate unit (this is to handle a situation
1585 -- where this new processing causes trouble).
1588 ((Configurable_Run_Time_Mode
or No_Run_Time_Mode
)
1589 and then not Debug_Flag_Dot_ZZ
1590 and then Nkind
(Unit
(Cunit
(Main_Unit
))) /= N_Subunit
));
1593 Full_Analysis
:= True;
1594 Inside_A_Generic
:= False;
1595 In_Assertion_Expr
:= 0;
1596 In_Declare_Expr
:= 0;
1597 In_Default_Expr
:= False;
1598 In_Spec_Expression
:= False;
1599 Set_Comes_From_Source_Default
(False);
1601 -- Save current config switches and reset then appropriately
1603 Save_Config_Attrs
:= Save_Config_Switches
;
1605 (Is_Internal_Unit
(Current_Sem_Unit
),
1606 Is_Main_Unit_Or_Main_Unit_Spec
);
1608 -- Save current non-partition-wide restrictions
1610 Save_Cunit_Restrictions
:= Cunit_Boolean_Restrictions_Save
;
1612 -- For unit in main extended unit, we reset the configuration values
1613 -- for the non-partition-wide restrictions. For other units reset them.
1615 if Ext_Main_Source_Unit
then
1616 Restore_Config_Cunit_Boolean_Restrictions
;
1618 Reset_Cunit_Boolean_Restrictions
;
1621 -- Turn off style checks for unit that is not in the extended main
1622 -- source unit. This improves processing efficiency for such units
1623 -- (for which we don't want style checks anyway, and where they will
1624 -- get suppressed), and is definitely needed to stop some style checks
1625 -- from invading the run-time units (e.g. overriding checks).
1627 if not Ext_Main_Source_Unit
then
1628 Style_Check
:= False;
1630 -- If this is part of the extended main source unit, set style check
1631 -- mode to match the style check mode of the main source unit itself.
1634 Style_Check
:= Style_Check_Main
;
1637 -- Only do analysis of unit that has not already been analyzed
1639 if not Analyzed
(Comp_Unit
) then
1640 Initialize_Version
(Current_Sem_Unit
);
1642 -- Do analysis, and then append the compilation unit onto the
1643 -- Comp_Unit_List, if appropriate. This is done after analysis,
1644 -- so if this unit depends on some others, they have already been
1645 -- appended. We ignore bodies, except for the main unit itself, and
1646 -- for subprogram bodies that act as specs. We have also to guard
1647 -- against ill-formed subunits that have an improper context.
1651 if Present
(Comp_Unit
)
1652 and then Nkind
(Unit
(Comp_Unit
)) in N_Proper_Body
1653 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Subprogram_Body
1654 or else not Acts_As_Spec
(Comp_Unit
))
1655 and then not Ext_Main_Source_Unit
1660 Append_New_Elmt
(Comp_Unit
, To
=> Comp_Unit_List
);
1662 if Debug_Unit_Walk
then
1663 Write_Str
("Appending ");
1665 (Get_Cunit_Unit_Number
(Comp_Unit
), Unit
(Comp_Unit
));
1670 -- Save indication of dynamic elaboration checks for ALI file
1672 Set_Dynamic_Elab
(Current_Sem_Unit
, Dynamic_Elaboration_Checks
);
1674 -- Restore settings of saved switches to entry values
1676 Current_Sem_Unit
:= S_Current_Sem_Unit
;
1677 Full_Analysis
:= S_Full_Analysis
;
1678 Global_Discard_Names
:= S_Global_Dis_Names
;
1679 GNAT_Mode
:= S_GNAT_Mode
;
1680 In_Assertion_Expr
:= S_In_Assertion_Expr
;
1681 In_Declare_Expr
:= S_In_Declare_Expr
;
1682 In_Default_Expr
:= S_In_Default_Expr
;
1683 In_Spec_Expression
:= S_In_Spec_Expr
;
1684 Inside_A_Generic
:= S_Inside_A_Generic
;
1685 Outer_Generic_Scope
:= S_Outer_Gen_Scope
;
1686 Style_Check
:= S_Style_Check
;
1688 Restore_Config_Switches
(Save_Config_Attrs
);
1690 -- Deal with restore of restrictions
1692 Cunit_Boolean_Restrictions_Restore
(Save_Cunit_Restrictions
);
1694 Expander_Mode_Restore
;
1696 if Debug_Unit_Walk
then
1699 if Already_Analyzed
then
1700 Write_Str
("(done)");
1704 (Get_Cunit_Unit_Number
(Comp_Unit
),
1709 Inside_Preanalysis_Without_Freezing
:= Save_Preanalysis_Counter
;
1716 function ss
(Index
: Int
) return Scope_Stack_Entry
is
1718 return Scope_Stack
.Table
(Index
);
1725 function sst
return Scope_Stack_Entry
is
1727 return ss
(Scope_Stack
.Last
);
1736 Scope_Stack
.Locked
:= False;
1739 ------------------------
1740 -- Walk_Library_Items --
1741 ------------------------
1743 procedure Walk_Library_Items
is
1744 type Unit_Number_Set
is array (Main_Unit
.. Last_Unit
) of Boolean;
1745 pragma Pack
(Unit_Number_Set
);
1747 Main_CU
: constant Node_Id
:= Cunit
(Main_Unit
);
1748 Spec_CU
: Node_Id
:= Empty
;
1750 Seen
, Done
: Unit_Number_Set
:= (others => False);
1751 -- Seen (X) is True after we have seen unit X in the walk. This is used
1752 -- to prevent processing the same unit more than once. Done (X) is True
1753 -- after we have fully processed X, and is used only for debugging
1754 -- printouts and assertions.
1756 Do_Main
: Boolean := False;
1757 -- Flag to delay processing the main body until after all other units.
1758 -- This is needed because the spec of the main unit may appear in the
1759 -- context of some other unit. We do not want this to force processing
1760 -- of the main body before all other units have been processed.
1762 -- Another circularity pattern occurs when the main unit is a child unit
1763 -- and the body of an ancestor has a with-clause of the main unit or on
1764 -- one of its children. In both cases the body in question has a with-
1765 -- clause on the main unit, and must be excluded from the traversal. In
1766 -- some convoluted cases this may lead to a CodePeer error because the
1767 -- spec of a subprogram declared in an instance within the parent will
1768 -- not be seen in the main unit.
1770 function Depends_On_Main
(CU
: Node_Id
) return Boolean;
1771 -- The body of a unit that is withed by the spec of the main unit may in
1772 -- turn have a with_clause on that spec. In that case do not traverse
1773 -- the body, to prevent loops. It can also happen that the main body has
1774 -- a with_clause on a child, which of course has an implicit with on its
1775 -- parent. It's OK to traverse the child body if the main spec has been
1776 -- processed, otherwise we also have a circularity to avoid.
1778 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
);
1779 -- Calls Action, with some validity checks
1781 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
);
1782 -- Calls Do_Action, first on the units with'ed by this one, then on
1783 -- this unit. If it's an instance body, do the spec first. If it is
1784 -- an instance spec, do the body last.
1786 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
);
1787 -- Apply Do_Unit_And_Dependents to a unit in a context clause
1789 procedure Process_Bodies_In_Context
(Comp
: Node_Id
);
1790 -- The main unit and its spec may depend on bodies that contain generics
1791 -- that are instantiated in them. Iterate through the corresponding
1792 -- contexts before processing main (spec/body) itself, to process bodies
1793 -- that may be present, together with their context. The spec of main
1794 -- is processed wherever it appears in the list of units, while the body
1795 -- is processed as the last unit in the list.
1797 ---------------------
1798 -- Depends_On_Main --
1799 ---------------------
1801 function Depends_On_Main
(CU
: Node_Id
) return Boolean is
1803 MCU
: constant Node_Id
:= Unit
(Main_CU
);
1806 -- Problem does not arise with main subprograms
1808 if Nkind
(MCU
) not in N_Package_Body | N_Package_Declaration
then
1812 CL
:= First
(Context_Items
(CU
));
1814 while Present
(CL
) loop
1815 if Nkind
(CL
) = N_With_Clause
1816 and then Library_Unit
(CL
) = Main_CU
1817 and then not Done
(Get_Cunit_Unit_Number
(Library_Unit
(CL
)))
1826 end Depends_On_Main
;
1832 procedure Do_Action
(CU
: Node_Id
; Item
: Node_Id
) is
1834 -- This calls Action at the end. All the preceding code is just
1835 -- assertions and debugging output.
1837 pragma Assert
(No
(CU
) or else Nkind
(CU
) = N_Compilation_Unit
);
1839 case Nkind
(Item
) is
1840 when N_Generic_Function_Renaming_Declaration
1841 | N_Generic_Package_Declaration
1842 | N_Generic_Package_Renaming_Declaration
1843 | N_Generic_Procedure_Renaming_Declaration
1844 | N_Generic_Subprogram_Declaration
1845 | N_Package_Declaration
1846 | N_Package_Renaming_Declaration
1847 | N_Subprogram_Declaration
1848 | N_Subprogram_Renaming_Declaration
1854 when N_Package_Body
=>
1856 -- Package bodies are processed separately if the main unit
1861 when N_Subprogram_Body
=>
1863 -- A subprogram body must be the main unit
1865 pragma Assert
(Acts_As_Spec
(CU
) or else CU
= Main_CU
);
1868 when N_Function_Instantiation
1869 | N_Package_Instantiation
1870 | N_Procedure_Instantiation
1872 -- Can only happen if some generic body (needed for gnat2scil
1873 -- traversal, but not by GNAT) is not available, ignore.
1877 -- All other cases cannot happen
1880 pragma Assert
(False, "subunit");
1883 when N_Null_Statement
=>
1885 -- Do not call Action for an ignored ghost unit
1887 pragma Assert
(Is_Ignored_Ghost_Node
(Original_Node
(Item
)));
1891 pragma Assert
(False);
1895 if Present
(CU
) then
1896 pragma Assert
(Item
/= Stand
.Standard_Package_Node
);
1897 pragma Assert
(Item
= Unit
(CU
));
1900 Unit_Num
: constant Unit_Number_Type
:=
1901 Get_Cunit_Unit_Number
(CU
);
1903 procedure Assert_Done
(Withed_Unit
: Node_Id
);
1904 -- Assert Withed_Unit is already Done, unless it's a body. It
1905 -- might seem strange for a with_clause to refer to a body, but
1906 -- this happens in the case of a generic instantiation, which
1907 -- gets transformed into the instance body (and the instance
1908 -- spec is also created). With clauses pointing to the
1909 -- instantiation end up pointing to the instance body.
1915 procedure Assert_Done
(Withed_Unit
: Node_Id
) is
1917 if Withed_Unit
/= Main_CU
1918 and then not Done
(Get_Cunit_Unit_Number
(Withed_Unit
))
1920 -- N_Null_Statement will happen in case of a ghost unit
1921 -- which gets rewritten.
1923 if Nkind
(Unit
(Withed_Unit
)) not in
1924 N_Generic_Package_Declaration |
1926 N_Package_Renaming_Declaration |
1931 (Unit_Name
(Get_Cunit_Unit_Number
(Withed_Unit
)));
1932 Write_Str
(" not yet walked!");
1934 if Get_Cunit_Unit_Number
(Withed_Unit
) = Unit_Num
then
1935 Write_Str
(" (self-ref)");
1940 pragma Assert
(False);
1945 procedure Assert_Withed_Units_Done
is
1946 new Walk_Withs
(Assert_Done
);
1949 if Debug_Unit_Walk
then
1950 Write_Unit_Info
(Unit_Num
, Item
, Withs
=> True);
1953 -- Main unit should come last, except in the case where we
1954 -- skipped System_Aux_Id, in which case we missed the things it
1955 -- depends on, and in the case of parent bodies if present.
1958 (not Done
(Main_Unit
)
1959 or else Present
(System_Aux_Id
)
1960 or else Nkind
(Item
) = N_Package_Body
);
1962 -- We shouldn't do the same thing twice
1964 pragma Assert
(not Done
(Unit_Num
));
1966 -- Everything we depend upon should already be done
1969 (Assert_Withed_Units_Done
(CU
, Include_Limited
=> False));
1973 -- Must be Standard, which has no entry in the units table
1975 pragma Assert
(Item
= Stand
.Standard_Package_Node
);
1977 if Debug_Unit_Walk
then
1978 Write_Line
("Standard");
1985 --------------------
1986 -- Do_Withed_Unit --
1987 --------------------
1989 procedure Do_Withed_Unit
(Withed_Unit
: Node_Id
) is
1991 Do_Unit_And_Dependents
(Withed_Unit
, Unit
(Withed_Unit
));
1993 -- If the unit in the with_clause is a generic instance, the clause
1994 -- now denotes the instance body. Traverse the corresponding spec
1995 -- because there may be no other dependence that will force the
1996 -- traversal of its own context.
1998 if Nkind
(Unit
(Withed_Unit
)) = N_Package_Body
1999 and then Is_Generic_Instance
2000 (Defining_Entity
(Unit
(Library_Unit
(Withed_Unit
))))
2002 Do_Withed_Unit
(Library_Unit
(Withed_Unit
));
2006 ----------------------------
2007 -- Do_Unit_And_Dependents --
2008 ----------------------------
2010 procedure Do_Unit_And_Dependents
(CU
: Node_Id
; Item
: Node_Id
) is
2011 Unit_Num
: constant Unit_Number_Type
:= Get_Cunit_Unit_Number
(CU
);
2013 Body_U
: Unit_Number_Type
;
2014 Parent_CU
: Node_Id
;
2016 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
2019 if not Seen
(Unit_Num
) then
2021 -- Process the with clauses
2023 Do_Withed_Units
(CU
, Include_Limited
=> False);
2025 -- Process the unit if it is a spec or the main unit, if it
2026 -- has no previous spec or we have done all other units.
2028 if Nkind
(Item
) not in N_Package_Body | N_Subprogram_Body
2029 or else Acts_As_Spec
(CU
)
2031 if CU
= Main_CU
and then not Do_Main
then
2032 Seen
(Unit_Num
) := False;
2035 Seen
(Unit_Num
) := True;
2037 if CU
= Library_Unit
(Main_CU
) then
2038 Process_Bodies_In_Context
(CU
);
2040 -- If main is a child unit, examine parent unit contexts
2041 -- to see if they include instantiated units. Also, if
2042 -- the parent itself is an instance, process its body
2043 -- because it may contain subprograms that are called
2044 -- in the main unit.
2046 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
2047 Child
:= Cunit_Entity
(Main_Unit
);
2048 while Is_Child_Unit
(Child
) loop
2051 (Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
2052 Process_Bodies_In_Context
(Parent_CU
);
2054 if Nkind
(Unit
(Parent_CU
)) = N_Package_Body
2056 Nkind
(Original_Node
(Unit
(Parent_CU
)))
2057 = N_Package_Instantiation
2059 not Seen
(Get_Cunit_Unit_Number
(Parent_CU
))
2061 Body_U
:= Get_Cunit_Unit_Number
(Parent_CU
);
2062 Seen
(Body_U
) := True;
2063 Do_Action
(Parent_CU
, Unit
(Parent_CU
));
2064 Done
(Body_U
) := True;
2067 Child
:= Scope
(Child
);
2072 Do_Action
(CU
, Item
);
2073 Done
(Unit_Num
) := True;
2077 end Do_Unit_And_Dependents
;
2079 -------------------------------
2080 -- Process_Bodies_In_Context --
2081 -------------------------------
2083 procedure Process_Bodies_In_Context
(Comp
: Node_Id
) is
2085 Body_U
: Unit_Number_Type
;
2089 procedure Do_Withed_Units
is new Walk_Withs
(Do_Withed_Unit
);
2091 -- Start of processing for Process_Bodies_In_Context
2094 Clause
:= First
(Context_Items
(Comp
));
2095 while Present
(Clause
) loop
2096 if Nkind
(Clause
) = N_With_Clause
then
2097 Spec
:= Library_Unit
(Clause
);
2098 Body_CU
:= Library_Unit
(Spec
);
2100 -- If we are processing the spec of the main unit, load bodies
2101 -- only if the with_clause indicates that it forced the loading
2102 -- of the body for a generic instantiation. Note that bodies of
2103 -- parents that are instances have been loaded already.
2105 if Present
(Body_CU
)
2106 and then Body_CU
/= Main_CU
2107 and then Nkind
(Unit
(Body_CU
)) /= N_Subprogram_Body
2108 and then Nkind
(Unit
(Comp
)) /= N_Package_Declaration
2110 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
2112 if not Seen
(Body_U
)
2113 and then not Depends_On_Main
(Body_CU
)
2115 Seen
(Body_U
) := True;
2116 Do_Withed_Units
(Body_CU
, Include_Limited
=> False);
2117 Do_Action
(Body_CU
, Unit
(Body_CU
));
2118 Done
(Body_U
) := True;
2125 end Process_Bodies_In_Context
;
2127 -- Local Declarations
2131 -- Start of processing for Walk_Library_Items
2134 if Debug_Unit_Walk
then
2135 Write_Line
("Walk_Library_Items:");
2139 -- Do Standard first, then walk the Comp_Unit_List
2141 Do_Action
(Empty
, Standard_Package_Node
);
2143 -- First place the context of all instance bodies on the corresponding
2144 -- spec, because it may be needed to analyze the code at the place of
2145 -- the instantiation.
2147 Cur
:= First_Elmt
(Comp_Unit_List
);
2148 while Present
(Cur
) loop
2150 CU
: constant Node_Id
:= Node
(Cur
);
2151 N
: constant Node_Id
:= Unit
(CU
);
2154 if Nkind
(N
) = N_Package_Body
2155 and then Is_Generic_Instance
(Defining_Entity
(N
))
2158 (Context_Items
(CU
), Context_Items
(Library_Unit
(CU
)));
2165 -- Now traverse compilation units (specs) in order
2167 Cur
:= First_Elmt
(Comp_Unit_List
);
2168 while Present
(Cur
) loop
2170 CU
: constant Node_Id
:= Node
(Cur
);
2171 N
: constant Node_Id
:= Unit
(CU
);
2175 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2179 -- If it is a subprogram body, process it if it has no
2182 -- If it's a package body, ignore it, unless it is a body
2183 -- created for an instance that is the main unit. In the case
2184 -- of subprograms, the body is the wrapper package. In case of
2185 -- a package, the original file carries the body, and the spec
2186 -- appears as a later entry in the units list.
2188 -- Otherwise bodies appear in the list only because of inlining
2189 -- or instantiations, and they are processed only if relevant.
2190 -- The flag Withed_Body on a context clause indicates that a
2191 -- unit contains an instantiation that may be needed later,
2192 -- and therefore the body that contains the generic body (and
2193 -- its context) must be traversed immediately after the
2194 -- corresponding spec (see Do_Unit_And_Dependents).
2196 -- The main unit itself is processed separately after all other
2197 -- specs, and relevant bodies are examined in Process_Main.
2199 when N_Subprogram_Body
=>
2200 if Acts_As_Spec
(N
) then
2201 Do_Unit_And_Dependents
(CU
, N
);
2204 when N_Package_Body
=>
2206 and then Nkind
(Original_Node
(Unit
(Main_CU
))) in
2207 N_Generic_Instantiation
2208 and then Present
(Library_Unit
(Main_CU
))
2210 Do_Unit_And_Dependents
2211 (Library_Unit
(Main_CU
),
2212 Unit
(Library_Unit
(Main_CU
)));
2215 -- It is a spec, process it, and the units it depends on,
2216 -- unless it is a descendant of the main unit. This can happen
2217 -- when the body of a parent depends on some other descendant.
2219 when N_Null_Statement
=>
2221 -- Ignore an ignored ghost unit
2223 pragma Assert
(Is_Ignored_Ghost_Node
(Original_Node
(N
)));
2228 -- Skip spec of main unit for now, we want to process it
2229 -- after all other specs.
2231 if Nkind
(Unit
(CU
)) = N_Package_Declaration
2232 and then Library_Unit
(CU
) = Main_CU
2233 and then CU
/= Main_CU
2237 Par
:= Scope
(Defining_Entity
(Unit
(CU
)));
2239 if Is_Child_Unit
(Defining_Entity
(Unit
(CU
))) then
2241 and then Par
/= Standard_Standard
2242 and then Par
/= Cunit_Entity
(Main_Unit
)
2248 if Par
/= Cunit_Entity
(Main_Unit
) then
2249 Do_Unit_And_Dependents
(CU
, N
);
2258 -- Now process main package spec if skipped
2260 if Present
(Spec_CU
) then
2261 Do_Unit_And_Dependents
(Spec_CU
, Unit
(Spec_CU
));
2264 -- Now process package bodies on which main depends, followed by bodies
2265 -- of parents, if present, and finally main itself.
2267 if not Done
(Main_Unit
) then
2270 Process_Main
: declare
2271 Parent_CU
: Node_Id
;
2273 Body_U
: Unit_Number_Type
;
2276 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean;
2277 -- If the main unit has subunits, their context may include
2278 -- bodies that are needed in the body of main. We must examine
2279 -- the context of the subunits, which are otherwise not made
2280 -- explicit in the main unit.
2282 ------------------------
2283 -- Is_Subunit_Of_Main --
2284 ------------------------
2286 function Is_Subunit_Of_Main
(U
: Node_Id
) return Boolean is
2290 if Present
(U
) and then Nkind
(Unit
(U
)) = N_Subunit
then
2291 Lib
:= Library_Unit
(U
);
2292 return Lib
= Main_CU
or else Is_Subunit_Of_Main
(Lib
);
2296 end Is_Subunit_Of_Main
;
2298 -- Start of processing for Process_Main
2301 Process_Bodies_In_Context
(Main_CU
);
2303 for Unit_Num
in Done
'Range loop
2304 if Is_Subunit_Of_Main
(Cunit
(Unit_Num
)) then
2305 Process_Bodies_In_Context
(Cunit
(Unit_Num
));
2309 -- If the main unit is a child unit, parent bodies may be present
2310 -- because they export instances or inlined subprograms. Check for
2311 -- presence of these, which are not present in context clauses.
2312 -- Note that if the parents are instances, their bodies have been
2313 -- processed before the main spec, because they may be needed
2314 -- therein, so the following loop only affects non-instances.
2316 if Is_Child_Unit
(Cunit_Entity
(Main_Unit
)) then
2317 Child
:= Cunit_Entity
(Main_Unit
);
2318 while Is_Child_Unit
(Child
) loop
2320 Cunit
(Get_Cunit_Entity_Unit_Number
(Scope
(Child
)));
2321 Body_CU
:= Library_Unit
(Parent_CU
);
2323 if Present
(Body_CU
)
2324 and then not Seen
(Get_Cunit_Unit_Number
(Body_CU
))
2325 and then not Depends_On_Main
(Body_CU
)
2327 Body_U
:= Get_Cunit_Unit_Number
(Body_CU
);
2328 Seen
(Body_U
) := True;
2329 Do_Action
(Body_CU
, Unit
(Body_CU
));
2330 Done
(Body_U
) := True;
2333 Child
:= Scope
(Child
);
2337 Do_Action
(Main_CU
, Unit
(Main_CU
));
2338 Done
(Main_Unit
) := True;
2342 if Debug_Unit_Walk
then
2343 if Done
/= (Done
'Range => True) then
2345 Write_Line
("Ignored units:");
2349 for Unit_Num
in Done
'Range loop
2350 if not Done
(Unit_Num
) then
2352 -- Units with configuration pragmas (.ads files) have empty
2353 -- compilation-unit nodes; skip printing info about them.
2355 if Present
(Cunit
(Unit_Num
)) then
2357 (Unit_Num
, Unit
(Cunit
(Unit_Num
)), Withs
=> True);
2366 pragma Assert
(Done
(Main_Unit
));
2368 if Debug_Unit_Walk
then
2370 Write_Line
("end Walk_Library_Items.");
2372 end Walk_Library_Items
;
2378 procedure Walk_Withs
(CU
: Node_Id
; Include_Limited
: Boolean) is
2379 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2380 pragma Assert
(Nkind
(Unit
(CU
)) /= N_Subunit
);
2382 procedure Walk_Immediate
is new Walk_Withs_Immediate
(Action
);
2385 -- First walk the withs immediately on the library item
2387 Walk_Immediate
(CU
, Include_Limited
);
2389 -- For a body, we must also check for any subunits which belong to it
2390 -- and which have context clauses of their own, since these with'ed
2391 -- units are part of its own dependencies.
2393 if Nkind
(Unit
(CU
)) in N_Unit_Body
then
2394 for S
in Main_Unit
.. Last_Unit
loop
2396 -- We are only interested in subunits. For preproc. data and def.
2397 -- files, Cunit is Empty, so we need to test that first.
2399 if Cunit
(S
) /= Empty
2400 and then Nkind
(Unit
(Cunit
(S
))) = N_Subunit
2406 Pnode
:= Library_Unit
(Cunit
(S
));
2408 -- In -gnatc mode, the errors in the subunits will not have
2409 -- been recorded, but the analysis of the subunit may have
2410 -- failed, so just quit.
2416 -- Find ultimate parent of the subunit
2418 while Nkind
(Unit
(Pnode
)) = N_Subunit
loop
2419 Pnode
:= Library_Unit
(Pnode
);
2422 -- See if it belongs to current unit, and if so, include its
2423 -- with_clauses. Do not process main unit prematurely.
2425 if Pnode
= CU
and then CU
/= Cunit
(Main_Unit
) then
2426 Walk_Immediate
(Cunit
(S
), Include_Limited
);
2434 --------------------------
2435 -- Walk_Withs_Immediate --
2436 --------------------------
2438 procedure Walk_Withs_Immediate
(CU
: Node_Id
; Include_Limited
: Boolean) is
2439 pragma Assert
(Nkind
(CU
) = N_Compilation_Unit
);
2441 Context_Item
: Node_Id
;
2445 Context_Item
:= First
(Context_Items
(CU
));
2446 while Present
(Context_Item
) loop
2447 if Nkind
(Context_Item
) = N_With_Clause
2448 and then (Include_Limited
2449 or else not Limited_Present
(Context_Item
))
2451 Lib_Unit
:= Library_Unit
(Context_Item
);
2455 Next
(Context_Item
);
2457 end Walk_Withs_Immediate
;