1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1999-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 Accessibility
; use Accessibility
;
27 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Einfo
.Entities
; use Einfo
.Entities
;
31 with Einfo
.Utils
; use Einfo
.Utils
;
32 with Errout
; use Errout
;
33 with Exp_Code
; use Exp_Code
;
35 with Namet
; use Namet
;
36 with Nlists
; use Nlists
;
38 with Par_SCO
; use Par_SCO
;
39 with Rtsfind
; use Rtsfind
;
41 with Sem_Ch8
; use Sem_Ch8
;
42 with Sem_Aux
; use Sem_Aux
;
43 with Sem_Eval
; use Sem_Eval
;
44 with Sem_Prag
; use Sem_Prag
;
45 with Sem_Util
; use Sem_Util
;
46 with Sinfo
; use Sinfo
;
47 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
48 with Sinfo
.Utils
; use Sinfo
.Utils
;
49 with Sinput
; use Sinput
;
50 with Snames
; use Snames
;
51 with Stand
; use Stand
;
52 with Stringt
; use Stringt
;
53 with Tbuild
; use Tbuild
;
54 with Uintp
; use Uintp
;
55 with Warnsw
; use Warnsw
;
57 package body Sem_Warn
is
59 -- The following table collects Id's of entities that are potentially
60 -- unreferenced. See Check_Unset_Reference for further details.
61 -- ??? Check_Unset_Reference has zero information about this table.
63 package Unreferenced_Entities
is new Table
.Table
(
64 Table_Component_Type
=> Entity_Id
,
65 Table_Index_Type
=> Nat
,
67 Table_Initial
=> Alloc
.Unreferenced_Entities_Initial
,
68 Table_Increment
=> Alloc
.Unreferenced_Entities_Increment
,
69 Table_Name
=> "Unreferenced_Entities");
71 -- The following table collects potential warnings for IN OUT parameters
72 -- that are referenced but not modified. These warnings are processed when
73 -- the front end calls the procedure Output_Non_Modified_In_Out_Warnings.
74 -- The reason that we defer output of these messages is that we want to
75 -- detect the case where the relevant procedure is used as a generic actual
76 -- in an instantiation, since we suppress the warnings in this case. The
77 -- flag Used_As_Generic_Actual will be set in this case, but only at the
78 -- point of usage. Similarly, we suppress the message if the address of the
79 -- procedure is taken, where the flag Address_Taken may be set later.
81 package In_Out_Warnings
is new Table
.Table
(
82 Table_Component_Type
=> Entity_Id
,
83 Table_Index_Type
=> Nat
,
85 Table_Initial
=> Alloc
.In_Out_Warnings_Initial
,
86 Table_Increment
=> Alloc
.In_Out_Warnings_Increment
,
87 Table_Name
=> "In_Out_Warnings");
89 --------------------------------------------------------
90 -- Handling of Warnings Off, Unmodified, Unreferenced --
91 --------------------------------------------------------
93 -- The functions Has_Warnings_Off, Has_Unmodified, Has_Unreferenced must
94 -- generally be used instead of Warnings_Off, Has_Pragma_Unmodified and
95 -- Has_Pragma_Unreferenced, as noted in the specs in Einfo.
97 -- In order to avoid losing warnings in -gnatw.w (warn on unnecessary
98 -- warnings off pragma) mode, i.e. to avoid false negatives, the code
99 -- must follow some important rules.
101 -- Call these functions as late as possible, after completing all other
102 -- tests, just before the warnings is given. For example, don't write:
104 -- if not Has_Warnings_Off (E)
105 -- and then some-other-predicate-on-E then ..
107 -- Instead the following is preferred
109 -- if some-other-predicate-on-E
110 -- and then Has_Warnings_Off (E)
112 -- This way if some-other-predicate is false, we avoid a false indication
113 -- that a Warnings (Off, E) pragma was useful in preventing a warning.
115 -- The second rule is that if both Has_Unmodified and Has_Warnings_Off, or
116 -- Has_Unreferenced and Has_Warnings_Off are called, make sure that the
117 -- call to Has_Unmodified/Has_Unreferenced comes first, this way we record
118 -- that the Warnings (Off) could have been Unreferenced or Unmodified. In
119 -- fact Has_Unmodified/Has_Unreferenced includes a test for Warnings Off,
120 -- and so a subsequent test is not needed anyway (though it is harmless).
122 -----------------------
123 -- Local Subprograms --
124 -----------------------
126 function Generic_Package_Spec_Entity
(E
: Entity_Id
) return Boolean;
127 -- This returns true if the entity E is declared within a generic package.
128 -- The point of this is to detect variables which are not assigned within
129 -- the generic, but might be assigned outside the package for any given
130 -- instance. These are cases where we leave the warnings to be posted for
131 -- the instance, when we will know more.
133 function Goto_Spec_Entity
(E
: Entity_Id
) return Entity_Id
;
134 -- If E is a parameter entity for a subprogram body, then this function
135 -- returns the corresponding spec entity, if not, E is returned unchanged.
137 function Has_Pragma_Unmodified_Check_Spec
(E
: Entity_Id
) return Boolean;
138 -- Tests Has_Pragma_Unmodified flag for entity E. If E is not a formal,
139 -- this is simply the setting of the flag Has_Pragma_Unmodified. If E is
140 -- a body formal, the setting of the flag in the corresponding spec is
141 -- also checked (and True returned if either flag is True).
143 function Has_Pragma_Unreferenced_Check_Spec
(E
: Entity_Id
) return Boolean;
144 -- Tests Has_Pragma_Unreferenced flag for entity E. If E is not a formal,
145 -- this is simply the setting of the flag Has_Pragma_Unreferenced. If E is
146 -- a body formal, the setting of the flag in the corresponding spec is
147 -- also checked (and True returned if either flag is True).
149 function Is_Attribute_And_Known_Value_Comparison
150 (Op
: Node_Id
) return Boolean;
151 -- Determine whether operator Op denotes a comparison where the left
152 -- operand is an attribute reference and the value of the right operand is
153 -- known at compile time.
155 function Never_Set_In_Source_Check_Spec
(E
: Entity_Id
) return Boolean;
156 -- Tests Never_Set_In_Source status for entity E. If E is not a formal,
157 -- this is simply the setting of the flag Never_Set_In_Source. If E is
158 -- a body formal, the setting of the flag in the corresponding spec is
159 -- also checked (and False returned if either flag is False).
161 function Operand_Has_Warnings_Suppressed
(N
: Node_Id
) return Boolean;
162 -- This function traverses the expression tree represented by the node N
163 -- and determines if any sub-operand is a reference to an entity for which
164 -- the Warnings_Off flag is set. True is returned if such an entity is
165 -- encountered, and False otherwise.
167 function Referenced_Check_Spec
(E
: Entity_Id
) return Boolean;
168 -- Tests Referenced status for entity E. If E is not a formal, this is
169 -- simply the setting of the flag Referenced. If E is a body formal, the
170 -- setting of the flag in the corresponding spec is also checked (and True
171 -- returned if either flag is True).
173 function Referenced_As_LHS_Check_Spec
(E
: Entity_Id
) return Boolean;
174 -- Tests Referenced_As_LHS status for entity E. If E is not a formal, this
175 -- is simply the setting of the flag Referenced_As_LHS. If E is a body
176 -- formal, the setting of the flag in the corresponding spec is also
177 -- checked (and True returned if either flag is True).
179 function Referenced_As_Out_Parameter_Check_Spec
180 (E
: Entity_Id
) return Boolean;
181 -- Tests Referenced_As_Out_Parameter status for entity E. If E is not a
182 -- formal, this is simply the setting of Referenced_As_Out_Parameter. If E
183 -- is a body formal, the setting of the flag in the corresponding spec is
184 -- also checked (and True returned if either flag is True).
186 procedure Warn_On_Unreferenced_Entity
188 Body_E
: Entity_Id
:= Empty
);
189 -- Output warnings for unreferenced entity E. For the case of an entry
190 -- formal, Body_E is the corresponding body entity for a particular
191 -- accept statement, and the message is posted on Body_E. In all other
192 -- cases, Body_E is ignored and must be Empty.
194 function Warnings_Off_Check_Spec
(E
: Entity_Id
) return Boolean;
195 -- Returns True if Warnings_Off is set for the entity E or (in the case
196 -- where there is a Spec_Entity), Warnings_Off is set for the Spec_Entity.
198 --------------------------
199 -- Check_Code_Statement --
200 --------------------------
202 procedure Check_Code_Statement
(N
: Node_Id
) is
204 -- If volatile, nothing to worry about
206 if Is_Asm_Volatile
(N
) then
210 -- Warn if no input or no output
212 Setup_Asm_Inputs
(N
);
214 if No
(Asm_Input_Value
) then
216 ("??code statement with no inputs should usually be Volatile!", N
);
220 Setup_Asm_Outputs
(N
);
222 if No
(Asm_Output_Variable
) then
224 ("??code statement with no outputs should usually be Volatile!", N
);
227 end Check_Code_Statement
;
229 ---------------------------------
230 -- Check_Infinite_Loop_Warning --
231 ---------------------------------
233 -- The case we look for is a while loop which tests a local variable, where
234 -- there is no obvious direct or possible indirect update of the variable
235 -- within the body of the loop.
237 procedure Check_Infinite_Loop_Warning
(Loop_Statement
: Node_Id
) is
238 Expression
: Node_Id
:= Empty
;
239 -- Set to WHILE or EXIT WHEN condition to be tested
241 Ref
: Node_Id
:= Empty
;
242 -- Reference in Expression to variable that might not be modified
243 -- in loop, indicating a possible infinite loop.
245 Var
: Entity_Id
:= Empty
;
246 -- Corresponding entity (entity of Ref)
248 Function_Call_Found
: Boolean := False;
249 -- True if Find_Var found a function call in the condition
251 procedure Find_Var
(N
: Node_Id
);
252 -- Inspect condition to see if it depends on a single entity reference.
253 -- If so, Ref is set to point to the reference node, and Var is set to
254 -- the referenced Entity.
256 function Has_Condition_Actions
(Iter
: Node_Id
) return Boolean;
257 -- Determine whether iteration scheme Iter has meaningful condition
260 function Has_Indirection
(T
: Entity_Id
) return Boolean;
261 -- If the controlling variable is an access type, or is a record type
262 -- with access components, assume that it is changed indirectly and
263 -- suppress the warning. As a concession to low-level programming, in
264 -- particular within Declib, we also suppress warnings on a record
265 -- type that contains components of type Address or Short_Address.
267 function Is_Suspicious_Function_Name
(E
: Entity_Id
) return Boolean;
268 -- Given an entity name, see if the name appears to have something to
269 -- do with I/O or network stuff, and if so, return True. Used to kill
270 -- some false positives on a heuristic basis that such functions will
271 -- likely have some strange side effect dependencies. A rather strange
272 -- test, but warning messages are in the heuristics business.
274 function Test_Ref
(N
: Node_Id
) return Traverse_Result
;
275 -- Test for reference to variable in question. Returns Abandon if
276 -- matching reference found. Used in instantiation of No_Ref_Found.
278 function No_Ref_Found
is new Traverse_Func
(Test_Ref
);
279 -- Function to traverse body of procedure. Returns Abandon if matching
286 procedure Find_Var
(N
: Node_Id
) is
288 -- Expression is a direct variable reference
290 if Is_Entity_Name
(N
) then
294 -- If expression is an operator, check its operands
296 elsif Nkind
(N
) in N_Binary_Op
then
297 if Compile_Time_Known_Value
(Right_Opnd
(N
)) then
298 Find_Var
(Left_Opnd
(N
));
300 elsif Compile_Time_Known_Value
(Left_Opnd
(N
)) then
301 Find_Var
(Right_Opnd
(N
));
303 -- Ignore any other comparison
309 -- If expression is a unary operator, check its operand
311 elsif Nkind
(N
) in N_Unary_Op
then
312 Find_Var
(Right_Opnd
(N
));
314 -- Case of condition is function call
316 elsif Nkind
(N
) = N_Function_Call
then
318 Function_Call_Found
:= True;
320 -- Forget it if function name is not entity, who knows what
321 -- we might be calling?
323 if not Is_Entity_Name
(Name
(N
)) then
326 -- Forget it if function name is suspicious. A strange test
327 -- but warning generation is in the heuristics business.
329 elsif Is_Suspicious_Function_Name
(Entity
(Name
(N
))) then
332 -- Forget it if function is marked Volatile_Function
334 elsif Is_Volatile_Function
(Entity
(Name
(N
))) then
337 -- Forget it if warnings are suppressed on function entity
339 elsif Has_Warnings_Off
(Entity
(Name
(N
))) then
342 -- Forget it if the parameter is not In
344 elsif Has_Out_Or_In_Out_Parameter
(Entity
(Name
(N
))) then
348 -- OK, see if we have one argument
351 PA
: constant List_Id
:= Parameter_Associations
(N
);
354 -- One argument, so check the argument
356 if Present
(PA
) and then List_Length
(PA
) = 1 then
357 if Nkind
(First
(PA
)) = N_Parameter_Association
then
358 Find_Var
(Explicit_Actual_Parameter
(First
(PA
)));
360 Find_Var
(First
(PA
));
370 -- Any other kind of node is not something we warn for
377 ---------------------------
378 -- Has_Condition_Actions --
379 ---------------------------
381 function Has_Condition_Actions
(Iter
: Node_Id
) return Boolean is
385 -- A call marker is not considered a meaningful action because it
386 -- acts as an annotation and has no runtime semantics.
388 Action
:= First
(Condition_Actions
(Iter
));
389 while Present
(Action
) loop
390 if Nkind
(Action
) /= N_Call_Marker
then
398 end Has_Condition_Actions
;
400 ---------------------
401 -- Has_Indirection --
402 ---------------------
404 function Has_Indirection
(T
: Entity_Id
) return Boolean is
409 if Is_Access_Type
(T
) then
412 elsif Is_Private_Type
(T
)
413 and then Present
(Full_View
(T
))
414 and then Is_Access_Type
(Full_View
(T
))
418 elsif Is_Record_Type
(T
) then
421 elsif Is_Private_Type
(T
)
422 and then Present
(Full_View
(T
))
423 and then Is_Record_Type
(Full_View
(T
))
425 Rec
:= Full_View
(T
);
430 Comp
:= First_Component
(Rec
);
431 while Present
(Comp
) loop
432 if Is_Access_Type
(Etype
(Comp
))
433 or else Is_Descendant_Of_Address
(Etype
(Comp
))
438 Next_Component
(Comp
);
444 ---------------------------------
445 -- Is_Suspicious_Function_Name --
446 ---------------------------------
448 function Is_Suspicious_Function_Name
(E
: Entity_Id
) return Boolean is
449 function Substring_Present
(S
: String) return Boolean;
450 -- Returns True if name buffer has given string delimited by non-
451 -- alphabetic characters or by end of string. S is lower case.
453 -----------------------
454 -- Substring_Present --
455 -----------------------
457 function Substring_Present
(S
: String) return Boolean is
458 Len
: constant Natural := S
'Length;
461 for J
in 1 .. Name_Len
- (Len
- 1) loop
462 if Name_Buffer
(J
.. J
+ (Len
- 1)) = S
463 and then (J
= 1 or else Name_Buffer
(J
- 1) not in 'a' .. 'z')
466 or else Name_Buffer
(J
+ Len
) not in 'a' .. 'z')
473 end Substring_Present
;
479 -- Start of processing for Is_Suspicious_Function_Name
483 while Present
(S
) and then S
/= Standard_Standard
loop
484 Get_Name_String
(Chars
(S
));
486 if Substring_Present
("io")
487 or else Substring_Present
("file")
488 or else Substring_Present
("network")
497 end Is_Suspicious_Function_Name
;
503 function Test_Ref
(N
: Node_Id
) return Traverse_Result
is
505 -- Waste of time to look at the expression we are testing
507 if N
= Expression
then
510 -- Direct reference to variable in question
512 elsif Is_Entity_Name
(N
)
513 and then Present
(Entity
(N
))
514 and then Entity
(N
) = Var
516 -- If this is an lvalue, then definitely abandon, since
517 -- this could be a direct modification of the variable.
519 if Known_To_Be_Assigned
(N
) then
523 -- If the condition contains a function call, we consider it may
524 -- be modified by side effects from a procedure call. Otherwise,
525 -- we consider the condition may not be modified, although that
526 -- might happen if Variable is itself a by-reference parameter,
527 -- and the procedure called modifies the global object referred to
528 -- by Variable, but we actually prefer to issue a warning in this
529 -- odd case. Note that the case where the procedure called has
530 -- visibility over Variable is treated in another case below.
532 if Function_Call_Found
then
540 exit when P
= Loop_Statement
;
542 -- Abandon if at procedure call, or something strange is
543 -- going on (perhaps a node with no parent that should
544 -- have one but does not?) As always, for a warning we
545 -- prefer to just abandon the warning than get into the
546 -- business of complaining about the tree structure here.
549 or else Nkind
(P
) = N_Procedure_Call_Statement
557 -- Reference to variable renaming variable in question
559 elsif Is_Entity_Name
(N
)
560 and then Present
(Entity
(N
))
561 and then Ekind
(Entity
(N
)) = E_Variable
562 and then Present
(Renamed_Object
(Entity
(N
)))
563 and then Is_Entity_Name
(Renamed_Object
(Entity
(N
)))
564 and then Entity
(Renamed_Object
(Entity
(N
))) = Var
565 and then Known_To_Be_Assigned
(N
)
569 -- Call to subprogram
571 elsif Nkind
(N
) in N_Subprogram_Call
then
573 -- If subprogram is within the scope of the entity we are dealing
574 -- with as the loop variable, then it could modify this parameter,
575 -- so we abandon in this case. In the case of a subprogram that is
576 -- not an entity we also abandon. The check for no entity being
577 -- present is a defense against previous errors.
579 if not Is_Entity_Name
(Name
(N
))
580 or else No
(Entity
(Name
(N
)))
581 or else Scope_Within
(Entity
(Name
(N
)), Scope
(Var
))
586 -- If any of the arguments are of type access to subprogram, then
587 -- we may have funny side effects, so no warning in this case.
592 Actual
:= First_Actual
(N
);
593 while Present
(Actual
) loop
594 if Is_Access_Subprogram_Type
(Etype
(Actual
)) then
597 Next_Actual
(Actual
);
602 -- Declaration of the variable in question
604 elsif Nkind
(N
) = N_Object_Declaration
605 and then Defining_Identifier
(N
) = Var
610 -- All OK, continue scan
615 -- Start of processing for Check_Infinite_Loop_Warning
618 -- Skip processing if debug flag gnatd.w is set
620 if Debug_Flag_Dot_W
then
624 -- Deal with Iteration scheme present
627 Iter
: constant Node_Id
:= Iteration_Scheme
(Loop_Statement
);
630 if Present
(Iter
) then
634 if Present
(Condition
(Iter
)) then
636 -- Skip processing for while iteration with conditions actions,
637 -- since they make it too complicated to get the warning right.
639 if Has_Condition_Actions
(Iter
) then
643 -- Capture WHILE condition
645 Expression
:= Condition
(Iter
);
647 -- For Loop_Parameter_Specification, do not process, since loop
648 -- will always terminate. For Iterator_Specification, also do not
649 -- process. Either it will always terminate (e.g. "for X of
650 -- Some_Array ..."), or we can't tell if it's going to terminate
651 -- without looking at the iterator, so any warning here would be
654 elsif Present
(Loop_Parameter_Specification
(Iter
))
655 or else Present
(Iterator_Specification
(Iter
))
662 -- Check chain of EXIT statements, we only process loops that have a
663 -- single exit condition (either a single EXIT WHEN statement, or a
664 -- WHILE loop not containing any EXIT WHEN statements).
667 Ident
: constant Node_Id
:= Identifier
(Loop_Statement
);
671 -- If we don't have a proper chain set, ignore call entirely. This
672 -- happens because of previous errors.
674 if No
(Entity
(Ident
))
675 or else Ekind
(Entity
(Ident
)) /= E_Loop
677 Check_Error_Detected
;
681 -- Otherwise prepare to scan list of EXIT statements
683 Exit_Stmt
:= First_Exit_Statement
(Entity
(Ident
));
684 while Present
(Exit_Stmt
) loop
686 -- Check for EXIT WHEN
688 if Present
(Condition
(Exit_Stmt
)) then
690 -- Quit processing if EXIT WHEN in WHILE loop, or more than
691 -- one EXIT WHEN statement present in the loop.
693 if Present
(Expression
) then
696 -- Otherwise capture condition from EXIT WHEN statement
699 Expression
:= Condition
(Exit_Stmt
);
702 -- If an unconditional exit statement is the last statement in the
703 -- loop, assume that no warning is needed, without any attempt at
704 -- checking whether the exit is reachable.
706 elsif Exit_Stmt
= Last
(Statements
(Loop_Statement
)) then
710 Exit_Stmt
:= Next_Exit_Statement
(Exit_Stmt
);
714 -- Return if no condition to test
716 if No
(Expression
) then
720 -- Initial conditions met, see if condition is of right form
722 Find_Var
(Expression
);
724 -- Nothing to do if local variable from source not found. If it's a
725 -- renaming, it is probably renaming something too complicated to deal
729 or else Ekind
(Var
) /= E_Variable
730 or else Is_Library_Level_Entity
(Var
)
731 or else not Comes_From_Source
(Var
)
732 or else Nkind
(Parent
(Var
)) = N_Object_Renaming_Declaration
736 -- Nothing to do if there is some indirection involved (assume that the
737 -- designated variable might be modified in some way we don't see).
738 -- However, if no function call was found, then we don't care about
739 -- indirections, because the condition must be something like "while X
740 -- /= null loop", so we don't care if X.all is modified in the loop.
742 elsif Function_Call_Found
and then Has_Indirection
(Etype
(Var
)) then
745 -- Same sort of thing for volatile variable, might be modified by
746 -- some other task or by the operating system in some way.
748 elsif Is_Volatile
(Var
) then
752 -- Filter out case of original statement sequence starting with delay.
753 -- We assume this is a multi-tasking program and that the condition
754 -- is affected by other threads (some kind of busy wait).
757 Fstm
: constant Node_Id
:=
758 Original_Node
(First
(Statements
(Loop_Statement
)));
760 if Nkind
(Fstm
) in N_Delay_Statement
then
765 -- We have a variable reference of the right form, now we scan the loop
766 -- body to see if it looks like it might not be modified
768 if No_Ref_Found
(Loop_Statement
) = OK
then
770 ("??variable& is not modified in loop body!", Ref
, Var
);
772 ("\??possible infinite loop!", Ref
);
774 end Check_Infinite_Loop_Warning
;
776 ----------------------------
777 -- Check_Low_Bound_Tested --
778 ----------------------------
780 procedure Check_Low_Bound_Tested
(Expr
: Node_Id
) is
781 procedure Check_Low_Bound_Tested_For
(Opnd
: Node_Id
);
782 -- Determine whether operand Opnd denotes attribute 'First whose prefix
783 -- is a formal parameter. If this is the case, mark the entity of the
784 -- prefix as having its low bound tested.
786 --------------------------------
787 -- Check_Low_Bound_Tested_For --
788 --------------------------------
790 procedure Check_Low_Bound_Tested_For
(Opnd
: Node_Id
) is
792 if Nkind
(Opnd
) = N_Attribute_Reference
793 and then Attribute_Name
(Opnd
) = Name_First
794 and then Is_Entity_Name
(Prefix
(Opnd
))
795 and then Present
(Entity
(Prefix
(Opnd
)))
796 and then Is_Formal
(Entity
(Prefix
(Opnd
)))
798 Set_Low_Bound_Tested
(Entity
(Prefix
(Opnd
)));
800 end Check_Low_Bound_Tested_For
;
802 -- Start of processing for Check_Low_Bound_Tested
805 if Comes_From_Source
(Expr
) then
806 Check_Low_Bound_Tested_For
(Left_Opnd
(Expr
));
807 Check_Low_Bound_Tested_For
(Right_Opnd
(Expr
));
809 end Check_Low_Bound_Tested
;
811 ----------------------
812 -- Check_References --
813 ----------------------
815 procedure Check_References
(E
: Entity_Id
; Anod
: Node_Id
:= Empty
) is
822 Accept_Statement
: Node_Id
) return Entity_Id
;
823 -- For an entry formal entity from an entry declaration, find the
824 -- corresponding body formal from the given accept statement.
826 function Generic_Body_Formal
(E
: Entity_Id
) return Entity_Id
;
827 -- Warnings on unused formals of subprograms are placed on the entity
828 -- in the subprogram body, which seems preferable because it suggests
829 -- a better codefix for GNAT Studio. The analysis of generic subprogram
830 -- bodies uses a different circuitry, so the choice for the proper
831 -- placement of the warning in the generic case takes place here, by
832 -- finding the body entity that corresponds to a formal in a spec.
834 procedure May_Need_Initialized_Actual
(Ent
: Entity_Id
);
835 -- If an entity of a generic type has default initialization, then the
836 -- corresponding actual type should be fully initialized, or else there
837 -- will be uninitialized components in the instantiation, that might go
838 -- unreported. This routine marks the type of the uninitialized variable
839 -- appropriately to allow the compiler to emit an appropriate warning
840 -- in the instance. In a sense, the use of a type that requires full
841 -- initialization is a weak part of the generic contract.
843 function Missing_Subunits
return Boolean;
844 -- We suppress warnings when there are missing subunits, because this
845 -- may generate too many false positives: entities in a parent may only
846 -- be referenced in one of the subunits. We make an exception for
847 -- subunits that contain no other stubs.
849 procedure Output_Reference_Error
(M
: String);
850 -- Used to output an error message. Deals with posting the error on the
851 -- body formal in the accept case.
853 function Publicly_Referenceable
(Ent
: Entity_Id
) return Boolean;
854 -- This is true if the entity in question is potentially referenceable
855 -- from another unit. This is true for entities in packages that are at
856 -- the library level.
858 function Warnings_Off_E1
return Boolean;
859 -- Return True if Warnings_Off is set for E1, or for its Etype (E1T),
860 -- or for the base type of E1T.
868 Accept_Statement
: Node_Id
) return Entity_Id
870 Body_Param
: Node_Id
;
874 -- Loop to find matching parameter in accept statement
876 Body_Param
:= First
(Parameter_Specifications
(Accept_Statement
));
877 while Present
(Body_Param
) loop
878 Body_E
:= Defining_Identifier
(Body_Param
);
880 if Chars
(Body_E
) = Chars
(E
) then
887 -- Should never fall through, should always find a match
892 -------------------------
893 -- Generic_Body_Formal --
894 -------------------------
896 function Generic_Body_Formal
(E
: Entity_Id
) return Entity_Id
is
897 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(E
));
898 Gen_Body
: constant Entity_Id
:= Corresponding_Body
(Gen_Decl
);
902 if No
(Gen_Body
) then
906 Form
:= First_Entity
(Gen_Body
);
907 while Present
(Form
) loop
908 if Chars
(Form
) = Chars
(E
) then
916 -- Should never fall through, should always find a match
919 end Generic_Body_Formal
;
921 ---------------------------------
922 -- May_Need_Initialized_Actual --
923 ---------------------------------
925 procedure May_Need_Initialized_Actual
(Ent
: Entity_Id
) is
926 T
: constant Entity_Id
:= Etype
(Ent
);
927 Par
: constant Node_Id
:= Parent
(T
);
930 if not Is_Generic_Type
(T
) then
933 elsif Nkind
(Par
) = N_Private_Extension_Declaration
then
935 -- We only indicate the first such variable in the generic.
937 if No
(Uninitialized_Variable
(Par
)) then
938 Set_Uninitialized_Variable
(Par
, Ent
);
941 elsif Nkind
(Par
) = N_Formal_Type_Declaration
942 and then Nkind
(Formal_Type_Definition
(Par
)) =
943 N_Formal_Private_Type_Definition
945 if No
(Uninitialized_Variable
(Formal_Type_Definition
(Par
))) then
946 Set_Uninitialized_Variable
(Formal_Type_Definition
(Par
), Ent
);
949 end May_Need_Initialized_Actual
;
951 ----------------------
952 -- Missing_Subunits --
953 ----------------------
955 function Missing_Subunits
return Boolean is
959 if not Unloaded_Subunits
then
961 -- Normal compilation, all subunits are present
965 elsif E
/= Main_Unit_Entity
then
967 -- No warnings on a stub that is not the main unit
971 elsif Nkind
(Unit_Declaration_Node
(E
)) in N_Proper_Body
then
972 D
:= First
(Declarations
(Unit_Declaration_Node
(E
)));
973 while Present
(D
) loop
975 -- No warnings if the proper body contains nested stubs
977 if Nkind
(D
) in N_Body_Stub
then
987 -- Missing stubs elsewhere
991 end Missing_Subunits
;
993 ----------------------------
994 -- Output_Reference_Error --
995 ----------------------------
997 procedure Output_Reference_Error
(M
: String) is
999 -- Never issue messages for internal names or renamings
1001 if Is_Internal_Name
(Chars
(E1
))
1002 or else Nkind
(Parent
(E1
)) = N_Object_Renaming_Declaration
1007 -- Don't output message for IN OUT formal unless we have the warning
1008 -- flag specifically set. It is a bit odd to distinguish IN OUT
1009 -- formals from other cases. This distinction is historical in
1010 -- nature. Warnings for IN OUT formals were added fairly late.
1012 if Ekind
(E1
) = E_In_Out_Parameter
1013 and then not Check_Unreferenced_Formals
1018 -- Other than accept case, post error on defining identifier
1021 Error_Msg_N
(M
, E1
);
1023 -- Accept case, find body formal to post the message
1026 Error_Msg_NE
(M
, Body_Formal
(E1
, Accept_Statement
=> Anod
), E1
);
1029 end Output_Reference_Error
;
1031 ----------------------------
1032 -- Publicly_Referenceable --
1033 ----------------------------
1035 function Publicly_Referenceable
(Ent
: Entity_Id
) return Boolean is
1040 -- A formal parameter is never referenceable outside the body of its
1041 -- subprogram or entry.
1043 if Is_Formal
(Ent
) then
1047 -- Examine parents to look for a library level package spec. But if
1048 -- we find a body or block or other similar construct along the way,
1049 -- we cannot be referenced.
1056 -- If we get to top of tree, then publicly referenceable
1061 -- If we reach a generic package declaration, then always
1062 -- consider this referenceable, since any instantiation will
1063 -- have access to the entities in the generic package. Note
1064 -- that the package itself may not be instantiated, but then
1065 -- we will get a warning for the package entity.
1067 -- Note that generic formal parameters are themselves not
1068 -- publicly referenceable in an instance, and warnings on them
1071 when N_Generic_Package_Declaration
=>
1073 not Is_List_Member
(Prev
)
1074 or else List_Containing
(Prev
) /=
1075 Generic_Formal_Declarations
(P
);
1077 -- Similarly, the generic formals of a generic subprogram are
1080 when N_Generic_Subprogram_Declaration
=>
1081 if Is_List_Member
(Prev
)
1082 and then List_Containing
(Prev
) =
1083 Generic_Formal_Declarations
(P
)
1090 -- If we reach a subprogram body, entity is not referenceable
1091 -- unless it is the defining entity of the body. This will
1092 -- happen, e.g. when a function is an attribute renaming that
1093 -- is rewritten as a body.
1095 when N_Subprogram_Body
=>
1096 if Ent
/= Defining_Entity
(P
) then
1102 -- If we reach any other body, definitely not referenceable
1104 when N_Block_Statement
1113 -- For all other cases, keep looking up tree
1120 end Publicly_Referenceable
;
1122 ---------------------
1123 -- Warnings_Off_E1 --
1124 ---------------------
1126 function Warnings_Off_E1
return Boolean is
1128 return Has_Warnings_Off
(E1T
)
1129 or else Has_Warnings_Off
(Base_Type
(E1T
))
1130 or else Warnings_Off_Check_Spec
(E1
);
1131 end Warnings_Off_E1
;
1133 -- Start of processing for Check_References
1136 -- No messages if warnings are suppressed, or if we have detected any
1137 -- real errors so far (this last check avoids junk messages resulting
1138 -- from errors, e.g. a subunit that is not loaded).
1140 if Warning_Mode
= Suppress
or else Serious_Errors_Detected
/= 0 then
1144 -- We also skip the messages if any subunits were not loaded (see
1145 -- comment in Sem_Ch10 to understand how this is set, and why it is
1146 -- necessary to suppress the warnings in this case).
1148 if Missing_Subunits
then
1152 -- Otherwise loop through entities, looking for suspicious stuff
1154 E1
:= First_Entity
(E
);
1155 while Present
(E1
) loop
1156 -- We are only interested in source entities. We also don't issue
1157 -- warnings within instances, since the proper place for such
1158 -- warnings is on the template when it is compiled, and we don't
1159 -- issue warnings for variables with names like Junk, Discard etc.
1161 if Comes_From_Source
(E1
)
1162 and then Instantiation_Location
(Sloc
(E1
)) = No_Location
1166 -- We are interested in variables and out/in-out parameters, but
1167 -- we exclude protected types, too complicated to worry about.
1169 if Ekind
(E1
) = E_Variable
1171 (Ekind
(E1
) in E_Out_Parameter | E_In_Out_Parameter
1172 and then not Is_Protected_Type
(Current_Scope
))
1174 -- If the formal has a class-wide type, retrieve its type
1175 -- because checks below depend on its private nature.
1177 if Is_Class_Wide_Type
(E1T
) then
1181 -- Case of an unassigned variable
1183 -- First gather any Unset_Reference indication for E1. In the
1184 -- case of an 'out' parameter, it is the Spec_Entity that is
1187 if Ekind
(E1
) = E_Out_Parameter
1188 and then Present
(Spec_Entity
(E1
))
1190 UR
:= Unset_Reference
(Spec_Entity
(E1
));
1192 UR
:= Unset_Reference
(E1
);
1195 -- Special processing for access types
1197 if Present
(UR
) and then Is_Access_Type
(E1T
) then
1199 -- For access types, the only time we made a UR entry was
1200 -- for a dereference, and so we post the appropriate warning
1201 -- here (note that the dereference may not be explicit in
1202 -- the source, for example in the case of a dispatching call
1203 -- with an anonymous access controlling formal, or of an
1204 -- assignment of a pointer involving discriminant check on
1205 -- the designated object).
1207 if not Warnings_Off_E1
then
1208 Error_Msg_NE
("??& may be null!", UR
, E1
);
1213 -- Case of variable that could be a constant. Note that we
1214 -- never signal such messages for generic package entities,
1215 -- since a given instance could have modifications outside
1218 -- Note that we used to check Address_Taken here, but we don't
1219 -- want to do that since it can be set for non-source cases,
1220 -- e.g. the Unrestricted_Access from a valid attribute, and
1221 -- the wanted effect is included in Never_Set_In_Source.
1223 elsif Warn_On_Constant
1224 and then Ekind
(E1
) = E_Variable
1225 and then Has_Initial_Value
(E1
)
1226 and then Never_Set_In_Source
(E1
)
1227 and then not Generic_Package_Spec_Entity
(E1
)
1229 -- A special case, if this variable is volatile and not
1230 -- imported, it is not helpful to tell the programmer
1231 -- to mark the variable as constant, since this would be
1232 -- illegal by virtue of RM C.6(13). Instead we suggest
1233 -- using pragma Export (can't be Import because of the
1236 if (Is_Volatile
(E1
) or else Has_Volatile_Components
(E1
))
1237 and then not Is_Imported
(E1
)
1240 ("?k?& is not modified, consider pragma Export for "
1241 & "volatile variable!", E1
);
1243 -- Another special case, Exception_Occurrence, this catches
1244 -- the case of exception choice (and a bit more too, but not
1245 -- worth doing more investigation here).
1247 elsif Is_RTE
(E1T
, RE_Exception_Occurrence
) then
1250 -- Here we give the warning if referenced and no pragma
1251 -- Unreferenced or Unmodified is present.
1253 elsif Referenced
(E1
)
1254 and then not Has_Unreferenced
(E1
)
1255 and then not Has_Unmodified
(E1
)
1256 and then not Warnings_Off_E1
1257 and then not Has_Junk_Name
(E1
)
1259 Error_Msg_N
-- CODEFIX
1260 ("?k?& is not modified, could be declared constant!",
1264 -- Other cases of a variable or parameter never set in source
1266 elsif Never_Set_In_Source_Check_Spec
(E1
)
1268 -- No warning if address taken somewhere
1270 and then not Address_Taken
(E1
)
1272 -- No warning if explicit initial value
1274 and then not Has_Initial_Value
(E1
)
1276 -- No warning for generic package spec entities, since we
1277 -- might set them in a child unit or something like that
1279 and then not Generic_Package_Spec_Entity
(E1
)
1281 -- No warning if fully initialized type, except that for
1282 -- this purpose we do not consider access types to qualify
1283 -- as fully initialized types (relying on an access type
1284 -- variable being null when it is never set is a bit odd).
1286 -- Also we generate warning for an out parameter that is
1287 -- never referenced, since again it seems odd to rely on
1288 -- default initialization to set an out parameter value.
1290 and then (Is_Access_Type
(E1T
)
1291 or else Ekind
(E1
) = E_Out_Parameter
1292 or else not Is_Fully_Initialized_Type
(E1T
))
1294 -- Do not output complaint about never being assigned a
1295 -- value if a pragma Unmodified applies to the variable
1296 -- we are examining, or if it is a parameter, if there is
1297 -- a pragma Unreferenced for the corresponding spec, or
1298 -- if the type is marked as having unreferenced objects.
1299 -- The last is a little peculiar, but better too few than
1300 -- too many warnings in this situation.
1302 if Has_Pragma_Unreferenced_Objects
(E1T
)
1303 or else Has_Pragma_Unmodified_Check_Spec
(E1
)
1307 -- IN OUT parameter case where parameter is referenced. We
1308 -- separate this out, since this is the case where we delay
1309 -- output of the warning until more information is available
1310 -- (about use in an instantiation or address being taken).
1312 elsif Ekind
(E1
) = E_In_Out_Parameter
1313 and then Referenced_Check_Spec
(E1
)
1315 -- Suppress warning if private type, and the procedure
1316 -- has a separate declaration in a different unit. This
1317 -- is the case where the client of a package sees only
1318 -- the private type, and it may be quite reasonable
1319 -- for the logical view to be IN OUT, even if the
1320 -- implementation ends up using access types or some
1321 -- other method to achieve the local effect of a
1322 -- modification. On the other hand if the spec and body
1323 -- are in the same unit, we are in the package body and
1324 -- there we have less excuse for a junk IN OUT parameter.
1326 if Has_Private_Declaration
(E1T
)
1327 and then Present
(Spec_Entity
(E1
))
1328 and then not In_Same_Source_Unit
(E1
, Spec_Entity
(E1
))
1332 -- Suppress warning for any parameter of a dispatching
1333 -- operation, since it is quite reasonable to have an
1334 -- operation that is overridden, and for some subclasses
1335 -- needs the formal to be IN OUT and for others happens
1336 -- not to assign it.
1338 elsif Is_Dispatching_Operation
1339 (Scope
(Goto_Spec_Entity
(E1
)))
1343 -- Suppress warning if composite type contains any access
1344 -- component, since the logical effect of modifying a
1345 -- parameter may be achieved by modifying a referenced
1346 -- object. This rationale does not apply to private
1347 -- types, so we warn in that case.
1349 elsif Is_Composite_Type
(E1T
)
1350 and then not Is_Private_Type
(E1T
)
1351 and then Has_Access_Values
(E1T
)
1355 -- Suppress warning on formals of an entry body. All
1356 -- references are attached to the formal in the entry
1357 -- declaration, which are marked Is_Entry_Formal.
1359 elsif Ekind
(Scope
(E1
)) = E_Entry
1360 and then not Is_Entry_Formal
(E1
)
1364 -- OK, looks like warning for an IN OUT parameter that
1365 -- could be IN makes sense, but we delay the output of
1366 -- the warning, pending possibly finding out later on
1367 -- that the associated subprogram is used as a generic
1368 -- actual, or its address/access is taken. In these two
1369 -- cases, we suppress the warning because the context may
1370 -- force use of IN OUT, even if in this particular case
1371 -- the formal is not modified.
1373 elsif Warn_On_No_Value_Assigned
then
1374 -- Suppress the warnings for a junk name
1376 if not Has_Junk_Name
(E1
) then
1377 In_Out_Warnings
.Append
(E1
);
1381 -- Other cases of formals
1383 elsif Is_Formal
(E1
) then
1384 if not Is_Trivial_Subprogram
(Scope
(E1
)) then
1385 if Referenced_Check_Spec
(E1
) then
1386 if not Has_Pragma_Unmodified_Check_Spec
(E1
)
1387 and then not Warnings_Off_E1
1388 and then not Has_Junk_Name
(E1
)
1389 and then Warn_On_No_Value_Assigned
1391 Output_Reference_Error
1392 ("?v?formal parameter& is read but "
1393 & "never assigned!");
1396 elsif not Has_Pragma_Unreferenced_Check_Spec
(E1
)
1397 and then not Warnings_Off_E1
1398 and then not Has_Junk_Name
(E1
)
1399 and then Check_Unreferenced_Formals
1401 Output_Reference_Error
1402 ("?f?formal parameter& is not referenced!");
1409 if Referenced
(E1
) then
1410 if Warn_On_No_Value_Assigned
1411 and then not Has_Unmodified
(E1
)
1412 and then not Warnings_Off_E1
1413 and then not Has_Junk_Name
(E1
)
1415 if Is_Access_Type
(E1T
)
1417 not Is_Partially_Initialized_Type
(E1T
, False)
1419 Output_Reference_Error
1420 ("?v?variable& is read but never assigned!");
1423 May_Need_Initialized_Actual
(E1
);
1426 elsif Check_Unreferenced
1427 and then not Has_Unreferenced
(E1
)
1428 and then not Warnings_Off_E1
1429 and then not Has_Junk_Name
(E1
)
1431 Output_Reference_Error
-- CODEFIX
1432 ("?u?variable& is never read and never assigned!");
1435 -- Deal with special case where this variable is hidden
1436 -- by a loop variable.
1438 if Ekind
(E1
) = E_Variable
1439 and then Present
(Hiding_Loop_Variable
(E1
))
1440 and then not Warnings_Off_E1
1441 and then Warn_On_Hiding
1444 ("?h?for loop implicitly declares loop variable!",
1445 Hiding_Loop_Variable
(E1
));
1447 Error_Msg_Sloc
:= Sloc
(E1
);
1449 ("\?h?declaration hides & declared#!",
1450 Hiding_Loop_Variable
(E1
));
1457 -- Check for unset reference. If type of object has
1458 -- preelaborable initialization, warning is misleading.
1460 if Warn_On_No_Value_Assigned
1461 and then Present
(UR
)
1462 and then not Known_To_Have_Preelab_Init
(Etype
(E1
))
1465 -- Don't issue warning if appearing inside Initial_Condition
1466 -- pragma or aspect, since that expression is not evaluated
1467 -- at the point where it occurs in the source.
1469 if In_Pragma_Expression
(UR
, Name_Initial_Condition
) then
1473 -- Here we issue the warning, all checks completed
1475 -- If we have a return statement, this was a case of an OUT
1476 -- parameter not being set at the time of the return. (Note:
1477 -- it can't be N_Extended_Return_Statement, because those
1478 -- are only for functions, and functions do not allow OUT
1481 if not Is_Trivial_Subprogram
(Scope
(E1
)) then
1482 if Nkind
(UR
) = N_Simple_Return_Statement
1483 and then not Has_Pragma_Unmodified_Check_Spec
(E1
)
1485 if not Warnings_Off_E1
1486 and then not Has_Junk_Name
(E1
)
1489 ("?v?OUT parameter& not set before return",
1493 -- If the unset reference is a selected component
1494 -- prefix from source, mention the component as well.
1495 -- If the selected component comes from expansion, all
1496 -- we know is that the entity is not fully initialized
1497 -- at the point of the reference. Locate a random
1498 -- uninitialized component to get a better message.
1500 elsif Nkind
(Parent
(UR
)) = N_Selected_Component
then
1501 -- Suppress possibly superfluous warning if component
1502 -- is known to exist and is partially initialized.
1504 if not Has_Discriminants
(Etype
(E1
))
1506 Is_Partially_Initialized_Type
1507 (Etype
(Parent
(UR
)), False)
1512 Error_Msg_Node_2
:= Selector_Name
(Parent
(UR
));
1514 if not Comes_From_Source
(Parent
(UR
)) then
1519 Comp
:= First_Component
(E1T
);
1520 while Present
(Comp
) loop
1521 if Nkind
(Parent
(Comp
)) =
1522 N_Component_Declaration
1523 and then No
(Expression
(Parent
(Comp
)))
1525 Error_Msg_Node_2
:= Comp
;
1529 Next_Component
(Comp
);
1534 -- Issue proper warning. This is a case of referencing
1535 -- a variable before it has been explicitly assigned.
1536 -- For access types, UR was only set for dereferences,
1537 -- so the issue is that the value may be null.
1539 if not Warnings_Off_E1
then
1540 if Is_Access_Type
(Etype
(Parent
(UR
))) then
1541 Error_Msg_N
("??`&.&` may be null!", UR
);
1544 ("??`&.&` may be referenced before "
1545 & "it has a value!", UR
);
1549 -- All other cases of unset reference active
1551 elsif not Warnings_Off_E1
then
1553 ("??& may be referenced before it has a value!", UR
);
1562 -- Then check for unreferenced entities. Note that we are only
1563 -- interested in entities whose Referenced flag is not set.
1565 if not Referenced_Check_Spec
(E1
)
1567 -- If Referenced_As_LHS is set, then that's still interesting
1568 -- (potential "assigned but never read" case), but not if we
1569 -- have pragma Unreferenced, which cancels this warning.
1571 and then (not Referenced_As_LHS_Check_Spec
(E1
)
1572 or else not Has_Unreferenced
(E1
))
1574 -- Check that warnings on unreferenced entities are enabled
1577 ((Check_Unreferenced
and then not Is_Formal
(E1
))
1579 -- Case of warning on unreferenced formal
1581 or else (Check_Unreferenced_Formals
and then Is_Formal
(E1
))
1583 -- Case of warning on unread variables modified by an
1584 -- assignment, or an OUT parameter if it is the only one.
1586 or else (Warn_On_Modified_Unread
1587 and then Referenced_As_LHS_Check_Spec
(E1
))
1589 -- Case of warning on any unread OUT parameter (note such
1590 -- indications are only set if the appropriate warning
1591 -- options were set, so no need to recheck here.)
1593 or else Referenced_As_Out_Parameter_Check_Spec
(E1
))
1595 -- All other entities, including local packages that cannot be
1596 -- referenced from elsewhere, including those declared within a
1599 and then (Is_Object
(E1
)
1600 or else Is_Type
(E1
)
1601 or else Ekind
(E1
) = E_Label
1602 or else Ekind
(E1
) in E_Exception
1605 or else Is_Overloadable
(E1
)
1607 -- Package case, if the main unit is a package spec
1608 -- or generic package spec, then there may be a
1609 -- corresponding body that references this package
1610 -- in some other file. Otherwise we can be sure
1611 -- that there is no other reference.
1614 (Ekind
(E1
) = E_Package
1616 not Is_Package_Or_Generic_Package
1617 (Cunit_Entity
(Current_Sem_Unit
))))
1619 -- Consider private type referenced if full view is referenced.
1620 -- If there is not full view, this is a generic type on which
1621 -- warnings are also useful.
1624 not (Is_Private_Type
(E1
)
1625 and then Present
(Full_View
(E1
))
1626 and then Referenced
(Full_View
(E1
)))
1628 -- Don't worry about full view, only about private type
1630 and then not Has_Private_Declaration
(E1
)
1632 -- Eliminate dispatching operations from consideration, we
1633 -- cannot tell if these are referenced or not in any easy
1634 -- manner (note this also catches Adjust/Finalize/Initialize).
1636 and then not Is_Dispatching_Operation
(E1
)
1638 -- Check entity that can be publicly referenced (we do not give
1639 -- messages for such entities, since there could be other
1640 -- units, not involved in this compilation, that contain
1641 -- relevant references.
1643 and then not Publicly_Referenceable
(E1
)
1645 -- Class wide types are marked as source entities, but they are
1646 -- not really source entities, and are always created, so we do
1647 -- not care if they are not referenced.
1649 and then Ekind
(E1
) /= E_Class_Wide_Type
1651 -- Objects other than parameters of task types are allowed to
1652 -- be non-referenced, since they start up tasks.
1654 and then ((Ekind
(E1
) /= E_Variable
1655 and then Ekind
(E1
) /= E_Constant
1656 and then Ekind
(E1
) /= E_Component
)
1658 -- Check that E1T is not a task or a composite type
1659 -- with a task component.
1661 or else not Has_Task
(E1T
))
1663 -- For subunits, only place warnings on the main unit itself,
1664 -- since parent units are not completely compiled.
1666 and then (Nkind
(Unit
(Cunit
(Main_Unit
))) /= N_Subunit
1667 or else Get_Source_Unit
(E1
) = Main_Unit
)
1669 -- No warning on a return object, because these are often
1670 -- created with a single expression and an implicit return.
1671 -- If the object is a variable there will be a warning
1672 -- indicating that it could be declared constant.
1675 (Ekind
(E1
) = E_Constant
and then Is_Return_Object
(E1
))
1677 -- Suppress warnings in internal units if not in -gnatg mode
1678 -- (these would be junk warnings for an applications program,
1679 -- since they refer to problems in internal units).
1681 if GNAT_Mode
or else not In_Internal_Unit
(E1
) then
1682 -- We do not immediately flag the error. This is because we
1683 -- have not expanded generic bodies yet, and they may have
1684 -- the missing reference. So instead we park the entity on a
1685 -- list, for later processing. However for the case of an
1686 -- accept statement we want to output messages now, since
1687 -- we know we already have all information at hand, and we
1688 -- also want to have separate warnings for each accept
1689 -- statement for the same entry.
1691 if Present
(Anod
) then
1692 pragma Assert
(Is_Formal
(E1
));
1694 -- The unreferenced entity is E1, but post the warning
1695 -- on the body entity for this accept statement.
1697 if not Warnings_Off_E1
then
1698 Warn_On_Unreferenced_Entity
1699 (E1
, Body_Formal
(E1
, Accept_Statement
=> Anod
));
1702 elsif not Warnings_Off_E1
1703 and then not Has_Junk_Name
(E1
)
1706 and then Nkind
(Unit_Declaration_Node
(Scope
(E1
)))
1707 = N_Generic_Subprogram_Declaration
1709 Unreferenced_Entities
.Append
1710 (Generic_Body_Formal
(E1
));
1712 Unreferenced_Entities
.Append
(E1
);
1717 -- Generic units are referenced in the generic body, but if they
1718 -- are not public and never instantiated we want to force a
1719 -- warning on them. We treat them as redundant constructs to
1722 elsif Is_Generic_Subprogram
(E1
)
1723 and then not Is_Instantiated
(E1
)
1724 and then not Publicly_Referenceable
(E1
)
1725 and then Warn_On_Redundant_Constructs
1727 if not Warnings_Off_E1
and then not Has_Junk_Name
(E1
) then
1728 Unreferenced_Entities
.Append
(E1
);
1730 -- Force warning on entity
1732 Set_Referenced
(E1
, False);
1737 -- Recurse into nested package or block. Do not recurse into a formal
1738 -- package, because the corresponding body is not analyzed.
1741 if (Is_Package_Or_Generic_Package
(E1
)
1742 and then Nkind
(Parent
(E1
)) = N_Package_Specification
1744 Nkind
(Original_Node
(Unit_Declaration_Node
(E1
))) /=
1745 N_Formal_Package_Declaration
)
1747 or else Ekind
(E1
) = E_Block
1749 Check_References
(E1
);
1754 end Check_References
;
1756 ---------------------------
1757 -- Check_Unset_Reference --
1758 ---------------------------
1760 procedure Check_Unset_Reference
(N
: Node_Id
) is
1761 Typ
: constant Entity_Id
:= Etype
(N
);
1763 function Is_OK_Fully_Initialized
return Boolean;
1764 -- This function returns true if the given node N is fully initialized
1765 -- so that the reference is safe as far as this routine is concerned.
1766 -- Safe generally means that the type of N is a fully initialized type.
1767 -- The one special case is that for access types, which are always fully
1768 -- initialized, we don't consider a dereference OK since it will surely
1769 -- be dereferencing a null value, which won't do.
1771 function Prefix_Has_Dereference
(Pref
: Node_Id
) return Boolean;
1772 -- Used to test indexed or selected component or slice to see if the
1773 -- evaluation of the prefix depends on a dereference, and if so, returns
1774 -- True, in which case we always check the prefix, even if we know that
1775 -- the referenced component is initialized. Pref is the prefix to test.
1777 -----------------------------
1778 -- Is_OK_Fully_Initialized --
1779 -----------------------------
1781 function Is_OK_Fully_Initialized
return Boolean is
1783 if Is_Access_Type
(Typ
) and then Is_Dereferenced
(N
) then
1786 -- A type subject to pragma Default_Initial_Condition may be fully
1787 -- default initialized depending on inheritance and the argument of
1788 -- the pragma (SPARK RM 3.1 and SPARK RM 7.3.3).
1790 elsif Has_Fully_Default_Initializing_DIC_Pragma
(Typ
) then
1794 return Is_Fully_Initialized_Type
(Typ
);
1796 end Is_OK_Fully_Initialized
;
1798 ----------------------------
1799 -- Prefix_Has_Dereference --
1800 ----------------------------
1802 function Prefix_Has_Dereference
(Pref
: Node_Id
) return Boolean is
1804 -- If prefix is of an access type, it certainly needs a dereference
1806 if Is_Access_Type
(Etype
(Pref
)) then
1809 -- If prefix is explicit dereference, that's a dereference for sure
1811 elsif Nkind
(Pref
) = N_Explicit_Dereference
then
1814 -- If prefix is itself a component reference or slice check prefix
1816 elsif Nkind
(Pref
) = N_Slice
1817 or else Nkind
(Pref
) = N_Indexed_Component
1818 or else Nkind
(Pref
) = N_Selected_Component
1820 return Prefix_Has_Dereference
(Prefix
(Pref
));
1822 -- All other cases do not involve a dereference
1827 end Prefix_Has_Dereference
;
1829 -- Start of processing for Check_Unset_Reference
1832 -- Nothing to do if warnings suppressed
1834 if Warning_Mode
= Suppress
then
1838 -- Ignore reference unless it comes from source. Almost always if we
1839 -- have a reference from generated code, it is bogus (e.g. calls to init
1840 -- procs to set default discriminant values).
1842 if not Comes_From_Source
(Original_Node
(N
)) then
1846 -- Otherwise see what kind of node we have. If the entity already has an
1847 -- unset reference, it is not necessarily the earliest in the text,
1848 -- because resolution of the prefix of selected components is completed
1849 -- before the resolution of the selected component itself. As a result,
1850 -- given (R /= null and then R.X > 0), the occurrences of R are examined
1851 -- in right-to-left order. If there is already an unset reference, we
1852 -- check whether N is earlier before proceeding.
1856 -- For identifier or expanded name, examine the entity involved
1858 when N_Expanded_Name
1862 E
: constant Entity_Id
:= Entity
(N
);
1865 if Ekind
(E
) in E_Variable | E_Out_Parameter
1866 and then Never_Set_In_Source_Check_Spec
(E
)
1867 and then not Has_Initial_Value
(E
)
1868 and then (No
(Unset_Reference
(E
))
1870 Earlier_In_Extended_Unit
1871 (N
, Unset_Reference
(E
)))
1872 and then not Has_Pragma_Unmodified_Check_Spec
(E
)
1873 and then not Warnings_Off_Check_Spec
(E
)
1874 and then not Has_Junk_Name
(E
)
1876 -- We may have an unset reference. The first test is whether
1877 -- this is an access to a discriminant of a record or a
1878 -- component with default initialization. Both of these
1879 -- cases can be ignored, since the actual object that is
1880 -- referenced is definitely initialized. Note that this
1881 -- covers the case of reading discriminants of an OUT
1882 -- parameter, which is OK even in Ada 83.
1884 -- Note that we are only interested in a direct reference to
1885 -- a record component here. If the reference is through an
1886 -- access type, then the access object is being referenced,
1887 -- not the record, and still deserves an unset reference.
1889 if Nkind
(Parent
(N
)) = N_Selected_Component
1890 and not Is_Access_Type
(Typ
)
1893 ES
: constant Entity_Id
:=
1894 Entity
(Selector_Name
(Parent
(N
)));
1896 if Ekind
(ES
) = E_Discriminant
1898 (Present
(Declaration_Node
(ES
))
1900 Present
(Expression
(Declaration_Node
(ES
))))
1907 -- Exclude fully initialized types
1909 if Is_OK_Fully_Initialized
then
1913 -- Here we have a potential unset reference. But before we
1914 -- get worried about it, we have to make sure that the
1915 -- entity declaration is in the same procedure as the
1916 -- reference, since if they are in separate procedures, then
1917 -- we have no idea about sequential execution.
1919 -- The tests in the loop below catch all such cases, but do
1920 -- allow the reference to appear in a loop, block, or
1921 -- package spec that is nested within the declaring scope.
1922 -- As always, it is possible to construct cases where the
1923 -- warning is wrong, that is why it is a warning.
1925 Potential_Unset_Reference
: declare
1927 SE
: constant Entity_Id
:= Scope
(E
);
1929 function Within_Postcondition
return Boolean;
1930 -- Returns True if N is within a Postcondition, a
1931 -- Refined_Post, an Ensures component in a Test_Case,
1932 -- or a Contract_Cases.
1934 --------------------------
1935 -- Within_Postcondition --
1936 --------------------------
1938 function Within_Postcondition
return Boolean is
1943 while Present
(Nod
) loop
1944 if Nkind
(Nod
) = N_Pragma
1946 Pragma_Name_Unmapped
(Nod
)
1947 in Name_Postcondition
1949 | Name_Contract_Cases
1953 elsif Present
(Parent
(Nod
)) then
1956 if Nkind
(P
) = N_Pragma
1957 and then Pragma_Name
(P
) = Name_Test_Case
1958 and then Nod
= Test_Case_Arg
(P
, Name_Ensures
)
1963 -- Prevent the search from going too far
1965 elsif Is_Body_Or_Package_Declaration
(Nod
) then
1969 Nod
:= Parent
(Nod
);
1973 end Within_Postcondition
;
1975 -- Start of processing for Potential_Unset_Reference
1978 SR
:= Current_Scope
;
1980 if SR
= Standard_Standard
1981 or else Is_Subprogram
(SR
)
1982 or else Is_Concurrent_Body
(SR
)
1983 or else Is_Concurrent_Type
(SR
)
1991 -- Case of reference has an access type. This is a
1992 -- special case since access types are always set to null
1993 -- so cannot be truly uninitialized, but we still want to
1994 -- warn about cases of obvious null dereference.
1996 if Is_Access_Type
(Typ
) then
1997 Access_Type_Case
: declare
2001 (N
: Node_Id
) return Traverse_Result
;
2002 -- Process function for instantiation of Traverse
2003 -- below. Checks if N contains reference to E other
2004 -- than a dereference.
2006 function Ref_In
(Nod
: Node_Id
) return Boolean;
2007 -- Determines whether Nod contains a reference to
2008 -- the entity E that is not a dereference.
2015 (N
: Node_Id
) return Traverse_Result
2018 if Is_Entity_Name
(N
)
2019 and then Entity
(N
) = E
2020 and then not Is_Dereferenced
(N
)
2032 function Ref_In
(Nod
: Node_Id
) return Boolean is
2033 function Traverse
is new Traverse_Func
(Process
);
2035 return Traverse
(Nod
) = Abandon
;
2038 -- Start of processing for Access_Type_Case
2041 -- Don't bother if we are inside an instance, since
2042 -- the compilation of the generic template is where
2043 -- the warning should be issued.
2049 -- Don't bother if this is not the main unit. If we
2050 -- try to give this warning for with'ed units, we
2051 -- get some false positives, since we do not record
2052 -- references in other units.
2054 if not In_Extended_Main_Source_Unit
(E
)
2056 not In_Extended_Main_Source_Unit
(N
)
2061 -- We are only interested in dereferences
2063 if not Is_Dereferenced
(N
) then
2067 -- One more check, don't bother with references
2068 -- that are inside conditional statements or WHILE
2069 -- loops if the condition references the entity in
2070 -- question. This avoids most false positives.
2077 if Nkind
(P
) in N_If_Statement | N_Elsif_Part
2078 and then Ref_In
(Condition
(P
))
2082 elsif Nkind
(P
) = N_Loop_Statement
2083 and then Present
(Iteration_Scheme
(P
))
2085 Ref_In
(Condition
(Iteration_Scheme
(P
)))
2090 end Access_Type_Case
;
2093 -- One more check, don't bother if we are within a
2094 -- postcondition, since the expression occurs in a
2095 -- place unrelated to the actual test.
2097 if not Within_Postcondition
then
2099 -- Here we definitely have a case for giving a warning
2100 -- for a reference to an unset value. But we don't
2101 -- give the warning now. Instead set Unset_Reference
2102 -- in the identifier involved. The reason for this is
2103 -- that if we find the variable is never ever assigned
2104 -- a value then that warning is more important and
2105 -- there is no point in giving the reference warning.
2107 -- If this is an identifier, set the field directly
2109 if Nkind
(N
) = N_Identifier
then
2110 Set_Unset_Reference
(E
, N
);
2112 -- Otherwise it is an expanded name, so set the field
2113 -- of the actual identifier for the reference.
2116 Set_Unset_Reference
(E
, Selector_Name
(N
));
2119 end Potential_Unset_Reference
;
2123 -- Indexed component or slice
2125 when N_Indexed_Component
2128 -- If prefix does not involve dereferencing an access type, then
2129 -- we know we are OK if the component type is fully initialized,
2130 -- since the component will have been set as part of the default
2133 if not Prefix_Has_Dereference
(Prefix
(N
))
2134 and then Is_OK_Fully_Initialized
2138 -- Look at prefix in access type case, or if the component is not
2139 -- fully initialized.
2142 Check_Unset_Reference
(Prefix
(N
));
2147 when N_Selected_Component
=>
2149 Pref
: constant Node_Id
:= Prefix
(N
);
2150 Ent
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
2153 -- If prefix involves dereferencing an access type, always
2154 -- check the prefix, since the issue then is whether this
2155 -- access value is null.
2157 if Prefix_Has_Dereference
(Pref
) then
2160 -- Always go to prefix if no selector entity is set. Can this
2161 -- happen in the normal case? Not clear, but it definitely can
2162 -- happen in error cases.
2167 -- For a record component, check some cases where we have
2168 -- reasonable cause to consider that the component is known to
2169 -- be or probably is initialized. In this case, we don't care
2170 -- if the prefix itself was explicitly initialized.
2172 -- Discriminants are always considered initialized
2174 elsif Ekind
(Ent
) = E_Discriminant
then
2177 -- An explicitly initialized component is certainly initialized
2179 elsif Nkind
(Parent
(Ent
)) = N_Component_Declaration
2180 and then Present
(Expression
(Parent
(Ent
)))
2184 -- A fully initialized component is initialized
2186 elsif Is_OK_Fully_Initialized
then
2190 -- If none of those cases apply, check the record type prefix
2192 Check_Unset_Reference
(Pref
);
2195 -- Type conversions can appear in assignment statements both
2196 -- as variable names and as expressions. We examine their own
2197 -- expressions only when processing their parent node.
2199 when N_Type_Conversion
=>
2200 Check_Unset_Reference
(Expression
(N
));
2202 -- For explicit dereference, always check prefix, which will generate
2203 -- an unset reference (since this is a case of dereferencing null).
2205 when N_Explicit_Dereference
=>
2206 Check_Unset_Reference
(Prefix
(N
));
2208 -- All other cases are not cases of an unset reference
2213 end Check_Unset_Reference
;
2215 ------------------------
2216 -- Check_Unused_Withs --
2217 ------------------------
2219 procedure Check_Unused_Withs
(Spec_Unit
: Unit_Number_Type
:= No_Unit
) is
2221 Munite
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
2222 -- This is needed for checking the special renaming case
2224 procedure Check_One_Unit
(Unit
: Unit_Number_Type
);
2225 -- Subsidiary procedure, performs checks for specified unit
2227 --------------------
2228 -- Check_One_Unit --
2229 --------------------
2231 procedure Check_One_Unit
(Unit
: Unit_Number_Type
) is
2232 Cnode
: constant Node_Id
:= Cunit
(Unit
);
2234 Is_Visible_Renaming
: Boolean := False;
2236 procedure Check_Inner_Package
(Pack
: Entity_Id
);
2237 -- Pack is a package local to a unit in a with_clause. Both the unit
2238 -- and Pack are referenced. If none of the entities in Pack are
2239 -- referenced, then the only occurrence of Pack is in a USE clause
2240 -- or a pragma, and a warning is worthwhile as well.
2242 function Check_System_Aux
(Lunit
: Entity_Id
) return Boolean;
2243 -- Before giving a warning on a with_clause for System, check whether
2244 -- a system extension is present.
2246 function Find_Package_Renaming
2248 L
: Entity_Id
) return Entity_Id
;
2249 -- The only reference to a context unit may be in a renaming
2250 -- declaration. If this renaming declares a visible entity, do not
2251 -- warn that the context clause could be moved to the body, because
2252 -- the renaming may be intended to re-export the unit.
2254 function Has_Visible_Entities
(P
: Entity_Id
) return Boolean;
2255 -- This function determines if a package has any visible entities.
2256 -- True is returned if there is at least one declared visible entity,
2257 -- otherwise False is returned (e.g. case of only pragmas present).
2259 -------------------------
2260 -- Check_Inner_Package --
2261 -------------------------
2263 procedure Check_Inner_Package
(Pack
: Entity_Id
) is
2265 Un
: constant Node_Id
:= Sinfo
.Nodes
.Unit
(Cnode
);
2267 function Check_Use_Clause
(N
: Node_Id
) return Traverse_Result
;
2268 -- If N is a use_clause for Pack, emit warning
2270 procedure Check_Use_Clauses
is new
2271 Traverse_Proc
(Check_Use_Clause
);
2273 ----------------------
2274 -- Check_Use_Clause --
2275 ----------------------
2277 function Check_Use_Clause
(N
: Node_Id
) return Traverse_Result
is
2279 if Nkind
(N
) = N_Use_Package_Clause
2280 and then Entity
(Name
(N
)) = Pack
2282 -- Suppress message if any serious errors detected that turn
2283 -- off expansion, and thus result in false positives for
2286 if Serious_Errors_Detected
= 0 then
2287 Error_Msg_Qual_Level
:= 1;
2288 Error_Msg_NE
-- CODEFIX
2289 ("?u?no entities of package& are referenced!",
2291 Error_Msg_Qual_Level
:= 0;
2296 end Check_Use_Clause
;
2298 -- Start of processing for Check_Inner_Package
2301 E
:= First_Entity
(Pack
);
2302 while Present
(E
) loop
2303 if Referenced_Check_Spec
(E
) then
2310 -- No entities of the package are referenced. Check whether the
2311 -- reference to the package itself is a use clause, and if so
2312 -- place a warning on it.
2314 Check_Use_Clauses
(Un
);
2315 end Check_Inner_Package
;
2317 ----------------------
2318 -- Check_System_Aux --
2319 ----------------------
2321 function Check_System_Aux
(Lunit
: Entity_Id
) return Boolean is
2325 if Chars
(Lunit
) = Name_System
2326 and then Scope
(Lunit
) = Standard_Standard
2327 and then Present_System_Aux
2329 Ent
:= First_Entity
(System_Aux_Id
);
2330 while Present
(Ent
) loop
2331 if Referenced_Check_Spec
(Ent
) then
2340 end Check_System_Aux
;
2342 ---------------------------
2343 -- Find_Package_Renaming --
2344 ---------------------------
2346 function Find_Package_Renaming
2348 L
: Entity_Id
) return Entity_Id
2354 Is_Visible_Renaming
:= False;
2356 E1
:= First_Entity
(P
);
2357 while Present
(E1
) loop
2358 if Ekind
(E1
) = E_Package
and then Renamed_Entity
(E1
) = L
then
2359 Is_Visible_Renaming
:= not Is_Hidden
(E1
);
2362 elsif Ekind
(E1
) = E_Package
2363 and then No
(Renamed_Entity
(E1
))
2364 and then not Is_Generic_Instance
(E1
)
2366 R
:= Find_Package_Renaming
(E1
, L
);
2369 Is_Visible_Renaming
:= not Is_Hidden
(R
);
2378 end Find_Package_Renaming
;
2380 --------------------------
2381 -- Has_Visible_Entities --
2382 --------------------------
2384 function Has_Visible_Entities
(P
: Entity_Id
) return Boolean is
2388 -- If unit in context is not a package, it is a subprogram that
2389 -- is not called or a generic unit that is not instantiated
2390 -- in the current unit, and warning is appropriate.
2392 if Ekind
(P
) /= E_Package
then
2396 -- If unit comes from a limited_with clause, look for declaration
2397 -- of shadow entities.
2399 if Present
(Limited_View
(P
)) then
2400 E
:= First_Entity
(Limited_View
(P
));
2402 E
:= First_Entity
(P
);
2405 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
2406 if Comes_From_Source
(E
) or else Present
(Limited_View
(P
)) then
2414 end Has_Visible_Entities
;
2423 -- Start of processing for Check_One_Unit
2426 -- Only do check in units that are part of the extended main unit.
2427 -- This is actually a necessary restriction, because in the case of
2428 -- subprogram acting as its own specification, there can be with's in
2429 -- subunits that we will not see.
2431 if not In_Extended_Main_Source_Unit
(Cnode
) then
2435 -- Loop through context items in this unit
2437 Item
:= First
(Context_Items
(Cnode
));
2438 while Present
(Item
) loop
2439 if Nkind
(Item
) = N_With_Clause
2440 and then not Implicit_With
(Item
)
2441 and then In_Extended_Main_Source_Unit
(Item
)
2443 -- Guard for no entity present. Not clear under what conditions
2444 -- this happens, but it does occur, and since this is only a
2445 -- warning, we just suppress the warning in this case.
2447 and then Nkind
(Name
(Item
)) in N_Has_Entity
2448 and then Present
(Entity
(Name
(Item
)))
2450 Lunit
:= Entity
(Name
(Item
));
2452 -- Check if this unit is referenced (skip the check if this
2453 -- is explicitly marked by a pragma Unreferenced).
2455 if not Referenced
(Lunit
) and then not Has_Unreferenced
(Lunit
)
2457 -- Suppress warnings in internal units if not in -gnatg mode
2458 -- (these would be junk warnings for an application program,
2459 -- since they refer to problems in internal units).
2461 if GNAT_Mode
or else not Is_Internal_Unit
(Unit
) then
2462 -- Here we definitely have a non-referenced unit. If it
2463 -- is the special call for a spec unit, then just set the
2464 -- flag to be read later.
2466 if Unit
= Spec_Unit
then
2467 Set_Unreferenced_In_Spec
(Item
);
2469 -- Otherwise simple unreferenced message, but skip this
2470 -- if no visible entities, because that is most likely a
2471 -- case where warning would be false positive (e.g. a
2472 -- package with only a linker options pragma and nothing
2473 -- else or a pragma elaborate with a body library task).
2475 elsif Has_Visible_Entities
(Lunit
) then
2476 Error_Msg_N
-- CODEFIX
2477 ("?u?unit& is not referenced!", Name
(Item
));
2481 -- If main unit is a renaming of this unit, then we consider
2482 -- the with to be OK (obviously it is needed in this case).
2483 -- This may be transitive: the unit in the with_clause may
2484 -- itself be a renaming, in which case both it and the main
2485 -- unit rename the same ultimate package.
2487 elsif Present
(Renamed_Entity
(Munite
))
2489 (Renamed_Entity
(Munite
) = Lunit
2490 or else Renamed_Entity
(Munite
) = Renamed_Entity
(Lunit
))
2494 -- If this unit is referenced, and it is a package, we do
2495 -- another test, to see if any of the entities in the package
2496 -- are referenced. If none of the entities are referenced, we
2497 -- still post a warning. This occurs if the only use of the
2498 -- package is in a use clause, or in a package renaming
2499 -- declaration. This check is skipped for packages that are
2500 -- renamed in a spec, since the entities in such a package are
2501 -- visible to clients via the renaming.
2503 elsif Ekind
(Lunit
) = E_Package
2504 and then not Renamed_In_Spec
(Lunit
)
2506 -- If Is_Instantiated is set, it means that the package is
2507 -- implicitly instantiated (this is the case of parent
2508 -- instance or an actual for a generic package formal), and
2509 -- this counts as a reference.
2511 if Is_Instantiated
(Lunit
) then
2514 -- If no entities in package, and there is a pragma
2515 -- Elaborate_Body present, then assume that this with is
2516 -- done for purposes of this elaboration.
2518 elsif No
(First_Entity
(Lunit
))
2519 and then Has_Pragma_Elaborate_Body
(Lunit
)
2523 -- Otherwise see if any entities have been referenced
2526 if Limited_Present
(Item
) then
2527 Ent
:= First_Entity
(Limited_View
(Lunit
));
2529 Ent
:= First_Entity
(Lunit
);
2533 -- No more entities, and we did not find one that was
2534 -- referenced. Means we have a definite case of a with
2535 -- none of whose entities was referenced.
2539 -- If in spec, just set the flag
2541 if Unit
= Spec_Unit
then
2542 Set_No_Entities_Ref_In_Spec
(Item
);
2544 elsif Check_System_Aux
(Lunit
) then
2547 -- Else the warning may be needed
2550 -- Warn if we unreferenced flag set and we have
2551 -- not had serious errors. The reason we inhibit
2552 -- the message if there are errors is to prevent
2553 -- false positives from disabling expansion.
2555 if not Has_Unreferenced
(Lunit
)
2556 and then Serious_Errors_Detected
= 0
2558 -- Get possible package renaming
2560 Pack
:= Find_Package_Renaming
(Munite
, Lunit
);
2562 -- No warning if either the package or its
2563 -- renaming is used as a generic actual.
2565 if Used_As_Generic_Actual
(Lunit
)
2569 Used_As_Generic_Actual
(Pack
))
2574 -- Here we give the warning
2576 Error_Msg_N
-- CODEFIX
2577 ("?u?no entities of & are referenced!",
2580 -- Flag renaming of package as well. If
2581 -- the original package has warnings off,
2582 -- we suppress the warning on the renaming
2586 and then not Has_Warnings_Off
(Lunit
)
2587 and then not Has_Unreferenced
(Pack
)
2589 Error_Msg_NE
-- CODEFIX
2590 ("?u?no entities of& are referenced!",
2591 Unit_Declaration_Node
(Pack
), Pack
);
2598 -- Case of entity being referenced. The reference may
2599 -- come from a limited_with_clause, in which case the
2600 -- limited view of the entity carries the flag.
2602 elsif Referenced_Check_Spec
(Ent
)
2603 or else Referenced_As_LHS_Check_Spec
(Ent
)
2604 or else Referenced_As_Out_Parameter_Check_Spec
(Ent
)
2606 (From_Limited_With
(Ent
)
2607 and then Is_Incomplete_Type
(Ent
)
2608 and then Present
(Non_Limited_View
(Ent
))
2609 and then Referenced
(Non_Limited_View
(Ent
)))
2611 -- This means that the with is indeed fine, in that
2612 -- it is definitely needed somewhere, and we can
2613 -- quit worrying about this one...
2615 -- Except for one little detail: if either of the
2616 -- flags was set during spec processing, this is
2617 -- where we complain that the with could be moved
2618 -- from the spec. If the spec contains a visible
2619 -- renaming of the package, inhibit warning to move
2620 -- with_clause to body.
2622 if Ekind
(Munite
) = E_Package_Body
then
2624 Find_Package_Renaming
2625 (Spec_Entity
(Munite
), Lunit
);
2630 -- If a renaming is present in the spec do not warn
2631 -- because the body or child unit may depend on it.
2634 and then Renamed_Entity
(Pack
) = Lunit
2638 elsif Unreferenced_In_Spec
(Item
) then
2639 Error_Msg_N
-- CODEFIX
2640 ("?u?unit& is not referenced in spec!",
2643 elsif No_Entities_Ref_In_Spec
(Item
) then
2644 Error_Msg_N
-- CODEFIX
2645 ("?u?no entities of & are referenced in spec!",
2649 if Ekind
(Ent
) = E_Package
then
2650 Check_Inner_Package
(Ent
);
2656 if not Is_Visible_Renaming
then
2657 Error_Msg_N
-- CODEFIX
2658 ("\?u?with clause might be moved to body!",
2664 -- Move to next entity to continue search
2672 -- For a generic package, the only interesting kind of
2673 -- reference is an instantiation, since entities cannot be
2674 -- referenced directly.
2676 elsif Is_Generic_Unit
(Lunit
) then
2678 -- Unit was never instantiated, set flag for case of spec
2679 -- call, or give warning for normal call.
2681 if not Is_Instantiated
(Lunit
) then
2682 if Unit
= Spec_Unit
then
2683 Set_Unreferenced_In_Spec
(Item
);
2685 Error_Msg_N
-- CODEFIX
2686 ("?u?unit& is never instantiated!", Name
(Item
));
2689 -- If unit was indeed instantiated, make sure that flag is
2690 -- not set showing it was uninstantiated in the spec, and if
2691 -- so, give warning.
2693 elsif Unreferenced_In_Spec
(Item
) then
2695 ("?u?unit& is not instantiated in spec!", Name
(Item
));
2696 Error_Msg_N
-- CODEFIX
2697 ("\?u?with clause can be moved to body!", Name
(Item
));
2706 -- Start of processing for Check_Unused_Withs
2709 -- Immediate return if no semantics or warning flag not set
2711 if not Check_Withs
or else Operating_Mode
= Check_Syntax
then
2715 -- Flag any unused with clauses. For a subunit, check only the units
2716 -- in its context, not those of the parent, which may be needed by other
2717 -- subunits. We will get the full warnings when we compile the parent,
2718 -- but the following is helpful when compiling a subunit by itself.
2720 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Subunit
then
2721 if Current_Sem_Unit
= Main_Unit
then
2722 Check_One_Unit
(Main_Unit
);
2728 -- Process specified units
2730 if Spec_Unit
= No_Unit
then
2732 -- For main call, check all units
2734 for Unit
in Main_Unit
.. Last_Unit
loop
2735 Check_One_Unit
(Unit
);
2739 -- For call for spec, check only the spec
2741 Check_One_Unit
(Spec_Unit
);
2743 end Check_Unused_Withs
;
2745 ---------------------------------
2746 -- Generic_Package_Spec_Entity --
2747 ---------------------------------
2749 function Generic_Package_Spec_Entity
(E
: Entity_Id
) return Boolean is
2753 if Is_Package_Body_Entity
(E
) then
2759 if S
= Standard_Standard
then
2762 elsif Ekind
(S
) = E_Generic_Package
then
2765 elsif Ekind
(S
) = E_Package
then
2773 end Generic_Package_Spec_Entity
;
2775 ----------------------
2776 -- Goto_Spec_Entity --
2777 ----------------------
2779 function Goto_Spec_Entity
(E
: Entity_Id
) return Entity_Id
is
2781 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
2782 return Spec_Entity
(E
);
2786 end Goto_Spec_Entity
;
2792 function Has_Junk_Name
(E
: Entity_Id
) return Boolean is
2793 function Match
(S
: String) return Boolean;
2794 -- Return true if substring S is found in Name_Buffer (1 .. Name_Len)
2800 function Match
(S
: String) return Boolean is
2801 Slen1
: constant Integer := S
'Length - 1;
2804 for J
in 1 .. Name_Len
- S
'Length + 1 loop
2805 if Name_Buffer
(J
.. J
+ Slen1
) = S
then
2813 -- Start of processing for Has_Junk_Name
2816 Get_Unqualified_Decoded_Name_String
(Chars
(E
));
2819 Match
("discard") or else
2820 Match
("dummy") or else
2821 Match
("ignore") or else
2822 Match
("junk") or else
2823 Match
("unuse") or else
2824 Match
("tmp") or else
2828 --------------------------------------
2829 -- Has_Pragma_Unmodified_Check_Spec --
2830 --------------------------------------
2832 function Has_Pragma_Unmodified_Check_Spec
2833 (E
: Entity_Id
) return Boolean
2836 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
2838 -- Note: use of OR instead of OR ELSE here is deliberate, we want
2839 -- to mess with Unmodified flags on both body and spec entities.
2840 -- Has_Unmodified has side effects!
2842 return Has_Unmodified
(E
)
2844 Has_Unmodified
(Spec_Entity
(E
));
2847 return Has_Unmodified
(E
);
2849 end Has_Pragma_Unmodified_Check_Spec
;
2851 ----------------------------------------
2852 -- Has_Pragma_Unreferenced_Check_Spec --
2853 ----------------------------------------
2855 function Has_Pragma_Unreferenced_Check_Spec
2856 (E
: Entity_Id
) return Boolean
2859 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
2861 -- Note: use of OR here instead of OR ELSE is deliberate, we want
2862 -- to mess with flags on both entities.
2864 return Has_Unreferenced
(E
)
2866 Has_Unreferenced
(Spec_Entity
(E
));
2869 return Has_Unreferenced
(E
);
2871 end Has_Pragma_Unreferenced_Check_Spec
;
2877 procedure Initialize
is
2879 Warnings_Off_Pragmas
.Init
;
2880 Unreferenced_Entities
.Init
;
2881 In_Out_Warnings
.Init
;
2884 ---------------------------------------------
2885 -- Is_Attribute_And_Known_Value_Comparison --
2886 ---------------------------------------------
2888 function Is_Attribute_And_Known_Value_Comparison
2889 (Op
: Node_Id
) return Boolean
2891 Orig_Op
: constant Node_Id
:= Original_Node
(Op
);
2895 Nkind
(Orig_Op
) in N_Op_Compare
2896 and then Nkind
(Original_Node
(Left_Opnd
(Orig_Op
))) =
2897 N_Attribute_Reference
2898 and then Compile_Time_Known_Value
(Right_Opnd
(Orig_Op
));
2899 end Is_Attribute_And_Known_Value_Comparison
;
2901 ------------------------------------
2902 -- Never_Set_In_Source_Check_Spec --
2903 ------------------------------------
2905 function Never_Set_In_Source_Check_Spec
(E
: Entity_Id
) return Boolean is
2907 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
2908 return Never_Set_In_Source
(E
)
2910 Never_Set_In_Source
(Spec_Entity
(E
));
2912 return Never_Set_In_Source
(E
);
2914 end Never_Set_In_Source_Check_Spec
;
2916 -------------------------------------
2917 -- Operand_Has_Warnings_Suppressed --
2918 -------------------------------------
2920 function Operand_Has_Warnings_Suppressed
(N
: Node_Id
) return Boolean is
2922 function Check_For_Warnings
(N
: Node_Id
) return Traverse_Result
;
2923 -- Function used to check one node to see if it is or was originally
2924 -- a reference to an entity for which Warnings are off. If so, Abandon
2925 -- is returned, otherwise OK_Orig is returned to continue the traversal
2926 -- of the original expression.
2928 function Traverse
is new Traverse_Func
(Check_For_Warnings
);
2929 -- Function used to traverse tree looking for warnings
2931 ------------------------
2932 -- Check_For_Warnings --
2933 ------------------------
2935 function Check_For_Warnings
(N
: Node_Id
) return Traverse_Result
is
2936 R
: constant Node_Id
:= Original_Node
(N
);
2939 if Nkind
(R
) in N_Has_Entity
2940 and then Present
(Entity
(R
))
2941 and then Has_Warnings_Off
(Entity
(R
))
2947 end Check_For_Warnings
;
2949 -- Start of processing for Operand_Has_Warnings_Suppressed
2952 return Traverse
(N
) = Abandon
;
2953 end Operand_Has_Warnings_Suppressed
;
2955 -----------------------------------------
2956 -- Output_Non_Modified_In_Out_Warnings --
2957 -----------------------------------------
2959 procedure Output_Non_Modified_In_Out_Warnings
is
2961 function Warn_On_In_Out
(E
: Entity_Id
) return Boolean;
2962 -- Given a formal parameter entity E, determines if there is a reason to
2963 -- suppress IN OUT warnings (not modified, could be IN) for formals of
2964 -- the subprogram. We suppress these warnings if Warnings Off is set, or
2965 -- if we have seen the address of the subprogram being taken, or if the
2966 -- subprogram is used as a generic actual (in the latter cases the
2967 -- context may force use of IN OUT, even if the parameter is not
2968 -- modified for this particular case).
2970 --------------------
2971 -- Warn_On_In_Out --
2972 --------------------
2974 function Warn_On_In_Out
(E
: Entity_Id
) return Boolean is
2975 S
: constant Entity_Id
:= Scope
(E
);
2976 SE
: constant Entity_Id
:= Spec_Entity
(E
);
2979 -- Do not warn if address is taken, since funny business may be going
2980 -- on in treating the parameter indirectly as IN OUT.
2982 if Address_Taken
(S
)
2983 or else (Present
(SE
) and then Address_Taken
(Scope
(SE
)))
2987 -- Do not warn if used as a generic actual, since the generic may be
2988 -- what is forcing the use of an "unnecessary" IN OUT.
2990 elsif Used_As_Generic_Actual
(S
)
2991 or else (Present
(SE
) and then Used_As_Generic_Actual
(Scope
(SE
)))
2995 -- Else test warnings off on the subprogram
2997 elsif Warnings_Off
(S
) then
3000 -- All tests for suppressing warning failed
3007 -- Start of processing for Output_Non_Modified_In_Out_Warnings
3010 -- Loop through entities for which a warning may be needed
3012 for J
in In_Out_Warnings
.First
.. In_Out_Warnings
.Last
loop
3014 E1
: constant Entity_Id
:= In_Out_Warnings
.Table
(J
);
3017 -- Suppress warning in specific cases (see details in comments for
3018 -- No_Warn_On_In_Out).
3020 if Warn_On_In_Out
(E1
) then
3021 -- If -gnatwk is set then output message that it could be IN
3023 if not Is_Trivial_Subprogram
(Scope
(E1
)) then
3024 if Warn_On_Constant
then
3026 ("?k?formal parameter & is not modified!", E1
);
3028 ("\?k?mode could be IN instead of `IN OUT`!", E1
);
3030 -- We do not generate warnings for IN OUT parameters
3031 -- unless we have at least -gnatwu. This is deliberately
3032 -- inconsistent with the treatment of variables, but
3033 -- otherwise we get too many unexpected warnings in
3036 elsif Check_Unreferenced
then
3038 ("?u?formal parameter& is read but "
3039 & "never assigned!", E1
);
3043 -- Kill any other warnings on this entity, since this is the
3044 -- one that should dominate any other unreferenced warning.
3046 Set_Warnings_Off
(E1
);
3050 end Output_Non_Modified_In_Out_Warnings
;
3052 ----------------------------------------
3053 -- Output_Obsolescent_Entity_Warnings --
3054 ----------------------------------------
3056 procedure Output_Obsolescent_Entity_Warnings
(N
: Node_Id
; E
: Entity_Id
) is
3057 P
: constant Node_Id
:= Parent
(N
);
3063 -- Do not output message if we are the scope of standard. This means
3064 -- we have a reference from a context clause from when it is originally
3065 -- processed, and that's too early to tell whether it is an obsolescent
3066 -- unit doing the with'ing. In Sem_Ch10.Analyze_Compilation_Unit we make
3067 -- sure that we have a later call when the scope is available. This test
3068 -- also eliminates all messages for use clauses, which is fine (we do
3069 -- not want messages for use clauses, since they are always redundant
3070 -- with respect to the associated with clause).
3072 if S
= Standard_Standard
then
3076 -- Do not output message if we are in scope of an obsolescent package
3080 if Is_Obsolescent
(S
) then
3085 exit when S
= Standard_Standard
;
3088 -- Here we will output the message
3090 Error_Msg_Sloc
:= Sloc
(E
);
3092 -- Case of with clause
3094 if Nkind
(P
) = N_With_Clause
then
3095 if Ekind
(E
) = E_Package
then
3097 ("?j?with of obsolescent package& declared#", N
, E
);
3098 elsif Ekind
(E
) = E_Procedure
then
3100 ("?j?with of obsolescent procedure& declared#", N
, E
);
3103 ("?j?with of obsolescent function& declared#", N
, E
);
3106 -- If we do not have a with clause, then ignore any reference to an
3107 -- obsolescent package name. We only want to give the one warning of
3108 -- withing the package, not one each time it is used to qualify.
3110 elsif Ekind
(E
) = E_Package
then
3113 -- Procedure call statement
3115 elsif Nkind
(P
) = N_Procedure_Call_Statement
then
3117 ("??call to obsolescent procedure& declared#", N
, E
);
3121 elsif Nkind
(P
) = N_Function_Call
then
3123 ("??call to obsolescent function& declared#", N
, E
);
3125 -- Reference to obsolescent type
3127 elsif Is_Type
(E
) then
3129 ("??reference to obsolescent type& declared#", N
, E
);
3131 -- Reference to obsolescent component
3133 elsif Ekind
(E
) in E_Component | E_Discriminant
then
3135 ("??reference to obsolescent component& declared#", N
, E
);
3137 -- Reference to obsolescent variable
3139 elsif Ekind
(E
) = E_Variable
then
3141 ("??reference to obsolescent variable& declared#", N
, E
);
3143 -- Reference to obsolescent constant
3145 elsif Ekind
(E
) = E_Constant
or else Ekind
(E
) in Named_Kind
then
3147 ("??reference to obsolescent constant& declared#", N
, E
);
3149 -- Reference to obsolescent enumeration literal
3151 elsif Ekind
(E
) = E_Enumeration_Literal
then
3153 ("??reference to obsolescent enumeration literal& declared#", N
, E
);
3155 -- Generic message for any other case we missed
3159 ("??reference to obsolescent entity& declared#", N
, E
);
3162 -- Output additional warning if present
3164 for J
in Obsolescent_Warnings
.First
.. Obsolescent_Warnings
.Last
loop
3165 if Obsolescent_Warnings
.Table
(J
).Ent
= E
then
3166 String_To_Name_Buffer
(Obsolescent_Warnings
.Table
(J
).Msg
);
3167 Error_Msg_Strlen
:= Name_Len
;
3168 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
3169 Error_Msg_N
("\\??~", N
);
3173 end Output_Obsolescent_Entity_Warnings
;
3175 ----------------------------------
3176 -- Output_Unreferenced_Messages --
3177 ----------------------------------
3179 procedure Output_Unreferenced_Messages
is
3181 for J
in Unreferenced_Entities
.First
.. Unreferenced_Entities
.Last
loop
3182 Warn_On_Unreferenced_Entity
(Unreferenced_Entities
.Table
(J
));
3184 end Output_Unreferenced_Messages
;
3186 -----------------------------------------
3187 -- Output_Unused_Warnings_Off_Warnings --
3188 -----------------------------------------
3190 procedure Output_Unused_Warnings_Off_Warnings
is
3192 for J
in Warnings_Off_Pragmas
.First
.. Warnings_Off_Pragmas
.Last
loop
3194 Wentry
: Warnings_Off_Entry
renames Warnings_Off_Pragmas
.Table
(J
);
3195 N
: Node_Id
renames Wentry
.N
;
3196 E
: Node_Id
renames Wentry
.E
;
3199 -- Turn off Warnings_Off, or we won't get the warning
3201 Set_Warnings_Off
(E
, False);
3203 -- Nothing to do if pragma was used to suppress a general warning
3205 if Warnings_Off_Used
(E
) then
3208 -- If pragma was used both in unmodified and unreferenced contexts
3209 -- then that's as good as the general case, no warning.
3211 elsif Warnings_Off_Used_Unmodified
(E
)
3213 Warnings_Off_Used_Unreferenced
(E
)
3217 -- Used only in context where Unmodified would have worked
3219 elsif Warnings_Off_Used_Unmodified
(E
) then
3221 ("?.w?could use Unmodified instead of "
3222 & "Warnings Off for &", Pragma_Identifier
(N
), E
);
3224 -- Used only in context where Unreferenced would have worked
3226 elsif Warnings_Off_Used_Unreferenced
(E
) then
3228 ("?.w?could use Unreferenced instead of "
3229 & "Warnings Off for &", Pragma_Identifier
(N
), E
);
3235 ("?.w?pragma Warnings Off for & unused, "
3236 & "could be omitted", N
, E
);
3240 end Output_Unused_Warnings_Off_Warnings
;
3242 ---------------------------
3243 -- Referenced_Check_Spec --
3244 ---------------------------
3246 function Referenced_Check_Spec
(E
: Entity_Id
) return Boolean is
3248 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
3249 return Referenced
(E
) or else Referenced
(Spec_Entity
(E
));
3251 return Referenced
(E
);
3253 end Referenced_Check_Spec
;
3255 ----------------------------------
3256 -- Referenced_As_LHS_Check_Spec --
3257 ----------------------------------
3259 function Referenced_As_LHS_Check_Spec
(E
: Entity_Id
) return Boolean is
3261 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
3262 return Referenced_As_LHS
(E
)
3263 or else Referenced_As_LHS
(Spec_Entity
(E
));
3265 return Referenced_As_LHS
(E
);
3267 end Referenced_As_LHS_Check_Spec
;
3269 --------------------------------------------
3270 -- Referenced_As_Out_Parameter_Check_Spec --
3271 --------------------------------------------
3273 function Referenced_As_Out_Parameter_Check_Spec
3274 (E
: Entity_Id
) return Boolean
3277 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
3278 return Referenced_As_Out_Parameter
(E
)
3279 or else Referenced_As_Out_Parameter
(Spec_Entity
(E
));
3281 return Referenced_As_Out_Parameter
(E
);
3283 end Referenced_As_Out_Parameter_Check_Spec
;
3285 --------------------------------------
3286 -- Warn_On_Constant_Valid_Condition --
3287 --------------------------------------
3289 procedure Warn_On_Constant_Valid_Condition
(Op
: Node_Id
) is
3290 Left
: constant Node_Id
:= Left_Opnd
(Op
);
3291 Right
: constant Node_Id
:= Right_Opnd
(Op
);
3293 function Comes_From_Simple_Condition_In_Source
3294 (Op
: Node_Id
) return Boolean;
3295 -- Return True if Op comes from a simple condition present in the source
3297 -------------------------------------------
3298 -- Comes_From_Simple_Condition_In_Source --
3299 -------------------------------------------
3301 function Comes_From_Simple_Condition_In_Source
3302 (Op
: Node_Id
) return Boolean
3304 Orig_Op
: constant Node_Id
:= Original_Node
(Op
);
3307 if not Comes_From_Source
(Orig_Op
) then
3311 -- We do not want to give warnings on a membership test with a mark
3312 -- for a subtype that is predicated, see also Exp_Ch4.Expand_N_In.
3314 if Nkind
(Orig_Op
) = N_In
then
3316 Orig_Rop
: constant Node_Id
:=
3317 Original_Node
(Right_Opnd
(Orig_Op
));
3319 if Is_Entity_Name
(Orig_Rop
)
3320 and then Is_Type
(Entity
(Orig_Rop
))
3321 and then Present
(Predicate_Function
(Entity
(Orig_Rop
)))
3329 end Comes_From_Simple_Condition_In_Source
;
3331 True_Result
: Boolean;
3332 False_Result
: Boolean;
3335 -- Determine the potential outcome of the comparison assuming that the
3336 -- scalar operands are valid.
3338 if Constant_Condition_Warnings
3339 and then Comes_From_Simple_Condition_In_Source
(Op
)
3340 and then Is_Scalar_Type
(Etype
(Left
))
3341 and then Is_Scalar_Type
(Etype
(Right
))
3343 -- Do not consider instances because the check was already performed
3346 and then not In_Instance
3348 -- Do not consider comparisons between two static expressions such as
3349 -- constants or literals because those values cannot be invalidated.
3351 and then not (Is_Static_Expression
(Left
)
3352 and then Is_Static_Expression
(Right
))
3354 -- Do not consider comparison between an attribute reference and a
3355 -- compile-time known value since this is most likely a conditional
3358 and then not Is_Attribute_And_Known_Value_Comparison
(Op
)
3360 -- Do not consider internal files to allow for various assertions and
3361 -- safeguards within our runtime.
3363 and then not In_Internal_Unit
(Op
)
3367 Assume_Valid
=> True,
3368 True_Result
=> True_Result
,
3369 False_Result
=> False_Result
);
3371 -- Warn on a possible evaluation to False / True in the presence of
3372 -- invalid values. But issue no warning for an assertion expression
3373 -- (or a subexpression thereof); in particular, we don't want a
3374 -- warning about an assertion that will always succeed.
3376 if In_Assertion_Expression_Pragma
(Op
) then
3379 elsif True_Result
then
3381 ("condition can only be False if invalid values present?c?", Op
);
3383 elsif False_Result
then
3385 ("condition can only be True if invalid values present?c?", Op
);
3388 end Warn_On_Constant_Valid_Condition
;
3390 -----------------------------
3391 -- Warn_On_Known_Condition --
3392 -----------------------------
3394 procedure Warn_On_Known_Condition
(C
: Node_Id
) is
3395 Test_Result
: Boolean := False;
3396 -- Force initialization to facilitate static analysis
3398 function Is_Known_Branch
return Boolean;
3399 -- If the type of the condition is Boolean, the constant value of the
3400 -- condition is a boolean literal. If the type is a derived boolean
3401 -- type, the constant is wrapped in a type conversion of the derived
3402 -- literal. If the value of the condition is not a literal, no warnings
3403 -- can be produced. This function returns True if the result can be
3404 -- determined, and Test_Result is set True/False accordingly. Otherwise
3405 -- False is returned, and Test_Result is unchanged.
3407 procedure Track
(N
: Node_Id
);
3408 -- Adds continuation warning(s) pointing to reason (assignment or test)
3409 -- for the operand of the conditional having a known value (or at least
3410 -- enough is known about the value to issue the warning).
3412 ---------------------
3413 -- Is_Known_Branch --
3414 ---------------------
3416 function Is_Known_Branch
return Boolean is
3418 if Etype
(C
) = Standard_Boolean
3419 and then Is_Entity_Name
(C
)
3421 (Entity
(C
) = Standard_False
or else Entity
(C
) = Standard_True
)
3423 Test_Result
:= Entity
(C
) = Standard_True
;
3426 elsif Is_Boolean_Type
(Etype
(C
))
3427 and then Nkind
(C
) = N_Unchecked_Type_Conversion
3428 and then Is_Entity_Name
(Expression
(C
))
3429 and then Ekind
(Entity
(Expression
(C
))) = E_Enumeration_Literal
3432 Chars
(Entity
(Expression
(C
))) = Chars
(Standard_True
);
3438 end Is_Known_Branch
;
3444 procedure Track
(N
: Node_Id
) is
3446 procedure Rec
(Sub_N
: Node_Id
);
3447 -- Recursive helper to do the work of Track, so we can refer to N's
3448 -- Sloc in error messages. Sub_N is initially N, and a proper subnode
3449 -- when recursively walking comparison operations.
3451 procedure Rec
(Sub_N
: Node_Id
) is
3452 Orig
: constant Node_Id
:= Original_Node
(Sub_N
);
3454 if Nkind
(Orig
) in N_Op_Compare
then
3455 Rec
(Left_Opnd
(Orig
));
3456 Rec
(Right_Opnd
(Orig
));
3458 elsif Is_Entity_Name
(Orig
) and then Is_Object
(Entity
(Orig
)) then
3460 CV
: constant Node_Id
:= Current_Value
(Entity
(Orig
));
3462 if Present
(CV
) then
3463 Error_Msg_Sloc
:= Sloc
(CV
);
3465 if Nkind
(CV
) not in N_Subexpr
then
3466 Error_Msg_N
("\\??(see test #)", N
);
3468 elsif Nkind
(Parent
(CV
)) =
3469 N_Case_Statement_Alternative
3471 Error_Msg_N
("\\??(see case alternative #)", N
);
3474 Error_Msg_N
("\\??(see assignment #)", N
);
3487 Orig
: constant Node_Id
:= Original_Node
(C
);
3490 -- Start of processing for Warn_On_Known_Condition
3493 -- Adjust SCO condition if from source
3496 and then Comes_From_Source
(Orig
)
3497 and then Is_Known_Branch
3500 Atrue
: Boolean := Test_Result
;
3502 if Present
(Parent
(C
)) and then Nkind
(Parent
(C
)) = N_Op_Not
then
3506 Set_SCO_Condition
(Orig
, Atrue
);
3510 -- Argument replacement in an inlined body can make conditions static.
3511 -- Do not emit warnings in this case.
3513 if In_Inlined_Body
then
3517 if Constant_Condition_Warnings
3518 and then Is_Known_Branch
3519 and then Comes_From_Source
(Orig
)
3520 and then Nkind
(Orig
) in N_Has_Entity
3521 and then not In_Instance
3523 -- Don't warn if comparison of result of attribute against a constant
3524 -- value, since this is likely legitimate conditional compilation.
3526 if Is_Attribute_And_Known_Value_Comparison
(C
) then
3530 -- See if this is in a statement or a declaration
3534 -- If tree is not attached, do not issue warning (this is very
3535 -- peculiar, and probably arises from some other error condition).
3540 -- If we are in a declaration, then no warning, since in practice
3541 -- conditionals in declarations are used for intended tests which
3542 -- may be known at compile time, e.g. things like
3544 -- x : constant Integer := 2 + (Word'Size = 32);
3546 -- And a warning is annoying in such cases
3548 elsif Nkind
(P
) in N_Declaration
3550 Nkind
(P
) in N_Later_Decl_Item
3554 -- Don't warn in assert or check pragma, since presumably tests in
3555 -- such a context are very definitely intended, and might well be
3556 -- known at compile time. Note that we have to test the original
3557 -- node, since assert pragmas get rewritten at analysis time.
3559 elsif Nkind
(Original_Node
(P
)) = N_Pragma
3561 Pragma_Name_Unmapped
(Original_Node
(P
))
3562 in Name_Assert | Name_Check
3567 exit when Is_Statement
(P
);
3571 -- Here we issue the warning unless some sub-operand has warnings
3572 -- set off, in which case we suppress the warning for the node. If
3573 -- the original expression is an inequality, it has been expanded
3574 -- into a negation, and the value of the original expression is the
3575 -- negation of the equality. If the expression is an entity that
3576 -- appears within a negation, it is clearer to flag the negation
3577 -- itself, and report on its constant value.
3579 if not Operand_Has_Warnings_Suppressed
(C
) then
3581 True_Branch
: Boolean := Test_Result
;
3582 Cond
: Node_Id
:= C
;
3584 if Present
(Parent
(C
))
3585 and then Nkind
(Parent
(C
)) = N_Op_Not
3587 True_Branch
:= not True_Branch
;
3591 -- Suppress warning if this is True/False of a derived boolean
3592 -- type with Nonzero_Is_True, which gets rewritten as Boolean
3595 if Is_Entity_Name
(Original_Node
(C
))
3596 and then Ekind
(Entity
(Original_Node
(C
)))
3597 = E_Enumeration_Literal
3598 and then Nonzero_Is_True
(Etype
(Original_Node
(C
)))
3602 -- Give warning for nontrivial always True/False case
3606 Error_Msg_N
("condition is always True?c?", Cond
);
3608 Error_Msg_N
("condition is always False?c?", Cond
);
3616 end Warn_On_Known_Condition
;
3618 ---------------------------------------
3619 -- Warn_On_Modified_As_Out_Parameter --
3620 ---------------------------------------
3622 function Warn_On_Modified_As_Out_Parameter
(E
: Entity_Id
) return Boolean is
3625 (Warn_On_Modified_Unread
and then Is_Only_Out_Parameter
(E
))
3626 or else Warn_On_All_Unread_Out_Parameters
;
3627 end Warn_On_Modified_As_Out_Parameter
;
3629 ---------------------------------
3630 -- Warn_On_Overlapping_Actuals --
3631 ---------------------------------
3633 procedure Warn_On_Overlapping_Actuals
(Subp
: Entity_Id
; N
: Node_Id
) is
3634 function Explicitly_By_Reference
(Formal_Id
: Entity_Id
) return Boolean;
3635 -- Returns True iff the type of Formal_Id is explicitly by-reference
3637 function Refer_Same_Object
3639 Act2
: Node_Id
) return Boolean;
3640 -- Two names are known to refer to the same object if the two names
3641 -- are known to denote the same object; or one of the names is a
3642 -- selected_component, indexed_component, or slice and its prefix is
3643 -- known to refer to the same object as the other name; or one of the
3644 -- two names statically denotes a renaming declaration whose renamed
3645 -- object_name is known to refer to the same object as the other name
3646 -- (RM 6.4.1(6.11/3))
3648 -----------------------------
3649 -- Explicitly_By_Reference --
3650 -----------------------------
3652 function Explicitly_By_Reference
3653 (Formal_Id
: Entity_Id
)
3656 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Formal_Id
));
3658 if Present
(Typ
) then
3659 return Is_By_Reference_Type
(Typ
)
3660 or else Convention
(Typ
) = Convention_Ada_Pass_By_Reference
;
3664 end Explicitly_By_Reference
;
3666 -----------------------
3667 -- Refer_Same_Object --
3668 -----------------------
3670 function Refer_Same_Object
3672 Act2
: Node_Id
) return Boolean
3676 Denotes_Same_Object
(Act1
, Act2
)
3677 or else Denotes_Same_Prefix
(Act1
, Act2
);
3678 end Refer_Same_Object
;
3687 -- Start of processing for Warn_On_Overlapping_Actuals
3690 -- Exclude calls rewritten as enumeration literals
3692 if Nkind
(N
) not in N_Subprogram_Call | N_Entry_Call_Statement
then
3695 -- Guard against previous errors
3697 elsif Error_Posted
(N
) then
3701 -- If a call C has two or more parameters of mode in out or out that are
3702 -- of an elementary type, then the call is legal only if for each name
3703 -- N that is passed as a parameter of mode in out or out to the call C,
3704 -- there is no other name among the other parameters of mode in out or
3705 -- out to C that is known to denote the same object (RM 6.4.1(6.15/3))
3706 -- This has been clarified in AI12-0216 to indicate that the illegality
3707 -- only occurs if both formals are of an elementary type, because of the
3708 -- nondeterminism on the write-back of the corresponding actuals.
3709 -- Earlier versions of the language made it illegal if only one of the
3710 -- actuals was an elementary parameter that overlapped a composite
3711 -- actual, and both were writable.
3713 -- If appropriate warning switch is set, we also report warnings on
3714 -- overlapping parameters that are composite types. Users find these
3715 -- warnings useful, and they are used in style guides.
3717 -- It is also worthwhile to warn on overlaps of composite objects when
3718 -- only one of the formals is (in)-out. Note that the RM rule above is
3719 -- a legality rule. We choose to implement this check as a warning to
3720 -- avoid major incompatibilities with legacy code.
3722 -- Note also that the rule in 6.4.1 (6.17/3), introduced by AI12-0324,
3723 -- is potentially more expensive to verify, and is not yet implemented.
3725 Form1
:= First_Formal
(Subp
);
3726 Act1
:= First_Actual
(N
);
3727 while Present
(Form1
) and then Present
(Act1
) loop
3729 Form2
:= Next_Formal
(Form1
);
3730 Act2
:= Next_Actual
(Act1
);
3731 while Present
(Form2
) and then Present
(Act2
) loop
3733 -- Ignore formals of generic types; they will be examined when
3736 if Is_Generic_Type
(Etype
(Form1
))
3737 or else Is_Generic_Type
(Etype
(Form2
))
3741 elsif Refer_Same_Object
(Act1
, Act2
) then
3743 -- Case 1: two writable elementary parameters that overlap
3745 if (Is_Elementary_Type
(Etype
(Form1
))
3746 and then Is_Elementary_Type
(Etype
(Form2
))
3747 and then Ekind
(Form1
) /= E_In_Parameter
3748 and then Ekind
(Form2
) /= E_In_Parameter
)
3750 -- Case 2: two composite parameters that overlap, one of
3751 -- which is writable.
3753 or else (Is_Composite_Type
(Etype
(Form1
))
3754 and then Is_Composite_Type
(Etype
(Form2
))
3755 and then (Ekind
(Form1
) /= E_In_Parameter
3756 or else Ekind
(Form2
) /= E_In_Parameter
))
3758 -- Case 3: an elementary writable parameter that overlaps
3761 or else (Is_Elementary_Type
(Etype
(Form1
))
3762 and then Ekind
(Form1
) /= E_In_Parameter
3763 and then Is_Composite_Type
(Etype
(Form2
)))
3765 or else (Is_Elementary_Type
(Etype
(Form2
))
3766 and then Ekind
(Form2
) /= E_In_Parameter
3767 and then Is_Composite_Type
(Etype
(Form1
)))
3770 -- Guard against previous errors
3772 if No
(Etype
(Act1
))
3773 or else No
(Etype
(Act2
))
3777 -- If type is explicitly by-reference, then it is not
3778 -- covered by the legality rule, which only applies to
3779 -- elementary types. Actually, the aliasing is most
3780 -- likely intended, so don't emit a warning either.
3782 elsif Explicitly_By_Reference
(Form1
)
3783 or else Explicitly_By_Reference
(Form2
)
3787 -- We only report warnings on overlapping arrays and record
3788 -- types if switch is set.
3790 elsif not Warn_On_Overlap
3791 and then not (Is_Elementary_Type
(Etype
(Form1
))
3793 Is_Elementary_Type
(Etype
(Form2
)))
3797 -- Here we may need to issue overlap message
3802 -- Overlap checking is an error only in Ada 2012. For
3803 -- earlier versions of Ada, this is a warning.
3805 Ada_Version
< Ada_2012
3807 -- Overlap is only illegal since Ada 2012 and only for
3808 -- elementary types (passed by copy). For other types
3809 -- we always have a warning in all versions. This is
3810 -- clarified by AI12-0216.
3813 (Is_Elementary_Type
(Etype
(Form1
))
3814 and then Is_Elementary_Type
(Etype
(Form2
)))
3816 -- debug flag -gnatd.E changes the error to a warning
3817 -- even in Ada 2012 mode.
3819 or else Error_To_Warning
;
3821 -- For greater clarity, give name of formal
3823 Error_Msg_Node_2
:= Form2
;
3825 -- This is one of the messages
3828 ("<.i<writable actual for & overlaps with actual for &",
3834 Next_Formal
(Form2
);
3838 Next_Formal
(Form1
);
3841 end Warn_On_Overlapping_Actuals
;
3843 ------------------------------
3844 -- Warn_On_Suspicious_Index --
3845 ------------------------------
3847 procedure Warn_On_Suspicious_Index
(Name
: Entity_Id
; X
: Node_Id
) is
3850 -- Set to lower bound for a suspicious type
3853 -- Entity for array reference
3858 function Is_Suspicious_Type
(Typ
: Entity_Id
) return Boolean;
3859 -- Tests to see if Typ is a type for which we may have a suspicious
3860 -- index, namely an unconstrained array type, whose lower bound is
3861 -- either zero or one. If so, True is returned, and Low_Bound is set
3862 -- to this lower bound. If not, False is returned, and Low_Bound is
3863 -- undefined on return.
3865 -- For now, we limit this to standard string types, so any other
3866 -- unconstrained types return False. We may change our minds on this
3867 -- later on, but strings seem the most important case.
3869 procedure Test_Suspicious_Index
;
3870 -- Test if index is of suspicious type and if so, generate warning
3872 ------------------------
3873 -- Is_Suspicious_Type --
3874 ------------------------
3876 function Is_Suspicious_Type
(Typ
: Entity_Id
) return Boolean is
3880 if Is_Array_Type
(Typ
)
3881 and then not Is_Constrained
(Typ
)
3882 and then Number_Dimensions
(Typ
) = 1
3883 and then Is_Standard_String_Type
(Typ
)
3884 and then not Has_Warnings_Off
(Typ
)
3886 LB
:= Type_Low_Bound
(Etype
(First_Index
(Typ
)));
3888 if Compile_Time_Known_Value
(LB
) then
3889 Low_Bound
:= Expr_Value
(LB
);
3890 return Low_Bound
= Uint_0
or else Low_Bound
= Uint_1
;
3895 end Is_Suspicious_Type
;
3897 ---------------------------
3898 -- Test_Suspicious_Index --
3899 ---------------------------
3901 procedure Test_Suspicious_Index
is
3903 function Length_Reference
(N
: Node_Id
) return Boolean;
3904 -- Check if node N is of the form Name'Length
3907 -- Generate first warning line
3909 procedure Warn_On_Index_Below_Lower_Bound
;
3910 -- Generate a warning on indexing the array with a literal value
3911 -- below the lower bound of the index type.
3913 procedure Warn_On_Literal_Index
;
3914 -- Generate a warning on indexing the array with a literal value
3916 ----------------------
3917 -- Length_Reference --
3918 ----------------------
3920 function Length_Reference
(N
: Node_Id
) return Boolean is
3921 R
: constant Node_Id
:= Original_Node
(N
);
3924 Nkind
(R
) = N_Attribute_Reference
3925 and then Attribute_Name
(R
) = Name_Length
3926 and then Is_Entity_Name
(Prefix
(R
))
3927 and then Entity
(Prefix
(R
)) = Ent
;
3928 end Length_Reference
;
3936 Error_Msg_Uint_1
:= Low_Bound
;
3937 Error_Msg_FE
-- CODEFIX
3938 ("?w?index for& may assume lower bound of^", X
, Ent
);
3941 -------------------------------------
3942 -- Warn_On_Index_Below_Lower_Bound --
3943 -------------------------------------
3945 procedure Warn_On_Index_Below_Lower_Bound
is
3947 if Is_Standard_String_Type
(Typ
) then
3949 (Compile_Time_Constraint_Error
3951 Msg
=> "?w?string index should be positive"));
3954 (Compile_Time_Constraint_Error
3956 Msg
=> "?w?index out of the allowed range"));
3958 end Warn_On_Index_Below_Lower_Bound
;
3960 ---------------------------
3961 -- Warn_On_Literal_Index --
3962 ---------------------------
3964 procedure Warn_On_Literal_Index
is
3968 -- Case where original form of subscript is an integer literal
3970 if Nkind
(Original_Node
(X
)) = N_Integer_Literal
then
3971 if Intval
(X
) = Low_Bound
then
3972 Error_Msg_FE
-- CODEFIX
3973 ("\?w?suggested replacement: `&''First`", X
, Ent
);
3975 Error_Msg_Uint_1
:= Intval
(X
) - Low_Bound
;
3976 Error_Msg_FE
-- CODEFIX
3977 ("\?w?suggested replacement: `&''First + ^`", X
, Ent
);
3981 -- Case where original form of subscript is more complex
3984 -- Build string X'First - 1 + expression where the expression
3985 -- is the original subscript. If the expression starts with "1
3986 -- + ", then the "- 1 + 1" is elided.
3988 Error_Msg_String
(1 .. 13) := "'First - 1 + ";
3989 Error_Msg_Strlen
:= 13;
3992 Sref
: Source_Ptr
:= Sloc
(First_Node
(Original_Node
(X
)));
3993 Tref
: constant Source_Buffer_Ptr
:=
3994 Source_Text
(Get_Source_File_Index
(Sref
));
3995 -- Tref (Sref) is used to scan the subscript
3998 -- Parentheses counter when scanning subscript
4001 -- Tref (Sref) points to start of subscript
4003 -- Elide - 1 if subscript starts with 1 +
4005 if Tref
(Sref
.. Sref
+ 2) = "1 +" then
4006 Error_Msg_Strlen
:= Error_Msg_Strlen
- 6;
4009 elsif Tref
(Sref
.. Sref
+ 1) = "1+" then
4010 Error_Msg_Strlen
:= Error_Msg_Strlen
- 6;
4014 -- Now we will copy the subscript to the string buffer
4018 -- Count parens, exit if terminating right paren. Note
4019 -- check to ignore paren appearing as character literal.
4021 if Tref
(Sref
+ 1) = '''
4023 Tref
(Sref
- 1) = '''
4027 if Tref
(Sref
) = '(' then
4029 elsif Tref
(Sref
) = ')' then
4035 -- Done if terminating double dot (slice case)
4038 and then (Tref
(Sref
.. Sref
+ 1) = ".."
4040 Tref
(Sref
.. Sref
+ 2) = " ..");
4042 -- Quit if we have hit EOF character, something wrong
4044 if Tref
(Sref
) = EOF
then
4048 -- String literals are too much of a pain to handle
4050 if Tref
(Sref
) = '"' or else Tref
(Sref
) = '%' then
4054 -- If we have a 'Range reference, then this is a case
4055 -- where we cannot easily give a replacement. Don't try.
4057 if Tref
(Sref
.. Sref
+ 4) = "range"
4058 and then Tref
(Sref
- 1) < 'A'
4059 and then Tref
(Sref
+ 5) < 'A'
4064 -- Else store next character
4066 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
4067 Error_Msg_String
(Error_Msg_Strlen
) := Tref
(Sref
);
4070 -- If we get more than 40 characters then the expression
4071 -- is too long to copy, or something has gone wrong. In
4072 -- either case, just skip the attempt at a suggested fix.
4074 if Error_Msg_Strlen
> 40 then
4080 -- Replacement subscript is now in string buffer
4082 Error_Msg_FE
-- CODEFIX
4083 ("\?w?suggested replacement: `&~`", Original_Node
(X
), Ent
);
4085 end Warn_On_Literal_Index
;
4087 -- Start of processing for Test_Suspicious_Index
4090 -- Nothing to do if subscript does not come from source (we don't
4091 -- want to give garbage warnings on compiler expanded code, e.g. the
4092 -- loops generated for slice assignments. Such junk warnings would
4093 -- be placed on source constructs with no subscript in sight).
4095 if not Comes_From_Source
(Original_Node
(X
)) then
4099 -- Case where subscript is a constant integer
4101 if Nkind
(X
) = N_Integer_Literal
then
4103 -- Case where subscript is lower than the lowest possible bound.
4104 -- This might be the case for example when programmers try to
4105 -- access a string at index 0, as they are used to in other
4106 -- programming languages like C.
4108 if Intval
(X
) < Low_Bound
then
4109 Warn_On_Index_Below_Lower_Bound
;
4111 Warn_On_Literal_Index
;
4114 -- Case where subscript is of the form X'Length
4116 elsif Length_Reference
(X
) then
4118 Error_Msg_Node_2
:= Ent
;
4120 ("\?w?suggest replacement of `&''Length` by `&''Last`",
4123 -- Case where subscript is of the form X'Length - expression
4125 elsif Nkind
(X
) = N_Op_Subtract
4126 and then Length_Reference
(Left_Opnd
(X
))
4129 Error_Msg_Node_2
:= Ent
;
4131 ("\?w?suggest replacement of `&''Length` by `&''Last`",
4132 Left_Opnd
(X
), Ent
);
4134 end Test_Suspicious_Index
;
4136 -- Start of processing for Warn_On_Suspicious_Index
4139 -- Only process if warnings activated
4141 if Warn_On_Assumed_Low_Bound
then
4143 -- Test if array is simple entity name
4145 if Is_Entity_Name
(Name
) then
4147 -- Test if array is parameter of unconstrained string type
4149 Ent
:= Entity
(Name
);
4153 and then Is_Suspicious_Type
(Typ
)
4154 and then not Low_Bound_Tested
(Ent
)
4156 Test_Suspicious_Index
;
4160 end Warn_On_Suspicious_Index
;
4162 -------------------------------
4163 -- Warn_On_Suspicious_Update --
4164 -------------------------------
4166 procedure Warn_On_Suspicious_Update
(N
: Node_Id
) is
4167 Par
: constant Node_Id
:= Parent
(N
);
4171 -- Only process if warnings activated
4173 if Warn_On_Suspicious_Contract
then
4174 if Nkind
(Par
) in N_Op_Eq | N_Op_Ne
then
4175 if N
= Left_Opnd
(Par
) then
4176 Arg
:= Right_Opnd
(Par
);
4178 Arg
:= Left_Opnd
(Par
);
4181 if Same_Object
(Prefix
(N
), Arg
) then
4182 if Nkind
(Par
) = N_Op_Eq
then
4184 ("suspicious equality test with modified version of "
4185 & "same object?.t?", Par
);
4188 ("suspicious inequality test with modified version of "
4189 & "same object?.t?", Par
);
4194 end Warn_On_Suspicious_Update
;
4196 --------------------------------------
4197 -- Warn_On_Unassigned_Out_Parameter --
4198 --------------------------------------
4200 procedure Warn_On_Unassigned_Out_Parameter
4201 (Return_Node
: Node_Id
;
4202 Scope_Id
: Entity_Id
)
4207 -- Ignore if procedure or return statement does not come from source
4209 if not Comes_From_Source
(Scope_Id
)
4210 or else not Comes_From_Source
(Return_Node
)
4215 -- Before we issue the warning, add an ad hoc defence against the most
4216 -- common case of false positives with this warning which is the case
4217 -- where there is a Boolean OUT parameter that has been set, and whose
4218 -- meaning is "ignore the values of the other parameters". We can't of
4219 -- course reliably tell this case at compile time, but the following
4220 -- test kills a lot of false positives, without generating a significant
4221 -- number of false negatives (missed real warnings).
4223 Form
:= First_Formal
(Scope_Id
);
4224 while Present
(Form
) loop
4225 if Ekind
(Form
) = E_Out_Parameter
4226 and then Root_Type
(Etype
(Form
)) = Standard_Boolean
4227 and then not Never_Set_In_Source_Check_Spec
(Form
)
4235 -- Loop through formals
4237 Form
:= First_Formal
(Scope_Id
);
4238 while Present
(Form
) loop
4240 -- We are only interested in OUT parameters that come from source
4241 -- and are never set in the source, and furthermore only in scalars
4242 -- since non-scalars generate too many false positives.
4244 if Ekind
(Form
) = E_Out_Parameter
4245 and then Never_Set_In_Source_Check_Spec
(Form
)
4246 and then Is_Scalar_Type
(Etype
(Form
))
4247 and then No
(Unset_Reference
(Form
))
4249 -- Here all conditions are met, record possible unset reference
4251 Set_Unset_Reference
(Form
, Return_Node
);
4256 end Warn_On_Unassigned_Out_Parameter
;
4258 ---------------------------------
4259 -- Warn_On_Unreferenced_Entity --
4260 ---------------------------------
4262 procedure Warn_On_Unreferenced_Entity
4263 (Spec_E
: Entity_Id
;
4264 Body_E
: Entity_Id
:= Empty
)
4266 E
: Entity_Id
:= Spec_E
;
4269 if not Referenced_Check_Spec
(E
)
4270 and then not Has_Pragma_Unreferenced_Check_Spec
(E
)
4271 and then not Warnings_Off_Check_Spec
(E
)
4272 and then not Has_Junk_Name
(Spec_E
)
4273 and then not Is_Exported
(Spec_E
)
4278 -- Case of variable that is assigned but not read. We suppress
4279 -- the message if the variable is volatile, has an address
4280 -- clause, is aliased, or is a renaming, or is imported.
4282 if Referenced_As_LHS_Check_Spec
(E
) then
4283 if Warn_On_Modified_Unread
4284 and then No
(Address_Clause
(E
))
4285 and then not Is_Volatile
(E
)
4286 and then not Is_Imported
(E
)
4287 and then not Is_Aliased
(E
)
4288 and then No
(Renamed_Object
(E
))
4290 if not Has_Pragma_Unmodified_Check_Spec
(E
) then
4291 Error_Msg_N
-- CODEFIX
4292 ("?m?variable & is assigned but never read!", E
);
4295 Set_Last_Assignment
(E
, Empty
);
4298 -- Normal case of neither assigned nor read (exclude variables
4299 -- referenced as out parameters, since we already generated
4300 -- appropriate warnings at the call point in this case).
4302 elsif not Referenced_As_Out_Parameter
(E
) then
4304 -- We suppress the message for types for which a valid
4305 -- pragma Unreferenced_Objects has been given, otherwise
4306 -- we go ahead and give the message.
4308 if not Has_Pragma_Unreferenced_Objects
(Etype
(E
)) then
4310 -- Distinguish renamed case in message
4312 if Present
(Renamed_Object
(E
))
4313 and then Comes_From_Source
(Renamed_Object
(E
))
4315 Error_Msg_N
-- CODEFIX
4316 ("?u?renamed variable & is not referenced!", E
);
4318 Error_Msg_N
-- CODEFIX
4319 ("?u?variable & is not referenced!", E
);
4325 if not Has_Pragma_Unreferenced_Objects
(Etype
(E
)) then
4326 if Present
(Renamed_Object
(E
))
4327 and then Comes_From_Source
(Renamed_Object
(E
))
4329 Error_Msg_N
-- CODEFIX
4330 ("?u?renamed constant & is not referenced!", E
);
4332 Error_Msg_N
-- CODEFIX
4333 ("?u?constant & is not referenced!", E
);
4337 when E_In_Out_Parameter
4340 -- Do not emit message for formals of a renaming, because they
4341 -- are never referenced explicitly.
4343 if Nkind
(Original_Node
(Unit_Declaration_Node
(Scope
(E
)))) /=
4344 N_Subprogram_Renaming_Declaration
4346 -- Suppress this message for an IN OUT parameter of a
4347 -- non-scalar type, since it is normal to have only an
4348 -- assignment in such a case.
4350 if Ekind
(E
) = E_In_Parameter
4351 or else not Referenced_As_LHS_Check_Spec
(E
)
4352 or else Is_Scalar_Type
(Etype
(E
))
4354 if Present
(Body_E
) then
4359 S
: Node_Id
:= Scope
(E
);
4361 if Ekind
(S
) = E_Subprogram_Body
then
4364 while Nkind
(S
) not in
4365 N_Expression_Function |
4367 N_Subprogram_Renaming_Declaration |
4374 S
:= Corresponding_Spec
(S
);
4378 -- Do not warn for dispatching operations, because
4379 -- that causes too much noise. Also do not warn for
4380 -- trivial subprograms (e.g. stubs).
4382 if (No
(S
) or else not Is_Dispatching_Operation
(S
))
4383 and then not Is_Trivial_Subprogram
(Scope
(E
))
4384 and then Check_Unreferenced_Formals
4386 Error_Msg_NE
-- CODEFIX
4387 ("?f?formal parameter & is not referenced!",
4394 when E_Out_Parameter
=>
4397 when E_Discriminant
=>
4398 Error_Msg_N
("?u?discriminant & is not referenced!", E
);
4400 when E_Named_Integer
4403 Error_Msg_N
-- CODEFIX
4404 ("?u?named number & is not referenced!", E
);
4406 when Formal_Object_Kind
=>
4407 Error_Msg_N
-- CODEFIX
4408 ("?u?formal object & is not referenced!", E
);
4410 when E_Enumeration_Literal
=>
4411 Error_Msg_N
-- CODEFIX
4412 ("?u?literal & is not referenced!", E
);
4415 Error_Msg_N
-- CODEFIX
4416 ("?u?function & is not referenced!", E
);
4419 Error_Msg_N
-- CODEFIX
4420 ("?u?procedure & is not referenced!", E
);
4423 Error_Msg_N
-- CODEFIX
4424 ("?u?package & is not referenced!", E
);
4427 Error_Msg_N
-- CODEFIX
4428 ("?u?exception & is not referenced!", E
);
4431 Error_Msg_N
-- CODEFIX
4432 ("?u?label & is not referenced!", E
);
4434 when E_Generic_Procedure
=>
4435 Error_Msg_N
-- CODEFIX
4436 ("?u?generic procedure & is never instantiated!", E
);
4438 when E_Generic_Function
=>
4439 Error_Msg_N
-- CODEFIX
4440 ("?u?generic function & is never instantiated!", E
);
4443 Error_Msg_N
-- CODEFIX
4444 ("?u?type & is not referenced!", E
);
4447 Error_Msg_N
-- CODEFIX
4448 ("?u?& is not referenced!", E
);
4451 -- Kill warnings on the entity on which the message has been posted
4452 -- (nothing is posted on out parameters because back end might be
4453 -- able to uncover an uninitialized path, and warn accordingly).
4455 if Ekind
(E
) /= E_Out_Parameter
then
4456 Set_Warnings_Off
(E
);
4459 end Warn_On_Unreferenced_Entity
;
4461 --------------------------------
4462 -- Warn_On_Useless_Assignment --
4463 --------------------------------
4465 procedure Warn_On_Useless_Assignment
4467 N
: Node_Id
:= Empty
)
4472 function Check_Ref
(N
: Node_Id
) return Traverse_Result
;
4473 -- Used to instantiate Traverse_Func. Returns Abandon if a reference to
4474 -- the entity in question is found.
4476 function Test_No_Refs
is new Traverse_Func
(Check_Ref
);
4482 function Check_Ref
(N
: Node_Id
) return Traverse_Result
is
4484 -- Check reference to our identifier. We use name equality here
4485 -- because the exception handlers have not yet been analyzed. This
4486 -- is not quite right, but it really does not matter that we fail
4487 -- to output the warning in some obscure cases of name clashes.
4489 if Nkind
(N
) = N_Identifier
and then Chars
(N
) = Chars
(Ent
) then
4496 -- Start of processing for Warn_On_Useless_Assignment
4499 -- Check if this is a case we want to warn on, a scalar or access
4500 -- variable with the last assignment field set, with warnings enabled,
4501 -- and which is not imported or exported. We also check that it is OK
4502 -- to capture the value. We are not going to capture any value, but
4503 -- the warning message depends on the same kind of conditions.
4505 -- If the assignment appears as an out-parameter in a call within an
4506 -- expression function it may be detected twice: once when expression
4507 -- itself is analyzed, and once when the constructed body is analyzed.
4508 -- We don't want to emit a spurious warning in this case.
4510 if Is_Assignable
(Ent
)
4511 and then not Is_Return_Object
(Ent
)
4512 and then Present
(Last_Assignment
(Ent
))
4513 and then Last_Assignment
(Ent
) /= N
4514 and then not Is_Imported
(Ent
)
4515 and then not Is_Exported
(Ent
)
4516 and then Safe_To_Capture_Value
(N
, Ent
)
4517 and then not Has_Pragma_Unreferenced_Check_Spec
(Ent
)
4518 and then not Has_Junk_Name
(Ent
)
4520 -- Before we issue the message, check covering exception handlers.
4521 -- Search up tree for enclosing statement sequences and handlers.
4523 P
:= Parent
(Last_Assignment
(Ent
));
4524 while Present
(P
) loop
4526 -- Something is really wrong if we don't find a handled statement
4527 -- sequence, so just suppress the warning.
4530 Set_Last_Assignment
(Ent
, Empty
);
4533 -- When we hit a package/subprogram body, issue warning and exit
4535 elsif Nkind
(P
) in N_Entry_Body
4540 -- Case of assigned value never referenced
4544 LA
: constant Node_Id
:= Last_Assignment
(Ent
);
4547 -- Don't give this for OUT and IN OUT formals, since
4548 -- clearly caller may reference the assigned value. Also
4549 -- never give such warnings for internal variables. In
4550 -- either case, word the warning in a conditional way,
4551 -- because in the case of a component of a controlled
4552 -- type, the assigned value might be referenced in the
4553 -- Finalize operation, so we can't make a definitive
4554 -- statement that it's never referenced.
4556 if Ekind
(Ent
) = E_Variable
4557 and then not Is_Internal_Name
(Chars
(Ent
))
4559 -- Give appropriate message, distinguishing between
4560 -- assignment statements and out parameters.
4562 if Nkind
(Parent
(LA
)) in N_Parameter_Association
4563 | N_Procedure_Call_Statement
4565 if Warn_On_All_Unread_Out_Parameters
then
4567 ("?.o?& modified by call, but value might not "
4568 & "be referenced", LA
, Ent
);
4571 Error_Msg_NE
-- CODEFIX
4572 ("?m?possibly useless assignment to&, value "
4573 & "might not be referenced!", LA
, Ent
);
4578 -- Case of assigned value overwritten
4582 LA
: constant Node_Id
:= Last_Assignment
(Ent
);
4585 Error_Msg_Sloc
:= Sloc
(N
);
4587 -- Give appropriate message, distinguishing between
4588 -- assignment statements and out parameters.
4590 if Nkind
(Parent
(LA
)) in N_Procedure_Call_Statement
4591 | N_Parameter_Association
4594 ("?m?& modified by call, but value overwritten #!",
4597 Error_Msg_NE
-- CODEFIX
4598 ("?m?useless assignment to&, value overwritten #!",
4604 -- Clear last assignment indication and we are done
4606 Set_Last_Assignment
(Ent
, Empty
);
4609 -- Enclosing handled sequence of statements
4611 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4613 -- Check exception handlers present
4615 if Present
(Exception_Handlers
(P
)) then
4617 -- If we are not at the top level, we regard an inner
4618 -- exception handler as a decisive indicator that we should
4619 -- not generate the warning, since the variable in question
4620 -- may be accessed after an exception in the outer block.
4622 if Nkind
(Parent
(P
)) not in N_Entry_Body
4627 Set_Last_Assignment
(Ent
, Empty
);
4630 -- Otherwise we are at the outer level. An exception
4631 -- handler is significant only if it references the
4632 -- variable in question, or if the entity in question
4633 -- is an OUT or IN OUT parameter, in which case
4634 -- the caller can reference it after the exception
4635 -- handler completes.
4638 if Is_Formal
(Ent
) then
4639 Set_Last_Assignment
(Ent
, Empty
);
4643 X
:= First
(Exception_Handlers
(P
));
4644 while Present
(X
) loop
4645 if Test_No_Refs
(X
) = Abandon
then
4646 Set_Last_Assignment
(Ent
, Empty
);
4660 end Warn_On_Useless_Assignment
;
4662 ---------------------------------
4663 -- Warn_On_Useless_Assignments --
4664 ---------------------------------
4666 procedure Warn_On_Useless_Assignments
(E
: Entity_Id
) is
4670 if Warn_On_Modified_Unread
4671 and then In_Extended_Main_Source_Unit
(E
)
4673 Ent
:= First_Entity
(E
);
4674 while Present
(Ent
) loop
4675 Warn_On_Useless_Assignment
(Ent
);
4679 end Warn_On_Useless_Assignments
;
4681 -----------------------------
4682 -- Warnings_Off_Check_Spec --
4683 -----------------------------
4685 function Warnings_Off_Check_Spec
(E
: Entity_Id
) return Boolean is
4687 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
4689 -- Note: use of OR here instead of OR ELSE is deliberate, we want
4690 -- to mess with flags on both entities.
4692 return Has_Warnings_Off
(E
)
4694 Has_Warnings_Off
(Spec_Entity
(E
));
4697 return Has_Warnings_Off
(E
);
4699 end Warnings_Off_Check_Spec
;