1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Checks
; use Checks
;
30 with Einfo
; use Einfo
;
31 with Errout
; use Errout
;
32 with Expander
; use Expander
;
33 with Exp_Util
; use Exp_Util
;
34 with Freeze
; use Freeze
;
35 with Lib
.Xref
; use Lib
.Xref
;
36 with Nlists
; use Nlists
;
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 Tbuild
; use Tbuild
;
51 with Uintp
; use Uintp
;
53 package body Sem_Ch5
is
55 Unblocked_Exit_Count
: Nat
:= 0;
56 -- This variable is used when processing if statements or case
57 -- statements, it counts the number of branches of the conditional
58 -- that are not blocked by unconditional transfer instructions. At
59 -- the end of processing, if the count is zero, it means that control
60 -- cannot fall through the conditional statement. This is used for
61 -- the generation of warning messages. This variable is recursively
62 -- saved on entry to processing an if or case, and restored on exit.
64 -----------------------
65 -- Local Subprograms --
66 -----------------------
68 procedure Analyze_Iteration_Scheme
(N
: Node_Id
);
70 ------------------------
71 -- Analyze_Assignment --
72 ------------------------
74 procedure Analyze_Assignment
(N
: Node_Id
) is
75 Lhs
: constant Node_Id
:= Name
(N
);
76 Rhs
: constant Node_Id
:= Expression
(N
);
80 procedure Diagnose_Non_Variable_Lhs
(N
: Node_Id
);
81 -- N is the node for the left hand side of an assignment, and it
82 -- is not a variable. This routine issues an appropriate diagnostic.
84 procedure Set_Assignment_Type
86 Opnd_Type
: in out Entity_Id
);
87 -- Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type
88 -- is the nominal subtype. This procedure is used to deal with cases
89 -- where the nominal subtype must be replaced by the actual subtype.
91 -------------------------------
92 -- Diagnose_Non_Variable_Lhs --
93 -------------------------------
95 procedure Diagnose_Non_Variable_Lhs
(N
: Node_Id
) is
97 -- Not worth posting another error if left hand side already
98 -- flagged as being illegal in some respect
100 if Error_Posted
(N
) then
103 -- Some special bad cases of entity names
105 elsif Is_Entity_Name
(N
) then
107 if Ekind
(Entity
(N
)) = E_In_Parameter
then
109 ("assignment to IN mode parameter not allowed", N
);
112 -- Private declarations in a protected object are turned into
113 -- constants when compiling a protected function.
115 elsif Present
(Scope
(Entity
(N
)))
116 and then Is_Protected_Type
(Scope
(Entity
(N
)))
118 (Ekind
(Current_Scope
) = E_Function
120 Ekind
(Enclosing_Dynamic_Scope
(Current_Scope
)) = E_Function
)
123 ("protected function cannot modify protected object", N
);
126 elsif Ekind
(Entity
(N
)) = E_Loop_Parameter
then
128 ("assignment to loop parameter not allowed", N
);
133 -- For indexed components, or selected components, test prefix
135 elsif Nkind
(N
) = N_Indexed_Component
136 or else Nkind
(N
) = N_Selected_Component
138 Diagnose_Non_Variable_Lhs
(Prefix
(N
));
142 -- If we fall through, we have no special message to issue!
144 Error_Msg_N
("left hand side of assignment must be a variable", N
);
146 end Diagnose_Non_Variable_Lhs
;
148 -------------------------
149 -- Set_Assignment_Type --
150 -------------------------
152 procedure Set_Assignment_Type
154 Opnd_Type
: in out Entity_Id
)
157 -- If the assignment operand is an in-out or out parameter, then we
158 -- get the actual subtype (needed for the unconstrained case).
160 if Is_Entity_Name
(Opnd
)
161 and then (Ekind
(Entity
(Opnd
)) = E_Out_Parameter
162 or else Ekind
(Entity
(Opnd
)) =
164 or else Ekind
(Entity
(Opnd
)) =
165 E_Generic_In_Out_Parameter
)
167 Opnd_Type
:= Get_Actual_Subtype
(Opnd
);
169 -- If assignment operand is a component reference, then we get the
170 -- actual subtype of the component for the unconstrained case.
172 elsif Nkind
(Opnd
) = N_Selected_Component
173 or else Nkind
(Opnd
) = N_Explicit_Dereference
175 Decl
:= Build_Actual_Subtype_Of_Component
(Opnd_Type
, Opnd
);
177 if Present
(Decl
) then
178 Insert_Action
(N
, Decl
);
179 Mark_Rewrite_Insertion
(Decl
);
181 Opnd_Type
:= Defining_Identifier
(Decl
);
182 Set_Etype
(Opnd
, Opnd_Type
);
183 Freeze_Itype
(Opnd_Type
, N
);
185 elsif Is_Constrained
(Etype
(Opnd
)) then
186 Opnd_Type
:= Etype
(Opnd
);
189 -- For slice, use the constrained subtype created for the slice
191 elsif Nkind
(Opnd
) = N_Slice
then
192 Opnd_Type
:= Etype
(Opnd
);
194 end Set_Assignment_Type
;
196 -- Start of processing for Analyze_Assignment
203 -- In the most general case, both Lhs and Rhs can be overloaded, and we
204 -- must compute the intersection of the possible types on each side.
206 if Is_Overloaded
(Lhs
) then
213 Get_First_Interp
(Lhs
, I
, It
);
215 while Present
(It
.Typ
) loop
216 if Has_Compatible_Type
(Rhs
, It
.Typ
) then
218 if T1
/= Any_Type
then
220 -- An explicit dereference is overloaded if the prefix
221 -- is. Try to remove the ambiguity on the prefix, the
222 -- error will be posted there if the ambiguity is real.
224 if Nkind
(Lhs
) = N_Explicit_Dereference
then
227 PI1
: Interp_Index
:= 0;
233 Get_First_Interp
(Prefix
(Lhs
), PI
, PIt
);
235 while Present
(PIt
.Typ
) loop
236 if Has_Compatible_Type
(Rhs
,
237 Designated_Type
(PIt
.Typ
))
241 Disambiguate
(Prefix
(Lhs
),
244 if PIt
= No_Interp
then
247 Resolve
(Prefix
(Lhs
), PIt
.Typ
);
257 Get_Next_Interp
(PI
, PIt
);
263 ("ambiguous left-hand side in assignment", Lhs
);
271 Get_Next_Interp
(I
, It
);
275 if T1
= Any_Type
then
277 ("no valid types for left-hand side for assignment", Lhs
);
284 if not Is_Variable
(Lhs
) then
285 Diagnose_Non_Variable_Lhs
(Lhs
);
288 elsif Is_Limited_Type
(T1
)
289 and then not Assignment_OK
(Lhs
)
290 and then not Assignment_OK
(Original_Node
(Lhs
))
293 ("left hand of assignment must not be limited type", Lhs
);
297 -- Resolution may have updated the subtype, in case the left-hand
298 -- side is a private protected component. Use the correct subtype
299 -- to avoid scoping issues in the back-end.
302 Set_Assignment_Type
(Lhs
, T1
);
306 -- Remaining steps are skipped if Rhs was synatactically in error
313 Check_Unset_Reference
(Rhs
);
314 Note_Possible_Modification
(Lhs
);
316 if Covers
(T1
, T2
) then
319 Wrong_Type
(Rhs
, Etype
(Lhs
));
323 Set_Assignment_Type
(Rhs
, T2
);
325 if T1
= Any_Type
or else T2
= Any_Type
then
329 if (Is_Class_Wide_Type
(T2
) or else Is_Dynamically_Tagged
(Rhs
))
330 and then not Is_Class_Wide_Type
(T1
)
332 Error_Msg_N
("dynamically tagged expression not allowed!", Rhs
);
334 elsif Is_Class_Wide_Type
(T1
)
335 and then not Is_Class_Wide_Type
(T2
)
336 and then not Is_Tag_Indeterminate
(Rhs
)
337 and then not Is_Dynamically_Tagged
(Rhs
)
339 Error_Msg_N
("dynamically tagged expression required!", Rhs
);
342 -- Tag propagation is done only in semantics mode only. If expansion
343 -- is on, the rhs tag indeterminate function call has been expanded
344 -- and tag propagation would have happened too late, so the
345 -- propagation take place in expand_call instead.
347 if not Expander_Active
348 and then Is_Class_Wide_Type
(T1
)
349 and then Is_Tag_Indeterminate
(Rhs
)
351 Propagate_Tag
(Lhs
, Rhs
);
354 if Is_Scalar_Type
(T1
) then
355 Apply_Scalar_Range_Check
(Rhs
, Etype
(Lhs
));
357 elsif Is_Array_Type
(T1
) then
359 -- Assignment verifies that the length of the Lsh and Rhs are equal,
360 -- but of course the indices do not have to match.
362 Apply_Length_Check
(Rhs
, Etype
(Lhs
));
365 -- Discriminant checks are applied in the course of expansion.
369 -- ??? a real accessibility check is needed when ???
371 -- Post warning for useless assignment
373 if Warn_On_Redundant_Constructs
375 -- We only warn for source constructs
377 and then Comes_From_Source
(N
)
379 -- Where the entity is the same on both sides
381 and then Is_Entity_Name
(Lhs
)
382 and then Is_Entity_Name
(Rhs
)
383 and then Entity
(Lhs
) = Entity
(Rhs
)
385 -- But exclude the case where the right side was an operation
386 -- that got rewritten (e.g. JUNK + K, where K was known to be
387 -- zero). We don't want to warn in such a case, since it is
388 -- reasonable to write such expressions especially when K is
389 -- defined symbolically in some other package.
391 and then Nkind
(Original_Node
(Rhs
)) not in N_Op
394 ("?useless assignment of & to itself", N
, Entity
(Lhs
));
396 end Analyze_Assignment
;
398 -----------------------------
399 -- Analyze_Block_Statement --
400 -----------------------------
402 procedure Analyze_Block_Statement
(N
: Node_Id
) is
403 Decls
: constant List_Id
:= Declarations
(N
);
404 Id
: constant Node_Id
:= Identifier
(N
);
408 -- If a label is present analyze it and mark it as referenced
413 Set_Ekind
(Ent
, E_Block
);
414 Generate_Reference
(Ent
, N
, ' ');
415 Generate_Definition
(Ent
);
417 if Nkind
(Parent
(Ent
)) = N_Implicit_Label_Declaration
then
418 Set_Label_Construct
(Parent
(Ent
), N
);
421 -- Otherwise create a label entity
424 Ent
:= New_Internal_Entity
(E_Block
, Current_Scope
, Sloc
(N
), 'B');
425 Set_Identifier
(N
, New_Occurrence_Of
(Ent
, Sloc
(N
)));
428 Set_Etype
(Ent
, Standard_Void_Type
);
429 Set_Block_Node
(Ent
, Identifier
(N
));
432 if Present
(Decls
) then
433 Analyze_Declarations
(Decls
);
437 Analyze
(Handled_Statement_Sequence
(N
));
438 Process_End_Label
(Handled_Statement_Sequence
(N
), 'e', Ent
);
440 -- Analyze exception handlers if present. Note that the test for
441 -- HSS being present is an error defence against previous errors.
443 if Present
(Handled_Statement_Sequence
(N
))
444 and then Present
(Exception_Handlers
(Handled_Statement_Sequence
(N
)))
447 S
: Entity_Id
:= Scope
(Ent
);
450 -- Indicate that enclosing scopes contain a block with handlers.
451 -- Only non-generic scopes need to be marked.
454 Set_Has_Nested_Block_With_Handler
(S
);
455 exit when Is_Overloadable
(S
)
456 or else Ekind
(S
) = E_Package
457 or else Ekind
(S
) = E_Generic_Function
458 or else Ekind
(S
) = E_Generic_Package
459 or else Ekind
(S
) = E_Generic_Procedure
;
465 Check_References
(Ent
);
467 end Analyze_Block_Statement
;
469 ----------------------------
470 -- Analyze_Case_Statement --
471 ----------------------------
473 procedure Analyze_Case_Statement
(N
: Node_Id
) is
475 Statements_Analyzed
: Boolean := False;
476 -- Set True if at least some statement sequences get analyzed.
477 -- If False on exit, means we had a serious error that prevented
478 -- full analysis of the case statement, and as a result it is not
479 -- a good idea to output warning messages about unreachable code.
481 Save_Unblocked_Exit_Count
: constant Nat
:= Unblocked_Exit_Count
;
482 -- Recursively save value of this global, will be restored on exit
484 procedure Non_Static_Choice_Error
(Choice
: Node_Id
);
485 -- Error routine invoked by the generic instantiation below when
486 -- the case statement has a non static choice.
488 procedure Process_Statements
(Alternative
: Node_Id
);
489 -- Analyzes all the statements associated to a case alternative.
490 -- Needed by the generic instantiation below.
492 package Case_Choices_Processing
is new
493 Generic_Choices_Processing
494 (Get_Alternatives
=> Alternatives
,
495 Get_Choices
=> Discrete_Choices
,
496 Process_Empty_Choice
=> No_OP
,
497 Process_Non_Static_Choice
=> Non_Static_Choice_Error
,
498 Process_Associated_Node
=> Process_Statements
);
499 use Case_Choices_Processing
;
500 -- Instantiation of the generic choice processing package.
502 -----------------------------
503 -- Non_Static_Choice_Error --
504 -----------------------------
506 procedure Non_Static_Choice_Error
(Choice
: Node_Id
) is
508 Error_Msg_N
("choice given in case statement is not static", Choice
);
509 end Non_Static_Choice_Error
;
511 ------------------------
512 -- Process_Statements --
513 ------------------------
515 procedure Process_Statements
(Alternative
: Node_Id
) is
517 Unblocked_Exit_Count
:= Unblocked_Exit_Count
+ 1;
518 Statements_Analyzed
:= True;
519 Analyze_Statements
(Statements
(Alternative
));
520 end Process_Statements
;
522 -- Variables local to Analyze_Case_Statement.
525 Exp_Type
: Entity_Id
;
526 Exp_Btype
: Entity_Id
;
528 Case_Table
: Choice_Table_Type
(1 .. Number_Of_Choices
(N
));
531 Others_Present
: Boolean;
533 -- Start of processing for Analyze_Case_Statement
536 Unblocked_Exit_Count
:= 0;
537 Exp
:= Expression
(N
);
538 Analyze_And_Resolve
(Exp
, Any_Discrete
);
539 Check_Unset_Reference
(Exp
);
540 Exp_Type
:= Etype
(Exp
);
541 Exp_Btype
:= Base_Type
(Exp_Type
);
543 -- The expression must be of a discrete type which must be determinable
544 -- independently of the context in which the expression occurs, but
545 -- using the fact that the expression must be of a discrete type.
546 -- Moreover, the type this expression must not be a character literal
547 -- (which is always ambiguous) or, for Ada-83, a generic formal type.
549 -- If error already reported by Resolve, nothing more to do
551 if Exp_Btype
= Any_Discrete
552 or else Exp_Btype
= Any_Type
556 elsif Exp_Btype
= Any_Character
then
558 ("character literal as case expression is ambiguous", Exp
);
562 and then (Is_Generic_Type
(Exp_Btype
)
563 or else Is_Generic_Type
(Root_Type
(Exp_Btype
)))
566 ("(Ada 83) case expression cannot be of a generic type", Exp
);
570 -- If the case expression is a formal object of mode in out,
571 -- then treat it as having a nonstatic subtype by forcing
572 -- use of the base type (which has to get passed to
573 -- Check_Case_Choices below). Also use base type when
574 -- the case expression is parenthesized.
576 if Paren_Count
(Exp
) > 0
577 or else (Is_Entity_Name
(Exp
)
578 and then Ekind
(Entity
(Exp
)) = E_Generic_In_Out_Parameter
)
580 Exp_Type
:= Exp_Btype
;
583 -- Call the instantiated Analyze_Choices which does the rest of the work
586 (N
, Exp_Type
, Case_Table
, Last_Choice
, Dont_Care
, Others_Present
);
588 if Exp_Type
= Universal_Integer
and then not Others_Present
then
589 Error_Msg_N
("case on universal integer requires OTHERS choice", Exp
);
592 -- If all our exits were blocked by unconditional transfers of control,
593 -- then the entire CASE statement acts as an unconditional transfer of
594 -- control, so treat it like one, and check unreachable code. Skip this
595 -- test if we had serious errors preventing any statement analysis.
597 if Unblocked_Exit_Count
= 0 and then Statements_Analyzed
then
598 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
599 Check_Unreachable_Code
(N
);
601 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
603 end Analyze_Case_Statement
;
605 ----------------------------
606 -- Analyze_Exit_Statement --
607 ----------------------------
609 -- If the exit includes a name, it must be the name of a currently open
610 -- loop. Otherwise there must be an innermost open loop on the stack,
611 -- to which the statement implicitly refers.
613 procedure Analyze_Exit_Statement
(N
: Node_Id
) is
614 Target
: constant Node_Id
:= Name
(N
);
615 Cond
: constant Node_Id
:= Condition
(N
);
616 Scope_Id
: Entity_Id
;
622 Check_Unreachable_Code
(N
);
625 if Present
(Target
) then
627 U_Name
:= Entity
(Target
);
629 if not In_Open_Scopes
(U_Name
) or else Ekind
(U_Name
) /= E_Loop
then
630 Error_Msg_N
("invalid loop name in exit statement", N
);
633 Set_Has_Exit
(U_Name
);
640 for J
in reverse 0 .. Scope_Stack
.Last
loop
641 Scope_Id
:= Scope_Stack
.Table
(J
).Entity
;
642 Kind
:= Ekind
(Scope_Id
);
645 and then (No
(Target
) or else Scope_Id
= U_Name
) then
646 Set_Has_Exit
(Scope_Id
);
649 elsif Kind
= E_Block
or else Kind
= E_Loop
then
654 ("cannot exit from program unit or accept statement", N
);
659 -- Verify that if present the condition is a Boolean expression.
661 if Present
(Cond
) then
662 Analyze_And_Resolve
(Cond
, Any_Boolean
);
663 Check_Unset_Reference
(Cond
);
665 end Analyze_Exit_Statement
;
667 ----------------------------
668 -- Analyze_Goto_Statement --
669 ----------------------------
671 procedure Analyze_Goto_Statement
(N
: Node_Id
) is
672 Label
: constant Node_Id
:= Name
(N
);
673 Scope_Id
: Entity_Id
;
674 Label_Scope
: Entity_Id
;
677 Check_Unreachable_Code
(N
);
681 if Entity
(Label
) = Any_Id
then
684 elsif Ekind
(Entity
(Label
)) /= E_Label
then
685 Error_Msg_N
("target of goto statement must be a label", Label
);
688 elsif not Reachable
(Entity
(Label
)) then
689 Error_Msg_N
("target of goto statement is not reachable", Label
);
693 Label_Scope
:= Enclosing_Scope
(Entity
(Label
));
695 for J
in reverse 0 .. Scope_Stack
.Last
loop
696 Scope_Id
:= Scope_Stack
.Table
(J
).Entity
;
698 if Label_Scope
= Scope_Id
699 or else (Ekind
(Scope_Id
) /= E_Block
700 and then Ekind
(Scope_Id
) /= E_Loop
)
702 if Scope_Id
/= Label_Scope
then
704 ("cannot exit from program unit or accept statement", N
);
713 end Analyze_Goto_Statement
;
715 --------------------------
716 -- Analyze_If_Statement --
717 --------------------------
719 -- A special complication arises in the analysis of if statements.
720 -- The expander has circuitry to completely deleted code that it
721 -- can tell will not be executed (as a result of compile time known
722 -- conditions). In the analyzer, we ensure that code that will be
723 -- deleted in this manner is analyzed but not expanded. This is
724 -- obviously more efficient, but more significantly, difficulties
725 -- arise if code is expanded and then eliminated (e.g. exception
726 -- table entries disappear).
728 procedure Analyze_If_Statement
(N
: Node_Id
) is
731 Save_Unblocked_Exit_Count
: constant Nat
:= Unblocked_Exit_Count
;
732 -- Recursively save value of this global, will be restored on exit
734 Del
: Boolean := False;
735 -- This flag gets set True if a True condition has been found,
736 -- which means that remaining ELSE/ELSIF parts are deleted.
738 procedure Analyze_Cond_Then
(Cnode
: Node_Id
);
739 -- This is applied to either the N_If_Statement node itself or
740 -- to an N_Elsif_Part node. It deals with analyzing the condition
741 -- and the THEN statements associated with it.
743 procedure Analyze_Cond_Then
(Cnode
: Node_Id
) is
744 Cond
: constant Node_Id
:= Condition
(Cnode
);
745 Tstm
: constant List_Id
:= Then_Statements
(Cnode
);
748 Unblocked_Exit_Count
:= Unblocked_Exit_Count
+ 1;
749 Analyze_And_Resolve
(Cond
, Any_Boolean
);
750 Check_Unset_Reference
(Cond
);
752 -- If already deleting, then just analyze then statements
755 Analyze_Statements
(Tstm
);
757 -- Compile time known value, not deleting yet
759 elsif Compile_Time_Known_Value
(Cond
) then
761 -- If condition is True, then analyze the THEN statements
762 -- and set no expansion for ELSE and ELSIF parts.
764 if Is_True
(Expr_Value
(Cond
)) then
765 Analyze_Statements
(Tstm
);
767 Expander_Mode_Save_And_Set
(False);
769 -- If condition is False, analyze THEN with expansion off
771 else -- Is_False (Expr_Value (Cond))
772 Expander_Mode_Save_And_Set
(False);
773 Analyze_Statements
(Tstm
);
774 Expander_Mode_Restore
;
777 -- Not known at compile time, not deleting, normal analysis
780 Analyze_Statements
(Tstm
);
782 end Analyze_Cond_Then
;
784 -- Start of Analyze_If_Statement
787 -- Initialize exit count for else statements. If there is no else
788 -- part, this count will stay non-zero reflecting the fact that the
789 -- uncovered else case is an unblocked exit.
791 Unblocked_Exit_Count
:= 1;
792 Analyze_Cond_Then
(N
);
794 -- Now to analyze the elsif parts if any are present
796 if Present
(Elsif_Parts
(N
)) then
797 E
:= First
(Elsif_Parts
(N
));
798 while Present
(E
) loop
799 Analyze_Cond_Then
(E
);
804 if Present
(Else_Statements
(N
)) then
805 Analyze_Statements
(Else_Statements
(N
));
808 -- If all our exits were blocked by unconditional transfers of control,
809 -- then the entire IF statement acts as an unconditional transfer of
810 -- control, so treat it like one, and check unreachable code.
812 if Unblocked_Exit_Count
= 0 then
813 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
814 Check_Unreachable_Code
(N
);
816 Unblocked_Exit_Count
:= Save_Unblocked_Exit_Count
;
820 Expander_Mode_Restore
;
823 end Analyze_If_Statement
;
825 ----------------------------------------
826 -- Analyze_Implicit_Label_Declaration --
827 ----------------------------------------
829 -- An implicit label declaration is generated in the innermost
830 -- enclosing declarative part. This is done for labels as well as
831 -- block and loop names.
833 -- Note: any changes in this routine may need to be reflected in
834 -- Analyze_Label_Entity.
836 procedure Analyze_Implicit_Label_Declaration
(N
: Node_Id
) is
837 Id
: Node_Id
:= Defining_Identifier
(N
);
841 Set_Ekind
(Id
, E_Label
);
842 Set_Etype
(Id
, Standard_Void_Type
);
843 Set_Enclosing_Scope
(Id
, Current_Scope
);
844 end Analyze_Implicit_Label_Declaration
;
846 ------------------------------
847 -- Analyze_Iteration_Scheme --
848 ------------------------------
850 procedure Analyze_Iteration_Scheme
(N
: Node_Id
) is
852 -- For an infinite loop, there is no iteration scheme
859 Cond
: constant Node_Id
:= Condition
(N
);
862 -- For WHILE loop, verify that the condition is a Boolean
863 -- expression and resolve and check it.
865 if Present
(Cond
) then
866 Analyze_And_Resolve
(Cond
, Any_Boolean
);
867 Check_Unset_Reference
(Cond
);
869 -- Else we have a FOR loop
873 LP
: constant Node_Id
:= Loop_Parameter_Specification
(N
);
874 Id
: constant Entity_Id
:= Defining_Identifier
(LP
);
875 DS
: constant Node_Id
:= Discrete_Subtype_Definition
(LP
);
881 -- We always consider the loop variable to be referenced,
882 -- since the loop may be used just for counting purposes.
884 Generate_Reference
(Id
, N
, ' ');
886 -- Check for case of loop variable hiding a local
887 -- variable (used later on to give a nice warning
888 -- if the hidden variable is never assigned).
891 H
: constant Entity_Id
:= Homonym
(Id
);
895 and then Enclosing_Dynamic_Scope
(H
) =
896 Enclosing_Dynamic_Scope
(Id
)
897 and then Ekind
(H
) = E_Variable
898 and then Is_Discrete_Type
(Etype
(H
))
900 Set_Hiding_Loop_Variable
(H
, Id
);
904 -- Now analyze the subtype definition
912 -- The subtype indication may denote the completion
913 -- of an incomplete type declaration.
915 if Is_Entity_Name
(DS
)
916 and then Present
(Entity
(DS
))
917 and then Is_Type
(Entity
(DS
))
918 and then Ekind
(Entity
(DS
)) = E_Incomplete_Type
920 Set_Entity
(DS
, Get_Full_View
(Entity
(DS
)));
921 Set_Etype
(DS
, Entity
(DS
));
924 if not Is_Discrete_Type
(Etype
(DS
)) then
925 Wrong_Type
(DS
, Any_Discrete
);
926 Set_Etype
(DS
, Any_Type
);
931 Set_Ekind
(Id
, E_Loop_Parameter
);
932 Set_Etype
(Id
, Etype
(DS
));
933 Set_Is_Known_Valid
(Id
, True);
935 -- The loop is not a declarative part, so the only entity
936 -- declared "within" must be frozen explicitly. Since the
937 -- type of this entity has already been frozen, this cannot
938 -- generate any freezing actions.
940 F
:= Freeze_Entity
(Id
, Sloc
(LP
));
941 pragma Assert
(F
= No_List
);
943 -- Check for null or possibly null range and issue warning.
944 -- We suppress such messages in generic templates and
945 -- instances, because in practice they tend to be dubious
948 if Nkind
(DS
) = N_Range
949 and then Comes_From_Source
(N
)
950 and then not Inside_A_Generic
951 and then not In_Instance
954 L
: constant Node_Id
:= Low_Bound
(DS
);
955 H
: constant Node_Id
:= High_Bound
(DS
);
965 Determine_Range
(L
, LOK
, Llo
, Lhi
);
966 Determine_Range
(H
, HOK
, Hlo
, Hhi
);
968 -- If range of loop is null, issue warning
970 if (LOK
and HOK
) and then Llo
> Hhi
then
972 ("?loop range is null, loop will not execute",
975 -- The other case for a warning is a reverse loop
976 -- where the upper bound is the integer literal
977 -- zero or one, and the lower bound can be positive.
979 elsif Reverse_Present
(LP
)
980 and then Nkind
(H
) = N_Integer_Literal
981 and then (Intval
(H
) = Uint_0
986 Warn_On_Instance
:= True;
987 Error_Msg_N
("?loop range may be null", DS
);
988 Warn_On_Instance
:= False;
996 end Analyze_Iteration_Scheme
;
1002 -- Important note: normally this routine is called from Analyze_Statements
1003 -- which does a prescan, to make sure that the Reachable flags are set on
1004 -- all labels before encountering a possible goto to one of these labels.
1005 -- If expanded code analyzes labels via the normal Sem path, then it must
1006 -- ensure that Reachable is set early enough to avoid problems in the case
1007 -- of a forward goto.
1009 procedure Analyze_Label
(N
: Node_Id
) is
1013 Analyze
(Identifier
(N
));
1014 Lab
:= Entity
(Identifier
(N
));
1016 -- If we found a label mark it as reachable.
1018 if Ekind
(Lab
) = E_Label
then
1019 Generate_Definition
(Lab
);
1020 Set_Reachable
(Lab
);
1022 if Nkind
(Parent
(Lab
)) = N_Implicit_Label_Declaration
then
1023 Set_Label_Construct
(Parent
(Lab
), N
);
1026 -- If we failed to find a label, it means the implicit declaration
1027 -- of the label was hidden. A for-loop parameter can do this to a
1028 -- label with the same name inside the loop, since the implicit label
1029 -- declaration is in the innermost enclosing body or block statement.
1032 Error_Msg_Sloc
:= Sloc
(Lab
);
1034 ("implicit label declaration for & is hidden#",
1039 --------------------------
1040 -- Analyze_Label_Entity --
1041 --------------------------
1043 procedure Analyze_Label_Entity
(E
: Entity_Id
) is
1045 Set_Ekind
(E
, E_Label
);
1046 Set_Etype
(E
, Standard_Void_Type
);
1047 Set_Enclosing_Scope
(E
, Current_Scope
);
1048 Set_Reachable
(E
, True);
1049 end Analyze_Label_Entity
;
1051 ----------------------------
1052 -- Analyze_Loop_Statement --
1053 ----------------------------
1055 procedure Analyze_Loop_Statement
(N
: Node_Id
) is
1056 Id
: constant Node_Id
:= Identifier
(N
);
1060 if Present
(Id
) then
1062 -- Make name visible, e.g. for use in exit statements. Loop
1063 -- labels are always considered to be referenced.
1067 Generate_Reference
(Ent
, N
, ' ');
1068 Generate_Definition
(Ent
);
1070 -- If we found a label, mark its type. If not, ignore it, since it
1071 -- means we have a conflicting declaration, which would already have
1072 -- been diagnosed at declaration time. Set Label_Construct of the
1073 -- implicit label declaration, which is not created by the parser
1074 -- for generic units.
1076 if Ekind
(Ent
) = E_Label
then
1077 Set_Ekind
(Ent
, E_Loop
);
1079 if Nkind
(Parent
(Ent
)) = N_Implicit_Label_Declaration
then
1080 Set_Label_Construct
(Parent
(Ent
), N
);
1084 -- Case of no identifier present
1087 Ent
:= New_Internal_Entity
(E_Loop
, Current_Scope
, Sloc
(N
), 'L');
1088 Set_Etype
(Ent
, Standard_Void_Type
);
1089 Set_Parent
(Ent
, N
);
1093 Analyze_Iteration_Scheme
(Iteration_Scheme
(N
));
1094 Analyze_Statements
(Statements
(N
));
1095 Process_End_Label
(N
, 'e', Ent
);
1097 end Analyze_Loop_Statement
;
1099 ----------------------------
1100 -- Analyze_Null_Statement --
1101 ----------------------------
1103 -- Note: the semantics of the null statement is implemented by a single
1104 -- null statement, too bad everything isn't as simple as this!
1106 procedure Analyze_Null_Statement
(N
: Node_Id
) is
1107 pragma Warnings
(Off
, N
);
1111 end Analyze_Null_Statement
;
1113 ------------------------
1114 -- Analyze_Statements --
1115 ------------------------
1117 procedure Analyze_Statements
(L
: List_Id
) is
1121 -- The labels declared in the statement list are reachable from
1122 -- statements in the list. We do this as a prepass so that any
1123 -- goto statement will be properly flagged if its target is not
1124 -- reachable. This is not required, but is nice behavior!
1128 while Present
(S
) loop
1129 if Nkind
(S
) = N_Label
then
1136 -- Perform semantic analysis on all statements
1140 while Present
(S
) loop
1142 if Nkind
(S
) /= N_Label
then
1149 -- Make labels unreachable. Visibility is not sufficient, because
1150 -- labels in one if-branch for example are not reachable from the
1151 -- other branch, even though their declarations are in the enclosing
1152 -- declarative part.
1156 while Present
(S
) loop
1157 if Nkind
(S
) = N_Label
then
1158 Set_Reachable
(Entity
(Identifier
(S
)), False);
1163 end Analyze_Statements
;
1165 ----------------------------
1166 -- Check_Unreachable_Code --
1167 ----------------------------
1169 procedure Check_Unreachable_Code
(N
: Node_Id
) is
1170 Error_Loc
: Source_Ptr
;
1174 if Is_List_Member
(N
)
1175 and then Comes_From_Source
(N
)
1181 Nxt
:= Original_Node
(Next
(N
));
1184 and then Comes_From_Source
(Nxt
)
1185 and then Is_Statement
(Nxt
)
1187 -- Special very annoying exception. If we have a return that
1188 -- follows a raise, then we allow it without a warning, since
1189 -- the Ada RM annoyingly requires a useless return here!
1191 if Nkind
(Original_Node
(N
)) /= N_Raise_Statement
1192 or else Nkind
(Nxt
) /= N_Return_Statement
1194 -- The rather strange shenanigans with the warning message
1195 -- here reflects the fact that Kill_Dead_Code is very good
1196 -- at removing warnings in deleted code, and this is one
1197 -- warning we would prefer NOT to have removed :-)
1199 Error_Loc
:= Sloc
(Nxt
);
1201 -- If we have unreachable code, analyze and remove the
1202 -- unreachable code, since it is useless and we don't
1203 -- want to generate junk warnings.
1205 -- We skip this step if we are not in code generation mode.
1206 -- This is the one case where we remove dead code in the
1207 -- semantics as opposed to the expander, and we do not want
1208 -- to remove code if we are not in code generation mode,
1209 -- since this messes up the ASIS trees.
1211 -- Note that one might react by moving the whole circuit to
1212 -- exp_ch5, but then we lose the warning in -gnatc mode.
1214 if Operating_Mode
= Generate_Code
then
1217 exit when No
(Nxt
) or else not Is_Statement
(Nxt
);
1220 Kill_Dead_Code
(Nxt
);
1224 -- Now issue the warning
1226 Error_Msg
("?unreachable code", Error_Loc
);
1229 -- If the unconditional transfer of control instruction is
1230 -- the last statement of a sequence, then see if our parent
1231 -- is an IF statement, and if so adjust the unblocked exit
1232 -- count of the if statement to reflect the fact that this
1233 -- branch of the if is indeed blocked by a transfer of control.
1238 if Nkind
(P
) = N_If_Statement
then
1241 elsif Nkind
(P
) = N_Elsif_Part
then
1243 pragma Assert
(Nkind
(P
) = N_If_Statement
);
1245 elsif Nkind
(P
) = N_Case_Statement_Alternative
then
1247 pragma Assert
(Nkind
(P
) = N_Case_Statement
);
1253 Unblocked_Exit_Count
:= Unblocked_Exit_Count
- 1;
1257 end Check_Unreachable_Code
;