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 Checks
; use Checks
;
29 with Einfo
; use Einfo
;
30 with Errout
; use Errout
;
31 with Expander
; use Expander
;
32 with Exp_Util
; use Exp_Util
;
33 with Freeze
; use Freeze
;
34 with Lib
.Xref
; use Lib
.Xref
;
35 with Nlists
; use Nlists
;
36 with Nmake
; use Nmake
;
39 with Sem_Case
; use Sem_Case
;
40 with Sem_Ch3
; use Sem_Ch3
;
41 with Sem_Ch8
; use Sem_Ch8
;
42 with Sem_Disp
; use Sem_Disp
;
43 with Sem_Eval
; use Sem_Eval
;
44 with Sem_Res
; use Sem_Res
;
45 with Sem_Type
; use Sem_Type
;
46 with Sem_Util
; use Sem_Util
;
47 with Sem_Warn
; use Sem_Warn
;
48 with Stand
; use Stand
;
49 with Sinfo
; use Sinfo
;
50 with Targparm
; use Targparm
;
51 with Tbuild
; use Tbuild
;
52 with Uintp
; use Uintp
;
54 package body Sem_Ch5
is
56 Unblocked_Exit_Count
: Nat
:= 0;
57 -- This variable is used when processing if statements, case statements,
58 -- and block statements. It counts the number of exit points that are
59 -- not blocked by unconditional transfer instructions (for IF and CASE,
60 -- these are the branches of the conditional, for a block, they are the
61 -- statement sequence of the block, and the statement sequences of any
62 -- exception handlers that are part of the block. When processing is
63 -- complete, if this count is zero, it means that control cannot fall
64 -- through the IF, CASE or block statement. This is used for the
65 -- generation of warning messages. This variable is recursively saved
66 -- on entry to processing the construct, and restored on exit.
68 -----------------------
69 -- Local Subprograms --
70 -----------------------
72 procedure Analyze_Iteration_Scheme
(N
: Node_Id
);
74 ------------------------
75 -- Analyze_Assignment --
76 ------------------------
78 procedure Analyze_Assignment
(N
: Node_Id
) is
79 Lhs
: constant Node_Id
:= Name
(N
);
80 Rhs
: constant Node_Id
:= Expression
(N
);
85 procedure Diagnose_Non_Variable_Lhs
(N
: Node_Id
);
86 -- N is the node for the left hand side of an assignment, and it
87 -- is not a variable. This routine issues an appropriate diagnostic.
90 -- This is called to kill current value settings of a simple variable
91 -- on the left hand side. We call it if we find any error in analyzing
92 -- the assignment, and at the end of processing before setting any new
93 -- current values in place.
95 procedure Set_Assignment_Type
97 Opnd_Type
: in out Entity_Id
);
98 -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type
99 -- is the nominal subtype. This procedure is used to deal with cases
100 -- where the nominal subtype must be replaced by the actual subtype.
102 -------------------------------
103 -- Diagnose_Non_Variable_Lhs --
104 -------------------------------
106 procedure Diagnose_Non_Variable_Lhs
(N
: Node_Id
) is
108 -- Not worth posting another error if left hand side already
109 -- flagged as being illegal in some respect
111 if Error_Posted
(N
) then
114 -- Some special bad cases of entity names
116 elsif Is_Entity_Name
(N
) then
117 if Ekind
(Entity
(N
)) = E_In_Parameter
then
119 ("assignment to IN mode parameter not allowed", N
);
121 -- Private declarations in a protected object are turned into
122 -- constants when compiling a protected function.
124 elsif Present
(Scope
(Entity
(N
)))
125 and then Is_Protected_Type
(Scope
(Entity
(N
)))
127 (Ekind
(Current_Scope
) = E_Function
129 Ekind
(Enclosing_Dynamic_Scope
(Current_Scope
)) = E_Function
)
132 ("protected function cannot modify protected object", N
);
134 elsif Ekind
(Entity
(N
)) = E_Loop_Parameter
then
136 ("assignment to loop parameter not allowed", N
);
140 ("left hand side of assignment must be a variable", N
);
143 -- For indexed components or selected components, test prefix
145 elsif Nkind
(N
) = N_Indexed_Component
then
146 Diagnose_Non_Variable_Lhs
(Prefix
(N
));
148 -- Another special case for assignment to discriminant
150 elsif Nkind
(N
) = N_Selected_Component
then
151 if Present
(Entity
(Selector_Name
(N
)))
152 and then Ekind
(Entity
(Selector_Name
(N
))) = E_Discriminant
155 ("assignment to discriminant not allowed", N
);
157 Diagnose_Non_Variable_Lhs
(Prefix
(N
));
161 -- If we fall through, we have no special message to issue!
163 Error_Msg_N
("left hand side of assignment must be a variable", N
);
165 end Diagnose_Non_Variable_Lhs
;
171 procedure Kill_Lhs
is
173 if Is_Entity_Name
(Lhs
) then
175 Ent
: constant Entity_Id
:= Entity
(Lhs
);
177 if Present
(Ent
) then
178 Kill_Current_Values
(Ent
);
184 -------------------------
185 -- Set_Assignment_Type --
186 -------------------------
188 procedure Set_Assignment_Type
190 Opnd_Type
: in out Entity_Id
)
193 Require_Entity
(Opnd
);
195 -- If the assignment operand is an in-out or out parameter, then we
196 -- get the actual subtype (needed for the unconstrained case).
197 -- If the operand is the actual in an entry declaration, then within
198 -- the accept statement it is replaced with a local renaming, which
199 -- may also have an actual subtype.
201 if Is_Entity_Name
(Opnd
)
202 and then (Ekind
(Entity
(Opnd
)) = E_Out_Parameter
203 or else Ekind
(Entity
(Opnd
)) =
205 or else Ekind
(Entity
(Opnd
)) =
206 E_Generic_In_Out_Parameter
208 (Ekind
(Entity
(Opnd
)) = E_Variable
209 and then Nkind
(Parent
(Entity
(Opnd
))) =
210 N_Object_Renaming_Declaration
211 and then Nkind
(Parent
(Parent
(Entity
(Opnd
)))) =
214 Opnd_Type
:= Get_Actual_Subtype
(Opnd
);
216 -- If assignment operand is a component reference, then we get the
217 -- actual subtype of the component for the unconstrained case.
220 (Nkind
(Opnd
) = N_Selected_Component
221 or else Nkind
(Opnd
) = N_Explicit_Dereference
)
222 and then not Is_Unchecked_Union
(Opnd_Type
)
224 Decl
:= Build_Actual_Subtype_Of_Component
(Opnd_Type
, Opnd
);
226 if Present
(Decl
) then
227 Insert_Action
(N
, Decl
);
228 Mark_Rewrite_Insertion
(Decl
);
230 Opnd_Type
:= Defining_Identifier
(Decl
);
231 Set_Etype
(Opnd
, Opnd_Type
);
232 Freeze_Itype
(Opnd_Type
, N
);
234 elsif Is_Constrained
(Etype
(Opnd
)) then
235 Opnd_Type
:= Etype
(Opnd
);
238 -- For slice, use the constrained subtype created for the slice
240 elsif Nkind
(Opnd
) = N_Slice
then
241 Opnd_Type
:= Etype
(Opnd
);
243 end Set_Assignment_Type
;
245 -- Start of processing for Analyze_Assignment
251 -- Start type analysis for assignment
255 -- In the most general case, both Lhs and Rhs can be overloaded, and we
256 -- must compute the intersection of the possible types on each side.
258 if Is_Overloaded
(Lhs
) then
265 Get_First_Interp
(Lhs
, I
, It
);
267 while Present
(It
.Typ
) loop
268 if Has_Compatible_Type
(Rhs
, It
.Typ
) then
269 if T1
/= Any_Type
then
271 -- An explicit dereference is overloaded if the prefix
272 -- is. Try to remove the ambiguity on the prefix, the
273 -- error will be posted there if the ambiguity is real.
275 if Nkind
(Lhs
) = N_Explicit_Dereference
then
278 PI1
: Interp_Index
:= 0;
284 Get_First_Interp
(Prefix
(Lhs
), PI
, PIt
);
286 while Present
(PIt
.Typ
) loop
287 if Is_Access_Type
(PIt
.Typ
)
288 and then Has_Compatible_Type
289 (Rhs
, Designated_Type
(PIt
.Typ
))
293 Disambiguate
(Prefix
(Lhs
),
296 if PIt
= No_Interp
then
298 ("ambiguous left-hand side"
299 & " in assignment", Lhs
);
302 Resolve
(Prefix
(Lhs
), PIt
.Typ
);
312 Get_Next_Interp
(PI
, PIt
);
318 ("ambiguous left-hand side in assignment", Lhs
);
326 Get_Next_Interp
(I
, It
);
330 if T1
= Any_Type
then
332 ("no valid types for left-hand side for assignment", Lhs
);
340 if not Is_Variable
(Lhs
) then
341 Diagnose_Non_Variable_Lhs
(Lhs
);
344 elsif Is_Limited_Type
(T1
)
345 and then not Assignment_OK
(Lhs
)
346 and then not Assignment_OK
(Original_Node
(Lhs
))
349 ("left hand of assignment must not be limited type", Lhs
);
350 Explain_Limited_Type
(T1
, Lhs
);
354 -- Resolution may have updated the subtype, in case the left-hand
355 -- side is a private protected component. Use the correct subtype
356 -- to avoid scoping issues in the back-end.
360 -- Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete
361 -- type. For example:
365 -- type Acc is access P.T;
368 -- with Pkg; use Acc;
369 -- procedure Example is
372 -- A.all := B.all; -- ERROR
375 if Nkind
(Lhs
) = N_Explicit_Dereference
376 and then Ekind
(T1
) = E_Incomplete_Type
378 Error_Msg_N
("invalid use of incomplete type", Lhs
);
383 Set_Assignment_Type
(Lhs
, T1
);
386 Check_Unset_Reference
(Rhs
);
388 -- Remaining steps are skipped if Rhs was syntactically in error
397 if not Covers
(T1
, T2
) then
398 Wrong_Type
(Rhs
, Etype
(Lhs
));
403 -- Ada 2005 (AI-326): In case of explicit dereference of incomplete
404 -- types, use the non-limited view if available
406 if Nkind
(Rhs
) = N_Explicit_Dereference
407 and then Ekind
(T2
) = E_Incomplete_Type
408 and then Is_Tagged_Type
(T2
)
409 and then Present
(Non_Limited_View
(T2
))
411 T2
:= Non_Limited_View
(T2
);
414 Set_Assignment_Type
(Rhs
, T2
);
416 if Total_Errors_Detected
/= 0 then
426 if T1
= Any_Type
or else T2
= Any_Type
then
431 if (Is_Class_Wide_Type
(T2
) or else Is_Dynamically_Tagged
(Rhs
))
432 and then not Is_Class_Wide_Type
(T1
)
434 Error_Msg_N
("dynamically tagged expression not allowed!", Rhs
);
436 elsif Is_Class_Wide_Type
(T1
)
437 and then not Is_Class_Wide_Type
(T2
)
438 and then not Is_Tag_Indeterminate
(Rhs
)
439 and then not Is_Dynamically_Tagged
(Rhs
)
441 Error_Msg_N
("dynamically tagged expression required!", Rhs
);
444 -- Propagate the tag from a class-wide target to the rhs when the rhs
445 -- is a tag-indeterminate call.
447 if Is_Class_Wide_Type
(T1
)
448 and then Is_Tag_Indeterminate
(Rhs
)
450 Propagate_Tag
(Lhs
, Rhs
);
453 -- Ada 2005 (AI-230 and AI-385): When the lhs type is an anonymous
454 -- access type, apply an implicit conversion of the rhs to that type
455 -- to force appropriate static and run-time accessibility checks.
457 if Ada_Version
>= Ada_05
458 and then Ekind
(T1
) = E_Anonymous_Access_Type
460 Rewrite
(Rhs
, Convert_To
(T1
, Relocate_Node
(Rhs
)));
461 Analyze_And_Resolve
(Rhs
, T1
);
466 if Ada_Version
>= Ada_05
467 and then Can_Never_Be_Null
(T1
)
468 and then not Assignment_OK
(Lhs
)
470 if Nkind
(Rhs
) = N_Null
then
471 Apply_Compile_Time_Constraint_Error
473 Msg
=> "(Ada 2005) NULL not allowed in null-excluding objects?",
474 Reason
=> CE_Null_Not_Allowed
);
477 elsif not Can_Never_Be_Null
(T2
) then
479 Convert_To
(T1
, Relocate_Node
(Rhs
)));
480 Analyze_And_Resolve
(Rhs
, T1
);
484 if Is_Scalar_Type
(T1
) then
485 Apply_Scalar_Range_Check
(Rhs
, Etype
(Lhs
));
487 -- For array types, verify that lengths match. If the right hand side
488 -- if a function call that has been inlined, the assignment has been
489 -- rewritten as a block, and the constraint check will be applied to the
490 -- assignment within the block.
492 elsif Is_Array_Type
(T1
)
494 (Nkind
(Rhs
) /= N_Type_Conversion
495 or else Is_Constrained
(Etype
(Rhs
)))
497 (Nkind
(Rhs
) /= N_Function_Call
498 or else Nkind
(N
) /= N_Block_Statement
)
500 -- Assignment verifies that the length of the Lsh and Rhs are equal,
501 -- but of course the indices do not have to match. If the right-hand
502 -- side is a type conversion to an unconstrained type, a length check
503 -- is performed on the expression itself during expansion. In rare
504 -- cases, the redundant length check is computed on an index type
505 -- with a different representation, triggering incorrect code in
508 Apply_Length_Check
(Rhs
, Etype
(Lhs
));
511 -- Discriminant checks are applied in the course of expansion
516 -- Note: modifications of the Lhs may only be recorded after
517 -- checks have been applied.
519 Note_Possible_Modification
(Lhs
);
521 -- ??? a real accessibility check is needed when ???
523 -- Post warning for useless assignment
525 if Warn_On_Redundant_Constructs
527 -- We only warn for source constructs
529 and then Comes_From_Source
(N
)
531 -- Where the entity is the same on both sides
533 and then Is_Entity_Name
(Lhs
)
534 and then Is_Entity_Name
(Original_Node
(Rhs
))
535 and then Entity
(Lhs
) = Entity
(Original_Node
(Rhs
))
537 -- But exclude the case where the right side was an operation
538 -- that got rewritten (e.g. JUNK + K, where K was known to be
539 -- zero). We don't want to warn in such a case, since it is
540 -- reasonable to write such expressions especially when K is
541 -- defined symbolically in some other package.
543 and then Nkind
(Original_Node
(Rhs
)) not in N_Op
546 ("?useless assignment of & to itself", N
, Entity
(Lhs
));
549 -- Check for non-allowed composite assignment
551 if not Support_Composite_Assign_On_Target
552 and then (Is_Array_Type
(T1
) or else Is_Record_Type
(T1
))
553 and then (not Has_Size_Clause
(T1
) or else Esize
(T1
) > 64)
555 Error_Msg_CRT
("composite assignment", N
);
558 -- Final step. If left side is an entity, then we may be able to
559 -- reset the current tracked values to new safe values. We only have
560 -- something to do if the left side is an entity name, and expansion
561 -- has not modified the node into something other than an assignment,
562 -- and of course we only capture values if it is safe to do so.
564 if Is_Entity_Name
(Lhs
)
565 and then Nkind
(N
) = N_Assignment_Statement
568 Ent
: constant Entity_Id
:= Entity
(Lhs
);
571 if Safe_To_Capture_Value
(N
, Ent
) then
573 -- If we are assigning an access type and the left side is an
574 -- entity, then make sure that the Is_Known_[Non_]Null flags
575 -- properly reflect the state of the entity after assignment.
577 if Is_Access_Type
(T1
) then
578 if Known_Non_Null
(Rhs
) then
579 Set_Is_Known_Non_Null
(Ent
, True);
581 elsif Known_Null
(Rhs
)
582 and then not Can_Never_Be_Null
(Ent
)
584 Set_Is_Known_Null
(Ent
, True);
587 Set_Is_Known_Null
(Ent
, False);
589 if not Can_Never_Be_Null
(Ent
) then
590 Set_Is_Known_Non_Null
(Ent
, False);
594 -- For discrete types, we may be able to set the current value
595 -- if the value is known at compile time.
597 elsif Is_Discrete_Type
(T1
)
598 and then Compile_Time_Known_Value
(Rhs
)
600 Set_Current_Value
(Ent
, Rhs
);
602 Set_Current_Value
(Ent
, Empty
);
605 -- If not safe to capture values, kill them
612 end Analyze_Assignment
;
614 -----------------------------
615 -- Analyze_Block_Statement --
616 -----------------------------
618 procedure Analyze_Block_Statement
(N
: Node_Id
) is
619 Decls
: constant List_Id
:= Declarations
(N
);
620 Id
: constant Node_Id
:= Identifier
(N
);
621 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(N
);
624 -- If no handled statement sequence is present, things are really
625 -- messed up, and we just return immediately (this is a defence
626 -- against previous errors).
632 -- Normal processing with HSS present
635 EH
: constant List_Id
:= Exception_Handlers
(HSS
);
636 Ent
: Entity_Id
:= Empty
;
639 Save_Unblocked_Exit_Count
: constant Nat
:= Unblocked_Exit_Count
;
640 -- Recursively save value of this global, will be restored on exit
643 -- Initialize unblocked exit count for statements of begin block
644 -- plus one for each excption handler that is present.
646 Unblocked_Exit_Count
:= 1;
649 Unblocked_Exit_Count
:= Unblocked_Exit_Count
+ List_Length
(EH
);
652 -- If a label is present analyze it and mark it as referenced
658 -- An error defense. If we have an identifier, but no entity,
659 -- then something is wrong. If we have previous errors, then
660 -- just remove the identifier and continue, otherwise raise
664 if Total_Errors_Detected
/= 0 then
665 Set_Identifier
(N
, Empty
);
671 Set_Ekind
(Ent
, E_Block
);
672 Generate_Reference
(Ent
, N
, ' ');
673 Generate_Definition
(Ent
);
675 if Nkind
(Parent
(Ent
)) = N_Implicit_Label_Declaration
then
676 Set_Label_Construct
(Parent
(Ent
), N
);
681 -- If no entity set, create a label entity
684 Ent
:= New_Internal_Entity
(E_Block
, Current_Scope
, Sloc
(N
), 'B');
685 Set_Identifier
(N
, New_Occurrence_Of
(Ent
, Sloc
(N
)));
689 Set_Etype
(Ent
, Standard_Void_Type
);
690 Set_Block_Node
(Ent
, Identifier
(N
));
693 if Present
(Decls
) then
694 Analyze_Declarations
(Decls
);
699 Process_End_Label
(HSS
, 'e', Ent
);
701 -- If exception handlers are present, then we indicate that
702 -- enclosing scopes contain a block with handlers. We only
703 -- need to mark non-generic scopes.
708 Set_Has_Nested_Block_With_Handler
(S
);
709 exit when Is_Overloadable
(S
)
710 or else Ekind
(S
) = E_Package
711 or else Is_Generic_Unit
(S
);
716 Check_References
(Ent
);
719 if Unblocked_Exit_Count
= 0 then
720 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
721 Check_Unreachable_Code
(N
);
723 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
726 end Analyze_Block_Statement
;
728 ----------------------------
729 -- Analyze_Case_Statement --
730 ----------------------------
732 procedure Analyze_Case_Statement
(N
: Node_Id
) is
734 Exp_Type
: Entity_Id
;
735 Exp_Btype
: Entity_Id
;
738 Others_Present
: Boolean;
740 Statements_Analyzed
: Boolean := False;
741 -- Set True if at least some statement sequences get analyzed.
742 -- If False on exit, means we had a serious error that prevented
743 -- full analysis of the case statement, and as a result it is not
744 -- a good idea to output warning messages about unreachable code.
746 Save_Unblocked_Exit_Count
: constant Nat
:= Unblocked_Exit_Count
;
747 -- Recursively save value of this global, will be restored on exit
749 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
750 -- Error routine invoked by the generic instantiation below when
751 -- the case statment has a non static choice.
753 procedure Process_Statements
(Alternative
: Node_Id
);
754 -- Analyzes all the statements associated to a case alternative.
755 -- Needed by the generic instantiation below.
757 package Case_Choices_Processing
is new
758 Generic_Choices_Processing
759 (Get_Alternatives
=> Alternatives
,
760 Get_Choices
=> Discrete_Choices
,
761 Process_Empty_Choice
=> No_OP
,
762 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
763 Process_Associated_Node
=> Process_Statements
);
764 use Case_Choices_Processing
;
765 -- Instantiation of the generic choice processing package
767 -----------------------------
768 -- Non_Static_Choice_Error --
769 -----------------------------
771 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
774 ("choice given in case statement is not static!", Choice
);
775 end Non_Static_Choice_Error
;
777 ------------------------
778 -- Process_Statements --
779 ------------------------
781 procedure Process_Statements
(Alternative
: Node_Id
) is
782 Choices
: constant List_Id
:= Discrete_Choices
(Alternative
);
786 Unblocked_Exit_Count
:= Unblocked_Exit_Count
+ 1;
787 Statements_Analyzed
:= True;
789 -- An interesting optimization. If the case statement expression
790 -- is a simple entity, then we can set the current value within
791 -- an alternative if the alternative has one possible value.
795 -- when 2 | 3 => beta
796 -- when others => gamma
798 -- Here we know that N is initially 1 within alpha, but for beta
799 -- and gamma, we do not know anything more about the initial value.
801 if Is_Entity_Name
(Exp
) then
804 if Ekind
(Ent
) = E_Variable
806 Ekind
(Ent
) = E_In_Out_Parameter
808 Ekind
(Ent
) = E_Out_Parameter
810 if List_Length
(Choices
) = 1
811 and then Nkind
(First
(Choices
)) in N_Subexpr
812 and then Compile_Time_Known_Value
(First
(Choices
))
814 Set_Current_Value
(Entity
(Exp
), First
(Choices
));
817 Analyze_Statements
(Statements
(Alternative
));
819 -- After analyzing the case, set the current value to empty
820 -- since we won't know what it is for the next alternative
821 -- (unless reset by this same circuit), or after the case.
823 Set_Current_Value
(Entity
(Exp
), Empty
);
828 -- Case where expression is not an entity name of a variable
830 Analyze_Statements
(Statements
(Alternative
));
831 end Process_Statements
;
833 -- Table to record choices. Put after subprograms since we make
834 -- a call to Number_Of_Choices to get the right number of entries.
836 Case_Table
: Choice_Table_Type
(1 .. Number_Of_Choices
(N
));
838 -- Start of processing for Analyze_Case_Statement
841 Unblocked_Exit_Count
:= 0;
842 Exp
:= Expression
(N
);
845 -- The expression must be of any discrete type. In rare cases, the
846 -- expander constructs a case statement whose expression has a private
847 -- type whose full view is discrete. This can happen when generating
848 -- a stream operation for a variant type after the type is frozen,
849 -- when the partial of view of the type of the discriminant is private.
850 -- In that case, use the full view to analyze case alternatives.
852 if not Is_Overloaded
(Exp
)
853 and then not Comes_From_Source
(N
)
854 and then Is_Private_Type
(Etype
(Exp
))
855 and then Present
(Full_View
(Etype
(Exp
)))
856 and then Is_Discrete_Type
(Full_View
(Etype
(Exp
)))
858 Resolve
(Exp
, Etype
(Exp
));
859 Exp_Type
:= Full_View
(Etype
(Exp
));
862 Analyze_And_Resolve
(Exp
, Any_Discrete
);
863 Exp_Type
:= Etype
(Exp
);
866 Check_Unset_Reference
(Exp
);
867 Exp_Btype
:= Base_Type
(Exp_Type
);
869 -- The expression must be of a discrete type which must be determinable
870 -- independently of the context in which the expression occurs, but
871 -- using the fact that the expression must be of a discrete type.
872 -- Moreover, the type this expression must not be a character literal
873 -- (which is always ambiguous) or, for Ada-83, a generic formal type.
875 -- If error already reported by Resolve, nothing more to do
877 if Exp_Btype
= Any_Discrete
878 or else Exp_Btype
= Any_Type
882 elsif Exp_Btype
= Any_Character
then
884 ("character literal as case expression is ambiguous", Exp
);
887 elsif Ada_Version
= Ada_83
888 and then (Is_Generic_Type
(Exp_Btype
)
889 or else Is_Generic_Type
(Root_Type
(Exp_Btype
)))
892 ("(Ada 83) case expression cannot be of a generic type", Exp
);
896 -- If the case expression is a formal object of mode in out, then
897 -- treat it as having a nonstatic subtype by forcing use of the base
898 -- type (which has to get passed to Check_Case_Choices below). Also
899 -- use base type when the case expression is parenthesized.
901 if Paren_Count
(Exp
) > 0
902 or else (Is_Entity_Name
(Exp
)
903 and then Ekind
(Entity
(Exp
)) = E_Generic_In_Out_Parameter
)
905 Exp_Type
:= Exp_Btype
;
908 -- Call instantiated Analyze_Choices which does the rest of the work
911 (N
, Exp_Type
, Case_Table
, Last_Choice
, Dont_Care
, Others_Present
);
913 if Exp_Type
= Universal_Integer
and then not Others_Present
then
914 Error_Msg_N
("case on universal integer requires OTHERS choice", Exp
);
917 -- If all our exits were blocked by unconditional transfers of control,
918 -- then the entire CASE statement acts as an unconditional transfer of
919 -- control, so treat it like one, and check unreachable code. Skip this
920 -- test if we had serious errors preventing any statement analysis.
922 if Unblocked_Exit_Count
= 0 and then Statements_Analyzed
then
923 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
924 Check_Unreachable_Code
(N
);
926 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
929 if not Expander_Active
930 and then Compile_Time_Known_Value
(Expression
(N
))
931 and then Serious_Errors_Detected
= 0
934 Chosen
: constant Node_Id
:= Find_Static_Alternative
(N
);
938 Alt
:= First
(Alternatives
(N
));
940 while Present
(Alt
) loop
941 if Alt
/= Chosen
then
942 Remove_Warning_Messages
(Statements
(Alt
));
949 end Analyze_Case_Statement
;
951 ----------------------------
952 -- Analyze_Exit_Statement --
953 ----------------------------
955 -- If the exit includes a name, it must be the name of a currently open
956 -- loop. Otherwise there must be an innermost open loop on the stack,
957 -- to which the statement implicitly refers.
959 procedure Analyze_Exit_Statement
(N
: Node_Id
) is
960 Target
: constant Node_Id
:= Name
(N
);
961 Cond
: constant Node_Id
:= Condition
(N
);
962 Scope_Id
: Entity_Id
;
968 Check_Unreachable_Code
(N
);
971 if Present
(Target
) then
973 U_Name
:= Entity
(Target
);
975 if not In_Open_Scopes
(U_Name
) or else Ekind
(U_Name
) /= E_Loop
then
976 Error_Msg_N
("invalid loop name in exit statement", N
);
979 Set_Has_Exit
(U_Name
);
986 for J
in reverse 0 .. Scope_Stack
.Last
loop
987 Scope_Id
:= Scope_Stack
.Table
(J
).Entity
;
988 Kind
:= Ekind
(Scope_Id
);
991 and then (No
(Target
) or else Scope_Id
= U_Name
) then
992 Set_Has_Exit
(Scope_Id
);
995 elsif Kind
= E_Block
or else Kind
= E_Loop
then
1000 ("cannot exit from program unit or accept statement", N
);
1005 -- Verify that if present the condition is a Boolean expression
1007 if Present
(Cond
) then
1008 Analyze_And_Resolve
(Cond
, Any_Boolean
);
1009 Check_Unset_Reference
(Cond
);
1011 end Analyze_Exit_Statement
;
1013 ----------------------------
1014 -- Analyze_Goto_Statement --
1015 ----------------------------
1017 procedure Analyze_Goto_Statement
(N
: Node_Id
) is
1018 Label
: constant Node_Id
:= Name
(N
);
1019 Scope_Id
: Entity_Id
;
1020 Label_Scope
: Entity_Id
;
1023 Check_Unreachable_Code
(N
);
1027 if Entity
(Label
) = Any_Id
then
1030 elsif Ekind
(Entity
(Label
)) /= E_Label
then
1031 Error_Msg_N
("target of goto statement must be a label", Label
);
1034 elsif not Reachable
(Entity
(Label
)) then
1035 Error_Msg_N
("target of goto statement is not reachable", Label
);
1039 Label_Scope
:= Enclosing_Scope
(Entity
(Label
));
1041 for J
in reverse 0 .. Scope_Stack
.Last
loop
1042 Scope_Id
:= Scope_Stack
.Table
(J
).Entity
;
1044 if Label_Scope
= Scope_Id
1045 or else (Ekind
(Scope_Id
) /= E_Block
1046 and then Ekind
(Scope_Id
) /= E_Loop
)
1048 if Scope_Id
/= Label_Scope
then
1050 ("cannot exit from program unit or accept statement", N
);
1057 raise Program_Error
;
1058 end Analyze_Goto_Statement
;
1060 --------------------------
1061 -- Analyze_If_Statement --
1062 --------------------------
1064 -- A special complication arises in the analysis of if statements
1066 -- The expander has circuitry to completely delete code that it
1067 -- can tell will not be executed (as a result of compile time known
1068 -- conditions). In the analyzer, we ensure that code that will be
1069 -- deleted in this manner is analyzed but not expanded. This is
1070 -- obviously more efficient, but more significantly, difficulties
1071 -- arise if code is expanded and then eliminated (e.g. exception
1072 -- table entries disappear). Similarly, itypes generated in deleted
1073 -- code must be frozen from start, because the nodes on which they
1074 -- depend will not be available at the freeze point.
1076 procedure Analyze_If_Statement
(N
: Node_Id
) is
1079 Save_Unblocked_Exit_Count
: constant Nat
:= Unblocked_Exit_Count
;
1080 -- Recursively save value of this global, will be restored on exit
1082 Save_In_Deleted_Code
: Boolean;
1084 Del
: Boolean := False;
1085 -- This flag gets set True if a True condition has been found,
1086 -- which means that remaining ELSE/ELSIF parts are deleted.
1088 procedure Analyze_Cond_Then
(Cnode
: Node_Id
);
1089 -- This is applied to either the N_If_Statement node itself or
1090 -- to an N_Elsif_Part node. It deals with analyzing the condition
1091 -- and the THEN statements associated with it.
1093 -----------------------
1094 -- Analyze_Cond_Then --
1095 -----------------------
1097 procedure Analyze_Cond_Then
(Cnode
: Node_Id
) is
1098 Cond
: constant Node_Id
:= Condition
(Cnode
);
1099 Tstm
: constant List_Id
:= Then_Statements
(Cnode
);
1102 Unblocked_Exit_Count
:= Unblocked_Exit_Count
+ 1;
1103 Analyze_And_Resolve
(Cond
, Any_Boolean
);
1104 Check_Unset_Reference
(Cond
);
1105 Check_Possible_Current_Value_Condition
(Cnode
);
1107 -- If already deleting, then just analyze then statements
1110 Analyze_Statements
(Tstm
);
1112 -- Compile time known value, not deleting yet
1114 elsif Compile_Time_Known_Value
(Cond
) then
1115 Save_In_Deleted_Code
:= In_Deleted_Code
;
1117 -- If condition is True, then analyze the THEN statements
1118 -- and set no expansion for ELSE and ELSIF parts.
1120 if Is_True
(Expr_Value
(Cond
)) then
1121 Analyze_Statements
(Tstm
);
1123 Expander_Mode_Save_And_Set
(False);
1124 In_Deleted_Code
:= True;
1126 -- If condition is False, analyze THEN with expansion off
1128 else -- Is_False (Expr_Value (Cond))
1129 Expander_Mode_Save_And_Set
(False);
1130 In_Deleted_Code
:= True;
1131 Analyze_Statements
(Tstm
);
1132 Expander_Mode_Restore
;
1133 In_Deleted_Code
:= Save_In_Deleted_Code
;
1136 -- Not known at compile time, not deleting, normal analysis
1139 Analyze_Statements
(Tstm
);
1141 end Analyze_Cond_Then
;
1143 -- Start of Analyze_If_Statement
1146 -- Initialize exit count for else statements. If there is no else
1147 -- part, this count will stay non-zero reflecting the fact that the
1148 -- uncovered else case is an unblocked exit.
1150 Unblocked_Exit_Count
:= 1;
1151 Analyze_Cond_Then
(N
);
1153 -- Now to analyze the elsif parts if any are present
1155 if Present
(Elsif_Parts
(N
)) then
1156 E
:= First
(Elsif_Parts
(N
));
1157 while Present
(E
) loop
1158 Analyze_Cond_Then
(E
);
1163 if Present
(Else_Statements
(N
)) then
1164 Analyze_Statements
(Else_Statements
(N
));
1167 -- If all our exits were blocked by unconditional transfers of control,
1168 -- then the entire IF statement acts as an unconditional transfer of
1169 -- control, so treat it like one, and check unreachable code.
1171 if Unblocked_Exit_Count
= 0 then
1172 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
1173 Check_Unreachable_Code
(N
);
1175 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
1179 Expander_Mode_Restore
;
1180 In_Deleted_Code
:= Save_In_Deleted_Code
;
1183 if not Expander_Active
1184 and then Compile_Time_Known_Value
(Condition
(N
))
1185 and then Serious_Errors_Detected
= 0
1187 if Is_True
(Expr_Value
(Condition
(N
))) then
1188 Remove_Warning_Messages
(Else_Statements
(N
));
1190 if Present
(Elsif_Parts
(N
)) then
1191 E
:= First
(Elsif_Parts
(N
));
1193 while Present
(E
) loop
1194 Remove_Warning_Messages
(Then_Statements
(E
));
1200 Remove_Warning_Messages
(Then_Statements
(N
));
1203 end Analyze_If_Statement
;
1205 ----------------------------------------
1206 -- Analyze_Implicit_Label_Declaration --
1207 ----------------------------------------
1209 -- An implicit label declaration is generated in the innermost
1210 -- enclosing declarative part. This is done for labels as well as
1211 -- block and loop names.
1213 -- Note: any changes in this routine may need to be reflected in
1214 -- Analyze_Label_Entity.
1216 procedure Analyze_Implicit_Label_Declaration
(N
: Node_Id
) is
1217 Id
: constant Node_Id
:= Defining_Identifier
(N
);
1220 Set_Ekind
(Id
, E_Label
);
1221 Set_Etype
(Id
, Standard_Void_Type
);
1222 Set_Enclosing_Scope
(Id
, Current_Scope
);
1223 end Analyze_Implicit_Label_Declaration
;
1225 ------------------------------
1226 -- Analyze_Iteration_Scheme --
1227 ------------------------------
1229 procedure Analyze_Iteration_Scheme
(N
: Node_Id
) is
1231 procedure Process_Bounds
(R
: Node_Id
);
1232 -- If the iteration is given by a range, create temporaries and
1233 -- assignment statements block to capture the bounds and perform
1234 -- required finalization actions in case a bound includes a function
1235 -- call that uses the temporary stack. We first pre-analyze a copy of
1236 -- the range in order to determine the expected type, and analyze and
1237 -- resolve the original bounds.
1239 procedure Check_Controlled_Array_Attribute
(DS
: Node_Id
);
1240 -- If the bounds are given by a 'Range reference on a function call
1241 -- that returns a controlled array, introduce an explicit declaration
1242 -- to capture the bounds, so that the function result can be finalized
1243 -- in timely fashion.
1245 --------------------
1246 -- Process_Bounds --
1247 --------------------
1249 procedure Process_Bounds
(R
: Node_Id
) is
1250 Loc
: constant Source_Ptr
:= Sloc
(N
);
1251 R_Copy
: constant Node_Id
:= New_Copy_Tree
(R
);
1252 Lo
: constant Node_Id
:= Low_Bound
(R
);
1253 Hi
: constant Node_Id
:= High_Bound
(R
);
1254 New_Lo_Bound
: Node_Id
:= Empty
;
1255 New_Hi_Bound
: Node_Id
:= Empty
;
1257 Save_Analysis
: Boolean;
1260 (Original_Bound
: Node_Id
;
1261 Analyzed_Bound
: Node_Id
) return Node_Id
;
1262 -- Create one declaration followed by one assignment statement
1263 -- to capture the value of bound. We create a separate assignment
1264 -- in order to force the creation of a block in case the bound
1265 -- contains a call that uses the secondary stack.
1272 (Original_Bound
: Node_Id
;
1273 Analyzed_Bound
: Node_Id
) return Node_Id
1280 -- If the bound is a constant or an object, no need for a separate
1281 -- declaration. If the bound is the result of previous expansion
1282 -- it is already analyzed and should not be modified. Note that
1283 -- the Bound will be resolved later, if needed, as part of the
1284 -- call to Make_Index (literal bounds may need to be resolved to
1287 if Analyzed
(Original_Bound
) then
1288 return Original_Bound
;
1290 elsif Nkind
(Analyzed_Bound
) = N_Integer_Literal
1291 or else Is_Entity_Name
(Analyzed_Bound
)
1293 Analyze_And_Resolve
(Original_Bound
, Typ
);
1294 return Original_Bound
;
1297 Analyze_And_Resolve
(Original_Bound
, Typ
);
1301 Make_Defining_Identifier
(Loc
,
1302 Chars
=> New_Internal_Name
('S'));
1305 Make_Object_Declaration
(Loc
,
1306 Defining_Identifier
=> Id
,
1307 Object_Definition
=> New_Occurrence_Of
(Typ
, Loc
));
1309 Insert_Before
(Parent
(N
), Decl
);
1313 Make_Assignment_Statement
(Loc
,
1314 Name
=> New_Occurrence_Of
(Id
, Loc
),
1315 Expression
=> Relocate_Node
(Original_Bound
));
1317 Insert_Before
(Parent
(N
), Assign
);
1320 Rewrite
(Original_Bound
, New_Occurrence_Of
(Id
, Loc
));
1322 if Nkind
(Assign
) = N_Assignment_Statement
then
1323 return Expression
(Assign
);
1325 return Original_Bound
;
1329 -- Start of processing for Process_Bounds
1332 -- Determine expected type of range by analyzing separate copy
1333 -- Do the analysis and resolution of the copy of the bounds with
1334 -- expansion disabled, to prevent the generation of finalization
1335 -- actions on each bound. This prevents memory leaks when the
1336 -- bounds contain calls to functions returning controlled arrays.
1338 Set_Parent
(R_Copy
, Parent
(R
));
1339 Save_Analysis
:= Full_Analysis
;
1340 Full_Analysis
:= False;
1341 Expander_Mode_Save_And_Set
(False);
1345 if Is_Overloaded
(R_Copy
) then
1347 -- Apply preference rules for range of predefined integer types,
1348 -- or diagnose true ambiguity.
1353 Found
: Entity_Id
:= Empty
;
1356 Get_First_Interp
(R_Copy
, I
, It
);
1357 while Present
(It
.Typ
) loop
1358 if Is_Discrete_Type
(It
.Typ
) then
1362 if Scope
(Found
) = Standard_Standard
then
1365 elsif Scope
(It
.Typ
) = Standard_Standard
then
1369 -- Both of them are user-defined
1372 ("ambiguous bounds in range of iteration",
1374 Error_Msg_N
("\possible interpretations:", R_Copy
);
1375 Error_Msg_NE
("\} ", R_Copy
, Found
);
1376 Error_Msg_NE
("\} ", R_Copy
, It
.Typ
);
1382 Get_Next_Interp
(I
, It
);
1388 Expander_Mode_Restore
;
1389 Full_Analysis
:= Save_Analysis
;
1391 Typ
:= Etype
(R_Copy
);
1393 -- If the type of the discrete range is Universal_Integer, then
1394 -- the bound's type must be resolved to Integer, and any object
1395 -- used to hold the bound must also have type Integer.
1397 if Typ
= Universal_Integer
then
1398 Typ
:= Standard_Integer
;
1403 New_Lo_Bound
:= One_Bound
(Lo
, Low_Bound
(R_Copy
));
1404 New_Hi_Bound
:= One_Bound
(Hi
, High_Bound
(R_Copy
));
1406 -- Propagate staticness to loop range itself, in case the
1407 -- corresponding subtype is static.
1409 if New_Lo_Bound
/= Lo
1410 and then Is_Static_Expression
(New_Lo_Bound
)
1412 Rewrite
(Low_Bound
(R
), New_Copy
(New_Lo_Bound
));
1415 if New_Hi_Bound
/= Hi
1416 and then Is_Static_Expression
(New_Hi_Bound
)
1418 Rewrite
(High_Bound
(R
), New_Copy
(New_Hi_Bound
));
1422 --------------------------------------
1423 -- Check_Controlled_Array_Attribute --
1424 --------------------------------------
1426 procedure Check_Controlled_Array_Attribute
(DS
: Node_Id
) is
1428 if Nkind
(DS
) = N_Attribute_Reference
1429 and then Is_Entity_Name
(Prefix
(DS
))
1430 and then Ekind
(Entity
(Prefix
(DS
))) = E_Function
1431 and then Is_Array_Type
(Etype
(Entity
(Prefix
(DS
))))
1434 Component_Type
(Etype
(Entity
(Prefix
(DS
)))))
1435 and then Expander_Active
1438 Loc
: constant Source_Ptr
:= Sloc
(N
);
1439 Arr
: constant Entity_Id
:=
1440 Etype
(Entity
(Prefix
(DS
)));
1441 Indx
: constant Entity_Id
:=
1442 Base_Type
(Etype
(First_Index
(Arr
)));
1443 Subt
: constant Entity_Id
:=
1444 Make_Defining_Identifier
1445 (Loc
, New_Internal_Name
('S'));
1450 Make_Subtype_Declaration
(Loc
,
1451 Defining_Identifier
=> Subt
,
1452 Subtype_Indication
=>
1453 Make_Subtype_Indication
(Loc
,
1454 Subtype_Mark
=> New_Reference_To
(Indx
, Loc
),
1456 Make_Range_Constraint
(Loc
,
1457 Relocate_Node
(DS
))));
1458 Insert_Before
(Parent
(N
), Decl
);
1462 Make_Attribute_Reference
(Loc
,
1463 Prefix
=> New_Reference_To
(Subt
, Loc
),
1464 Attribute_Name
=> Attribute_Name
(DS
)));
1468 end Check_Controlled_Array_Attribute
;
1470 -- Start of processing for Analyze_Iteration_Scheme
1473 -- For an infinite loop, there is no iteration scheme
1480 Cond
: constant Node_Id
:= Condition
(N
);
1483 -- For WHILE loop, verify that the condition is a Boolean
1484 -- expression and resolve and check it.
1486 if Present
(Cond
) then
1487 Analyze_And_Resolve
(Cond
, Any_Boolean
);
1488 Check_Unset_Reference
(Cond
);
1490 -- Else we have a FOR loop
1494 LP
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
1495 Id
: constant Entity_Id
:= Defining_Identifier
(LP
);
1496 DS
: constant Node_Id
:= Discrete_Subtype_Definition
(LP
);
1501 -- We always consider the loop variable to be referenced,
1502 -- since the loop may be used just for counting purposes.
1504 Generate_Reference
(Id
, N
, ' ');
1506 -- Check for case of loop variable hiding a local
1507 -- variable (used later on to give a nice warning
1508 -- if the hidden variable is never assigned).
1511 H
: constant Entity_Id
:= Homonym
(Id
);
1514 and then Enclosing_Dynamic_Scope
(H
) =
1515 Enclosing_Dynamic_Scope
(Id
)
1516 and then Ekind
(H
) = E_Variable
1517 and then Is_Discrete_Type
(Etype
(H
))
1519 Set_Hiding_Loop_Variable
(H
, Id
);
1523 -- Now analyze the subtype definition. If it is
1524 -- a range, create temporaries for bounds.
1526 if Nkind
(DS
) = N_Range
1527 and then Expander_Active
1529 Process_Bounds
(DS
);
1538 -- The subtype indication may denote the completion
1539 -- of an incomplete type declaration.
1541 if Is_Entity_Name
(DS
)
1542 and then Present
(Entity
(DS
))
1543 and then Is_Type
(Entity
(DS
))
1544 and then Ekind
(Entity
(DS
)) = E_Incomplete_Type
1546 Set_Entity
(DS
, Get_Full_View
(Entity
(DS
)));
1547 Set_Etype
(DS
, Entity
(DS
));
1550 if not Is_Discrete_Type
(Etype
(DS
)) then
1551 Wrong_Type
(DS
, Any_Discrete
);
1552 Set_Etype
(DS
, Any_Type
);
1555 Check_Controlled_Array_Attribute
(DS
);
1557 Make_Index
(DS
, LP
);
1559 Set_Ekind
(Id
, E_Loop_Parameter
);
1560 Set_Etype
(Id
, Etype
(DS
));
1561 Set_Is_Known_Valid
(Id
, True);
1563 -- The loop is not a declarative part, so the only entity
1564 -- declared "within" must be frozen explicitly.
1567 Flist
: constant List_Id
:= Freeze_Entity
(Id
, Sloc
(N
));
1569 if Is_Non_Empty_List
(Flist
) then
1570 Insert_Actions
(N
, Flist
);
1574 -- Check for null or possibly null range and issue warning.
1575 -- We suppress such messages in generic templates and
1576 -- instances, because in practice they tend to be dubious
1579 if Nkind
(DS
) = N_Range
1580 and then Comes_From_Source
(N
)
1583 L
: constant Node_Id
:= Low_Bound
(DS
);
1584 H
: constant Node_Id
:= High_Bound
(DS
);
1594 Determine_Range
(L
, LOK
, Llo
, Lhi
);
1595 Determine_Range
(H
, HOK
, Hlo
, Hhi
);
1597 -- If range of loop is null, issue warning
1599 if (LOK
and HOK
) and then Llo
> Hhi
then
1601 -- Suppress the warning if inside a generic
1602 -- template or instance, since in practice
1603 -- they tend to be dubious in these cases since
1604 -- they can result from intended parametrization.
1606 if not Inside_A_Generic
1607 and then not In_Instance
1610 ("?loop range is null, loop will not execute",
1614 -- Since we know the range of the loop is null,
1615 -- set the appropriate flag to suppress any
1616 -- warnings that would otherwise be issued in
1617 -- the body of the loop that will not execute.
1618 -- We do this even in the generic case, since
1619 -- if it is dubious to warn on the null loop
1620 -- itself, it is certainly dubious to warn for
1621 -- conditions that occur inside it!
1623 Set_Is_Null_Loop
(Parent
(N
));
1625 -- The other case for a warning is a reverse loop
1626 -- where the upper bound is the integer literal
1627 -- zero or one, and the lower bound can be positive.
1629 -- For example, we have
1631 -- for J in reverse N .. 1 loop
1633 -- In practice, this is very likely to be a case
1634 -- of reversing the bounds incorrectly in the range.
1636 elsif Reverse_Present
(LP
)
1637 and then Nkind
(Original_Node
(H
)) =
1639 and then (Intval
(H
) = Uint_0
1641 Intval
(H
) = Uint_1
)
1644 Error_Msg_N
("?loop range may be null", DS
);
1645 Error_Msg_N
("\?bounds may be wrong way round", DS
);
1653 end Analyze_Iteration_Scheme
;
1659 -- Note: the semantic work required for analyzing labels (setting them as
1660 -- reachable) was done in a prepass through the statements in the block,
1661 -- so that forward gotos would be properly handled. See Analyze_Statements
1662 -- for further details. The only processing required here is to deal with
1663 -- optimizations that depend on an assumption of sequential control flow,
1664 -- since of course the occurrence of a label breaks this assumption.
1666 procedure Analyze_Label
(N
: Node_Id
) is
1667 pragma Warnings
(Off
, N
);
1669 Kill_Current_Values
;
1672 --------------------------
1673 -- Analyze_Label_Entity --
1674 --------------------------
1676 procedure Analyze_Label_Entity
(E
: Entity_Id
) is
1678 Set_Ekind
(E
, E_Label
);
1679 Set_Etype
(E
, Standard_Void_Type
);
1680 Set_Enclosing_Scope
(E
, Current_Scope
);
1681 Set_Reachable
(E
, True);
1682 end Analyze_Label_Entity
;
1684 ----------------------------
1685 -- Analyze_Loop_Statement --
1686 ----------------------------
1688 procedure Analyze_Loop_Statement
(N
: Node_Id
) is
1689 Id
: constant Node_Id
:= Identifier
(N
);
1693 if Present
(Id
) then
1695 -- Make name visible, e.g. for use in exit statements. Loop
1696 -- labels are always considered to be referenced.
1700 Generate_Reference
(Ent
, N
, ' ');
1701 Generate_Definition
(Ent
);
1703 -- If we found a label, mark its type. If not, ignore it, since it
1704 -- means we have a conflicting declaration, which would already have
1705 -- been diagnosed at declaration time. Set Label_Construct of the
1706 -- implicit label declaration, which is not created by the parser
1707 -- for generic units.
1709 if Ekind
(Ent
) = E_Label
then
1710 Set_Ekind
(Ent
, E_Loop
);
1712 if Nkind
(Parent
(Ent
)) = N_Implicit_Label_Declaration
then
1713 Set_Label_Construct
(Parent
(Ent
), N
);
1717 -- Case of no identifier present
1720 Ent
:= New_Internal_Entity
(E_Loop
, Current_Scope
, Sloc
(N
), 'L');
1721 Set_Etype
(Ent
, Standard_Void_Type
);
1722 Set_Parent
(Ent
, N
);
1725 -- Kill current values on entry to loop, since statements in body
1726 -- of loop may have been executed before the loop is entered.
1727 -- Similarly we kill values after the loop, since we do not know
1728 -- that the body of the loop was executed.
1730 Kill_Current_Values
;
1732 Analyze_Iteration_Scheme
(Iteration_Scheme
(N
));
1733 Analyze_Statements
(Statements
(N
));
1734 Process_End_Label
(N
, 'e', Ent
);
1736 Kill_Current_Values
;
1737 end Analyze_Loop_Statement
;
1739 ----------------------------
1740 -- Analyze_Null_Statement --
1741 ----------------------------
1743 -- Note: the semantics of the null statement is implemented by a single
1744 -- null statement, too bad everything isn't as simple as this!
1746 procedure Analyze_Null_Statement
(N
: Node_Id
) is
1747 pragma Warnings
(Off
, N
);
1750 end Analyze_Null_Statement
;
1752 ------------------------
1753 -- Analyze_Statements --
1754 ------------------------
1756 procedure Analyze_Statements
(L
: List_Id
) is
1761 -- The labels declared in the statement list are reachable from
1762 -- statements in the list. We do this as a prepass so that any
1763 -- goto statement will be properly flagged if its target is not
1764 -- reachable. This is not required, but is nice behavior!
1767 while Present
(S
) loop
1768 if Nkind
(S
) = N_Label
then
1769 Analyze
(Identifier
(S
));
1770 Lab
:= Entity
(Identifier
(S
));
1772 -- If we found a label mark it as reachable
1774 if Ekind
(Lab
) = E_Label
then
1775 Generate_Definition
(Lab
);
1776 Set_Reachable
(Lab
);
1778 if Nkind
(Parent
(Lab
)) = N_Implicit_Label_Declaration
then
1779 Set_Label_Construct
(Parent
(Lab
), S
);
1782 -- If we failed to find a label, it means the implicit declaration
1783 -- of the label was hidden. A for-loop parameter can do this to
1784 -- a label with the same name inside the loop, since the implicit
1785 -- label declaration is in the innermost enclosing body or block
1789 Error_Msg_Sloc
:= Sloc
(Lab
);
1791 ("implicit label declaration for & is hidden#",
1799 -- Perform semantic analysis on all statements
1801 Conditional_Statements_Begin
;
1804 while Present
(S
) loop
1809 Conditional_Statements_End
;
1811 -- Make labels unreachable. Visibility is not sufficient, because
1812 -- labels in one if-branch for example are not reachable from the
1813 -- other branch, even though their declarations are in the enclosing
1814 -- declarative part.
1817 while Present
(S
) loop
1818 if Nkind
(S
) = N_Label
then
1819 Set_Reachable
(Entity
(Identifier
(S
)), False);
1824 end Analyze_Statements
;
1826 --------------------------------------------
1827 -- Check_Possible_Current_Value_Condition --
1828 --------------------------------------------
1830 procedure Check_Possible_Current_Value_Condition
(Cnode
: Node_Id
) is
1834 -- Loop to deal with (ignore for now) any NOT operators present
1836 Cond
:= Condition
(Cnode
);
1837 while Nkind
(Cond
) = N_Op_Not
loop
1838 Cond
:= Right_Opnd
(Cond
);
1841 -- Check possible relational operator
1843 if Nkind
(Cond
) = N_Op_Eq
1845 Nkind
(Cond
) = N_Op_Ne
1847 Nkind
(Cond
) = N_Op_Ge
1849 Nkind
(Cond
) = N_Op_Le
1851 Nkind
(Cond
) = N_Op_Gt
1853 Nkind
(Cond
) = N_Op_Lt
1855 if Compile_Time_Known_Value
(Right_Opnd
(Cond
))
1856 and then Nkind
(Left_Opnd
(Cond
)) = N_Identifier
1859 Ent
: constant Entity_Id
:= Entity
(Left_Opnd
(Cond
));
1862 if Ekind
(Ent
) = E_Variable
1864 Ekind
(Ent
) = E_Constant
1868 Ekind
(Ent
) = E_Loop_Parameter
1870 -- Here we have a case where the Current_Value field
1871 -- may need to be set. We set it if it is not already
1872 -- set to a compile time expression value.
1874 -- Note that this represents a decision that one
1875 -- condition blots out another previous one. That's
1876 -- certainly right if they occur at the same level.
1877 -- If the second one is nested, then the decision is
1878 -- neither right nor wrong (it would be equally OK
1879 -- to leave the outer one in place, or take the new
1880 -- inner one. Really we should record both, but our
1881 -- data structures are not that elaborate.
1883 if Nkind
(Current_Value
(Ent
)) not in N_Subexpr
then
1884 Set_Current_Value
(Ent
, Cnode
);
1890 end Check_Possible_Current_Value_Condition
;
1892 ----------------------------
1893 -- Check_Unreachable_Code --
1894 ----------------------------
1896 procedure Check_Unreachable_Code
(N
: Node_Id
) is
1897 Error_Loc
: Source_Ptr
;
1901 if Is_List_Member
(N
)
1902 and then Comes_From_Source
(N
)
1908 Nxt
:= Original_Node
(Next
(N
));
1910 -- If a label follows us, then we never have dead code, since
1911 -- someone could branch to the label, so we just ignore it.
1913 if Nkind
(Nxt
) = N_Label
then
1916 -- Otherwise see if we have a real statement following us
1919 and then Comes_From_Source
(Nxt
)
1920 and then Is_Statement
(Nxt
)
1922 -- Special very annoying exception. If we have a return that
1923 -- follows a raise, then we allow it without a warning, since
1924 -- the Ada RM annoyingly requires a useless return here!
1926 if Nkind
(Original_Node
(N
)) /= N_Raise_Statement
1927 or else Nkind
(Nxt
) /= N_Return_Statement
1929 -- The rather strange shenanigans with the warning message
1930 -- here reflects the fact that Kill_Dead_Code is very good
1931 -- at removing warnings in deleted code, and this is one
1932 -- warning we would prefer NOT to have removed :-)
1934 Error_Loc
:= Sloc
(Nxt
);
1936 -- If we have unreachable code, analyze and remove the
1937 -- unreachable code, since it is useless and we don't
1938 -- want to generate junk warnings.
1940 -- We skip this step if we are not in code generation mode.
1941 -- This is the one case where we remove dead code in the
1942 -- semantics as opposed to the expander, and we do not want
1943 -- to remove code if we are not in code generation mode,
1944 -- since this messes up the ASIS trees.
1946 -- Note that one might react by moving the whole circuit to
1947 -- exp_ch5, but then we lose the warning in -gnatc mode.
1949 if Operating_Mode
= Generate_Code
then
1953 -- Quit deleting when we have nothing more to delete
1954 -- or if we hit a label (since someone could transfer
1955 -- control to a label, so we should not delete it).
1957 exit when No
(Nxt
) or else Nkind
(Nxt
) = N_Label
;
1959 -- Statement/declaration is to be deleted
1963 Kill_Dead_Code
(Nxt
);
1967 -- Now issue the warning
1969 Error_Msg
("?unreachable code", Error_Loc
);
1972 -- If the unconditional transfer of control instruction is
1973 -- the last statement of a sequence, then see if our parent
1974 -- is one of the constructs for which we count unblocked exits,
1975 -- and if so, adjust the count.
1980 -- Statements in THEN part or ELSE part of IF statement
1982 if Nkind
(P
) = N_If_Statement
then
1985 -- Statements in ELSIF part of an IF statement
1987 elsif Nkind
(P
) = N_Elsif_Part
then
1989 pragma Assert
(Nkind
(P
) = N_If_Statement
);
1991 -- Statements in CASE statement alternative
1993 elsif Nkind
(P
) = N_Case_Statement_Alternative
then
1995 pragma Assert
(Nkind
(P
) = N_Case_Statement
);
1997 -- Statements in body of block
1999 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
2000 and then Nkind
(Parent
(P
)) = N_Block_Statement
2004 -- Statements in exception handler in a block
2006 elsif Nkind
(P
) = N_Exception_Handler
2007 and then Nkind
(Parent
(P
)) = N_Handled_Sequence_Of_Statements
2008 and then Nkind
(Parent
(Parent
(P
))) = N_Block_Statement
2012 -- None of these cases, so return
2018 -- This was one of the cases we are looking for (i.e. the
2019 -- parent construct was IF, CASE or block) so decrement count.
2021 Unblocked_Exit_Count
:= Unblocked_Exit_Count
- 1;
2025 end Check_Unreachable_Code
;