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 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 No
(Etype
(Actual
))
595 or else Is_Access_Subprogram_Type
(Etype
(Actual
))
599 Next_Actual
(Actual
);
604 -- Declaration of the variable in question
606 elsif Nkind
(N
) = N_Object_Declaration
607 and then Defining_Identifier
(N
) = Var
612 -- All OK, continue scan
617 -- Start of processing for Check_Infinite_Loop_Warning
620 -- Skip processing if debug flag gnatd.w is set
622 if Debug_Flag_Dot_W
then
626 -- Deal with Iteration scheme present
629 Iter
: constant Node_Id
:= Iteration_Scheme
(Loop_Statement
);
632 if Present
(Iter
) then
636 if Present
(Condition
(Iter
)) then
638 -- Skip processing for while iteration with conditions actions,
639 -- since they make it too complicated to get the warning right.
641 if Has_Condition_Actions
(Iter
) then
645 -- Capture WHILE condition
647 Expression
:= Condition
(Iter
);
649 -- For Loop_Parameter_Specification, do not process, since loop
650 -- will always terminate. For Iterator_Specification, also do not
651 -- process. Either it will always terminate (e.g. "for X of
652 -- Some_Array ..."), or we can't tell if it's going to terminate
653 -- without looking at the iterator, so any warning here would be
656 elsif Present
(Loop_Parameter_Specification
(Iter
))
657 or else Present
(Iterator_Specification
(Iter
))
664 -- Check chain of EXIT statements, we only process loops that have a
665 -- single exit condition (either a single EXIT WHEN statement, or a
666 -- WHILE loop not containing any EXIT WHEN statements).
669 Ident
: constant Node_Id
:= Identifier
(Loop_Statement
);
673 -- If we don't have a proper chain set, ignore call entirely. This
674 -- happens because of previous errors.
676 if No
(Entity
(Ident
))
677 or else Ekind
(Entity
(Ident
)) /= E_Loop
679 Check_Error_Detected
;
683 -- Otherwise prepare to scan list of EXIT statements
685 Exit_Stmt
:= First_Exit_Statement
(Entity
(Ident
));
686 while Present
(Exit_Stmt
) loop
688 -- Check for EXIT WHEN
690 if Present
(Condition
(Exit_Stmt
)) then
692 -- Quit processing if EXIT WHEN in WHILE loop, or more than
693 -- one EXIT WHEN statement present in the loop.
695 if Present
(Expression
) then
698 -- Otherwise capture condition from EXIT WHEN statement
701 Expression
:= Condition
(Exit_Stmt
);
704 -- If an unconditional exit statement is the last statement in the
705 -- loop, assume that no warning is needed, without any attempt at
706 -- checking whether the exit is reachable.
708 elsif Exit_Stmt
= Last
(Statements
(Loop_Statement
)) then
712 Exit_Stmt
:= Next_Exit_Statement
(Exit_Stmt
);
716 -- Return if no condition to test
718 if No
(Expression
) then
722 -- Initial conditions met, see if condition is of right form
724 Find_Var
(Expression
);
726 -- Nothing to do if local variable from source not found. If it's a
727 -- renaming, it is probably renaming something too complicated to deal
731 or else Ekind
(Var
) /= E_Variable
732 or else Is_Library_Level_Entity
(Var
)
733 or else not Comes_From_Source
(Var
)
734 or else Nkind
(Parent
(Var
)) = N_Object_Renaming_Declaration
738 -- Nothing to do if there is some indirection involved (assume that the
739 -- designated variable might be modified in some way we don't see).
740 -- However, if no function call was found, then we don't care about
741 -- indirections, because the condition must be something like "while X
742 -- /= null loop", so we don't care if X.all is modified in the loop.
744 elsif Function_Call_Found
and then Has_Indirection
(Etype
(Var
)) then
747 -- Same sort of thing for volatile variable, might be modified by
748 -- some other task or by the operating system in some way.
750 elsif Is_Volatile
(Var
) then
754 -- Filter out case of original statement sequence starting with delay.
755 -- We assume this is a multi-tasking program and that the condition
756 -- is affected by other threads (some kind of busy wait).
759 Fstm
: constant Node_Id
:=
760 Original_Node
(First
(Statements
(Loop_Statement
)));
762 if Nkind
(Fstm
) in N_Delay_Statement
then
767 -- We have a variable reference of the right form, now we scan the loop
768 -- body to see if it looks like it might not be modified
770 if No_Ref_Found
(Loop_Statement
) = OK
then
772 ("??variable& is not modified in loop body!", Ref
, Var
);
774 ("\??possible infinite loop!", Ref
);
776 end Check_Infinite_Loop_Warning
;
778 ----------------------------
779 -- Check_Low_Bound_Tested --
780 ----------------------------
782 procedure Check_Low_Bound_Tested
(Expr
: Node_Id
) is
783 procedure Check_Low_Bound_Tested_For
(Opnd
: Node_Id
);
784 -- Determine whether operand Opnd denotes attribute 'First whose prefix
785 -- is a formal parameter. If this is the case, mark the entity of the
786 -- prefix as having its low bound tested.
788 --------------------------------
789 -- Check_Low_Bound_Tested_For --
790 --------------------------------
792 procedure Check_Low_Bound_Tested_For
(Opnd
: Node_Id
) is
794 if Nkind
(Opnd
) = N_Attribute_Reference
795 and then Attribute_Name
(Opnd
) = Name_First
796 and then Is_Entity_Name
(Prefix
(Opnd
))
797 and then Present
(Entity
(Prefix
(Opnd
)))
798 and then Is_Formal
(Entity
(Prefix
(Opnd
)))
800 Set_Low_Bound_Tested
(Entity
(Prefix
(Opnd
)));
802 end Check_Low_Bound_Tested_For
;
804 -- Start of processing for Check_Low_Bound_Tested
807 if Comes_From_Source
(Expr
) then
808 Check_Low_Bound_Tested_For
(Left_Opnd
(Expr
));
809 Check_Low_Bound_Tested_For
(Right_Opnd
(Expr
));
811 end Check_Low_Bound_Tested
;
813 ----------------------
814 -- Check_References --
815 ----------------------
817 procedure Check_References
(E
: Entity_Id
; Anod
: Node_Id
:= Empty
) is
824 Accept_Statement
: Node_Id
) return Entity_Id
;
825 -- For an entry formal entity from an entry declaration, find the
826 -- corresponding body formal from the given accept statement.
828 function Generic_Body_Formal
(E
: Entity_Id
) return Entity_Id
;
829 -- Warnings on unused formals of subprograms are placed on the entity
830 -- in the subprogram body, which seems preferable because it suggests
831 -- a better codefix for GNAT Studio. The analysis of generic subprogram
832 -- bodies uses a different circuitry, so the choice for the proper
833 -- placement of the warning in the generic case takes place here, by
834 -- finding the body entity that corresponds to a formal in a spec.
836 procedure May_Need_Initialized_Actual
(Ent
: Entity_Id
);
837 -- If an entity of a generic type has default initialization, then the
838 -- corresponding actual type should be fully initialized, or else there
839 -- will be uninitialized components in the instantiation, that might go
840 -- unreported. This routine marks the type of the uninitialized variable
841 -- appropriately to allow the compiler to emit an appropriate warning
842 -- in the instance. In a sense, the use of a type that requires full
843 -- initialization is a weak part of the generic contract.
845 function Missing_Subunits
return Boolean;
846 -- We suppress warnings when there are missing subunits, because this
847 -- may generate too many false positives: entities in a parent may only
848 -- be referenced in one of the subunits. We make an exception for
849 -- subunits that contain no other stubs.
851 procedure Output_Reference_Error
(M
: String);
852 -- Used to output an error message. Deals with posting the error on the
853 -- body formal in the accept case.
855 function Publicly_Referenceable
(Ent
: Entity_Id
) return Boolean;
856 -- This is true if the entity in question is potentially referenceable
857 -- from another unit. This is true for entities in packages that are at
858 -- the library level.
860 function Warnings_Off_E1
return Boolean;
861 -- Return True if Warnings_Off is set for E1, or for its Etype (E1T),
862 -- or for the base type of E1T.
870 Accept_Statement
: Node_Id
) return Entity_Id
872 Body_Param
: Node_Id
;
876 -- Loop to find matching parameter in accept statement
878 Body_Param
:= First
(Parameter_Specifications
(Accept_Statement
));
879 while Present
(Body_Param
) loop
880 Body_E
:= Defining_Identifier
(Body_Param
);
882 if Chars
(Body_E
) = Chars
(E
) then
889 -- Should never fall through, should always find a match
894 -------------------------
895 -- Generic_Body_Formal --
896 -------------------------
898 function Generic_Body_Formal
(E
: Entity_Id
) return Entity_Id
is
899 Gen_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Scope
(E
));
900 Gen_Body
: constant Entity_Id
:= Corresponding_Body
(Gen_Decl
);
904 if No
(Gen_Body
) then
908 Form
:= First_Entity
(Gen_Body
);
909 while Present
(Form
) loop
910 if Chars
(Form
) = Chars
(E
) then
918 -- Should never fall through, should always find a match
921 end Generic_Body_Formal
;
923 ---------------------------------
924 -- May_Need_Initialized_Actual --
925 ---------------------------------
927 procedure May_Need_Initialized_Actual
(Ent
: Entity_Id
) is
928 T
: constant Entity_Id
:= Etype
(Ent
);
929 Par
: constant Node_Id
:= Parent
(T
);
932 if not Is_Generic_Type
(T
) then
935 elsif Nkind
(Par
) = N_Private_Extension_Declaration
then
937 -- We only indicate the first such variable in the generic.
939 if No
(Uninitialized_Variable
(Par
)) then
940 Set_Uninitialized_Variable
(Par
, Ent
);
943 elsif Nkind
(Par
) = N_Formal_Type_Declaration
944 and then Nkind
(Formal_Type_Definition
(Par
)) =
945 N_Formal_Private_Type_Definition
947 if No
(Uninitialized_Variable
(Formal_Type_Definition
(Par
))) then
948 Set_Uninitialized_Variable
(Formal_Type_Definition
(Par
), Ent
);
951 end May_Need_Initialized_Actual
;
953 ----------------------
954 -- Missing_Subunits --
955 ----------------------
957 function Missing_Subunits
return Boolean is
961 if not Unloaded_Subunits
then
963 -- Normal compilation, all subunits are present
967 elsif E
/= Main_Unit_Entity
then
969 -- No warnings on a stub that is not the main unit
973 elsif Nkind
(Unit_Declaration_Node
(E
)) in N_Proper_Body
then
974 D
:= First
(Declarations
(Unit_Declaration_Node
(E
)));
975 while Present
(D
) loop
977 -- No warnings if the proper body contains nested stubs
979 if Nkind
(D
) in N_Body_Stub
then
989 -- Missing stubs elsewhere
993 end Missing_Subunits
;
995 ----------------------------
996 -- Output_Reference_Error --
997 ----------------------------
999 procedure Output_Reference_Error
(M
: String) is
1001 -- Never issue messages for internal names or renamings
1003 if Is_Internal_Name
(Chars
(E1
))
1004 or else Nkind
(Parent
(E1
)) = N_Object_Renaming_Declaration
1009 -- Don't output message for IN OUT formal unless we have the warning
1010 -- flag specifically set. It is a bit odd to distinguish IN OUT
1011 -- formals from other cases. This distinction is historical in
1012 -- nature. Warnings for IN OUT formals were added fairly late.
1014 if Ekind
(E1
) = E_In_Out_Parameter
1015 and then not Check_Unreferenced_Formals
1020 -- Other than accept case, post error on defining identifier
1023 Error_Msg_N
(M
, E1
);
1025 -- Accept case, find body formal to post the message
1028 Error_Msg_NE
(M
, Body_Formal
(E1
, Accept_Statement
=> Anod
), E1
);
1031 end Output_Reference_Error
;
1033 ----------------------------
1034 -- Publicly_Referenceable --
1035 ----------------------------
1037 function Publicly_Referenceable
(Ent
: Entity_Id
) return Boolean is
1042 -- A formal parameter is never referenceable outside the body of its
1043 -- subprogram or entry.
1045 if Is_Formal
(Ent
) then
1049 -- Examine parents to look for a library level package spec. But if
1050 -- we find a body or block or other similar construct along the way,
1051 -- we cannot be referenced.
1058 -- If we get to top of tree, then publicly referenceable
1063 -- If we reach a generic package declaration, then always
1064 -- consider this referenceable, since any instantiation will
1065 -- have access to the entities in the generic package. Note
1066 -- that the package itself may not be instantiated, but then
1067 -- we will get a warning for the package entity.
1069 -- Note that generic formal parameters are themselves not
1070 -- publicly referenceable in an instance, and warnings on them
1073 when N_Generic_Package_Declaration
=>
1075 not Is_List_Member
(Prev
)
1076 or else List_Containing
(Prev
) /=
1077 Generic_Formal_Declarations
(P
);
1079 -- Similarly, the generic formals of a generic subprogram are
1082 when N_Generic_Subprogram_Declaration
=>
1083 if Is_List_Member
(Prev
)
1084 and then List_Containing
(Prev
) =
1085 Generic_Formal_Declarations
(P
)
1092 -- If we reach a subprogram body, entity is not referenceable
1093 -- unless it is the defining entity of the body. This will
1094 -- happen, e.g. when a function is an attribute renaming that
1095 -- is rewritten as a body.
1097 when N_Subprogram_Body
=>
1098 if Ent
/= Defining_Entity
(P
) then
1104 -- If we reach any other body, definitely not referenceable
1106 when N_Block_Statement
1115 -- For all other cases, keep looking up tree
1122 end Publicly_Referenceable
;
1124 ---------------------
1125 -- Warnings_Off_E1 --
1126 ---------------------
1128 function Warnings_Off_E1
return Boolean is
1130 return Has_Warnings_Off
(E1T
)
1131 or else Has_Warnings_Off
(Base_Type
(E1T
))
1132 or else Warnings_Off_Check_Spec
(E1
);
1133 end Warnings_Off_E1
;
1135 -- Start of processing for Check_References
1138 -- No messages if warnings are suppressed, or if we have detected any
1139 -- real errors so far (this last check avoids junk messages resulting
1140 -- from errors, e.g. a subunit that is not loaded).
1142 if Warning_Mode
= Suppress
or else Serious_Errors_Detected
/= 0 then
1146 -- We also skip the messages if any subunits were not loaded (see
1147 -- comment in Sem_Ch10 to understand how this is set, and why it is
1148 -- necessary to suppress the warnings in this case).
1150 if Missing_Subunits
then
1154 -- Otherwise loop through entities, looking for suspicious stuff
1156 E1
:= First_Entity
(E
);
1157 while Present
(E1
) loop
1158 -- We are only interested in source entities. We also don't issue
1159 -- warnings within instances, since the proper place for such
1160 -- warnings is on the template when it is compiled, and we don't
1161 -- issue warnings for variables with names like Junk, Discard etc.
1163 if Comes_From_Source
(E1
)
1164 and then Instantiation_Location
(Sloc
(E1
)) = No_Location
1168 -- We are interested in variables and out/in-out parameters, but
1169 -- we exclude protected types, too complicated to worry about.
1171 if Ekind
(E1
) = E_Variable
1173 (Ekind
(E1
) in E_Out_Parameter | E_In_Out_Parameter
1174 and then not Is_Protected_Type
(Current_Scope
))
1176 -- If the formal has a class-wide type, retrieve its type
1177 -- because checks below depend on its private nature.
1179 if Is_Class_Wide_Type
(E1T
) then
1183 -- Case of an unassigned variable
1185 -- First gather any Unset_Reference indication for E1. In the
1186 -- case of an 'out' parameter, it is the Spec_Entity that is
1189 if Ekind
(E1
) = E_Out_Parameter
1190 and then Present
(Spec_Entity
(E1
))
1192 UR
:= Unset_Reference
(Spec_Entity
(E1
));
1194 UR
:= Unset_Reference
(E1
);
1197 -- Special processing for access types
1199 if Present
(UR
) and then Is_Access_Type
(E1T
) then
1201 -- For access types, the only time we made a UR entry was
1202 -- for a dereference, and so we post the appropriate warning
1203 -- here (note that the dereference may not be explicit in
1204 -- the source, for example in the case of a dispatching call
1205 -- with an anonymous access controlling formal, or of an
1206 -- assignment of a pointer involving discriminant check on
1207 -- the designated object).
1209 if not Warnings_Off_E1
then
1210 Error_Msg_NE
("??& may be null!", UR
, E1
);
1215 -- Case of variable that could be a constant. Note that we
1216 -- never signal such messages for generic package entities,
1217 -- since a given instance could have modifications outside
1220 -- Note that we used to check Address_Taken here, but we don't
1221 -- want to do that since it can be set for non-source cases,
1222 -- e.g. the Unrestricted_Access from a valid attribute, and
1223 -- the wanted effect is included in Never_Set_In_Source.
1225 elsif Warn_On_Constant
1226 and then Ekind
(E1
) = E_Variable
1227 and then Has_Initial_Value
(E1
)
1228 and then Never_Set_In_Source
(E1
)
1229 and then not Generic_Package_Spec_Entity
(E1
)
1231 -- A special case, if this variable is volatile and not
1232 -- imported, it is not helpful to tell the programmer
1233 -- to mark the variable as constant, since this would be
1234 -- illegal by virtue of RM C.6(13). Instead we suggest
1235 -- using pragma Export (can't be Import because of the
1238 if (Is_Volatile
(E1
) or else Has_Volatile_Components
(E1
))
1239 and then not Is_Imported
(E1
)
1242 ("?k?& is not modified, consider pragma Export for "
1243 & "volatile variable!", E1
);
1245 -- Another special case, Exception_Occurrence, this catches
1246 -- the case of exception choice (and a bit more too, but not
1247 -- worth doing more investigation here).
1249 elsif Is_RTE
(E1T
, RE_Exception_Occurrence
) then
1252 -- Here we give the warning if referenced and no pragma
1253 -- Unreferenced or Unmodified is present.
1255 elsif Referenced
(E1
)
1256 and then not Has_Unreferenced
(E1
)
1257 and then not Has_Unmodified
(E1
)
1258 and then not Warnings_Off_E1
1259 and then not Has_Junk_Name
(E1
)
1261 Error_Msg_N
-- CODEFIX
1262 ("?k?& is not modified, could be declared constant!",
1266 -- Other cases of a variable or parameter never set in source
1268 elsif Never_Set_In_Source_Check_Spec
(E1
)
1270 -- No warning if address taken somewhere
1272 and then not Address_Taken
(E1
)
1274 -- No warning if explicit initial value
1276 and then not Has_Initial_Value
(E1
)
1278 -- No warning for generic package spec entities, since we
1279 -- might set them in a child unit or something like that
1281 and then not Generic_Package_Spec_Entity
(E1
)
1283 -- No warning if fully initialized type, except that for
1284 -- this purpose we do not consider access types to qualify
1285 -- as fully initialized types (relying on an access type
1286 -- variable being null when it is never set is a bit odd).
1288 -- Also we generate warning for an out parameter that is
1289 -- never referenced, since again it seems odd to rely on
1290 -- default initialization to set an out parameter value.
1292 and then (Is_Access_Type
(E1T
)
1293 or else Ekind
(E1
) = E_Out_Parameter
1294 or else not Is_Fully_Initialized_Type
(E1T
))
1296 -- Do not output complaint about never being assigned a
1297 -- value if a pragma Unmodified applies to the variable
1298 -- we are examining, or if it is a parameter, if there is
1299 -- a pragma Unreferenced for the corresponding spec, or
1300 -- if the type is marked as having unreferenced objects.
1301 -- The last is a little peculiar, but better too few than
1302 -- too many warnings in this situation.
1304 if Has_Pragma_Unreferenced_Objects
(E1T
)
1305 or else Has_Pragma_Unmodified_Check_Spec
(E1
)
1309 -- IN OUT parameter case where parameter is referenced. We
1310 -- separate this out, since this is the case where we delay
1311 -- output of the warning until more information is available
1312 -- (about use in an instantiation or address being taken).
1314 elsif Ekind
(E1
) = E_In_Out_Parameter
1315 and then Referenced_Check_Spec
(E1
)
1317 -- Suppress warning if private type, and the procedure
1318 -- has a separate declaration in a different unit. This
1319 -- is the case where the client of a package sees only
1320 -- the private type, and it may be quite reasonable
1321 -- for the logical view to be IN OUT, even if the
1322 -- implementation ends up using access types or some
1323 -- other method to achieve the local effect of a
1324 -- modification. On the other hand if the spec and body
1325 -- are in the same unit, we are in the package body and
1326 -- there we have less excuse for a junk IN OUT parameter.
1328 if Has_Private_Declaration
(E1T
)
1329 and then Present
(Spec_Entity
(E1
))
1330 and then not In_Same_Source_Unit
(E1
, Spec_Entity
(E1
))
1334 -- Suppress warning for any parameter of a dispatching
1335 -- operation, since it is quite reasonable to have an
1336 -- operation that is overridden, and for some subclasses
1337 -- needs the formal to be IN OUT and for others happens
1338 -- not to assign it.
1340 elsif Is_Dispatching_Operation
1341 (Scope
(Goto_Spec_Entity
(E1
)))
1345 -- Suppress warning if composite type contains any access
1346 -- component, since the logical effect of modifying a
1347 -- parameter may be achieved by modifying a referenced
1348 -- object. This rationale does not apply to private
1349 -- types, so we warn in that case.
1351 elsif Is_Composite_Type
(E1T
)
1352 and then not Is_Private_Type
(E1T
)
1353 and then Has_Access_Values
(E1T
)
1357 -- Suppress warning on formals of an entry body. All
1358 -- references are attached to the formal in the entry
1359 -- declaration, which are marked Is_Entry_Formal.
1361 elsif Ekind
(Scope
(E1
)) = E_Entry
1362 and then not Is_Entry_Formal
(E1
)
1366 -- OK, looks like warning for an IN OUT parameter that
1367 -- could be IN makes sense, but we delay the output of
1368 -- the warning, pending possibly finding out later on
1369 -- that the associated subprogram is used as a generic
1370 -- actual, or its address/access is taken. In these two
1371 -- cases, we suppress the warning because the context may
1372 -- force use of IN OUT, even if in this particular case
1373 -- the formal is not modified.
1375 elsif Warn_On_No_Value_Assigned
then
1376 -- Suppress the warnings for a junk name
1378 if not Has_Junk_Name
(E1
) then
1379 In_Out_Warnings
.Append
(E1
);
1383 -- Other cases of formals
1385 elsif Is_Formal
(E1
) then
1386 if not Is_Trivial_Subprogram
(Scope
(E1
)) then
1387 if Referenced_Check_Spec
(E1
) then
1388 if not Has_Pragma_Unmodified_Check_Spec
(E1
)
1389 and then not Warnings_Off_E1
1390 and then not Has_Junk_Name
(E1
)
1391 and then Warn_On_No_Value_Assigned
1393 Output_Reference_Error
1394 ("?v?formal parameter& is read but "
1395 & "never assigned!");
1398 elsif not Has_Pragma_Unreferenced_Check_Spec
(E1
)
1399 and then not Warnings_Off_E1
1400 and then not Has_Junk_Name
(E1
)
1401 and then Check_Unreferenced_Formals
1403 Output_Reference_Error
1404 ("?f?formal parameter& is not referenced!");
1411 if Referenced
(E1
) then
1412 if Warn_On_No_Value_Assigned
1413 and then not Has_Unmodified
(E1
)
1414 and then not Warnings_Off_E1
1415 and then not Has_Junk_Name
(E1
)
1417 if Is_Access_Type
(E1T
)
1419 not Is_Partially_Initialized_Type
(E1T
, False)
1421 Output_Reference_Error
1422 ("?v?variable& is read but never assigned!");
1425 May_Need_Initialized_Actual
(E1
);
1428 elsif Check_Unreferenced
1429 and then not Has_Unreferenced
(E1
)
1430 and then not Warnings_Off_E1
1431 and then not Has_Junk_Name
(E1
)
1433 Output_Reference_Error
-- CODEFIX
1434 ("?u?variable& is never read and never assigned!");
1437 -- Deal with special case where this variable is hidden
1438 -- by a loop variable.
1440 if Ekind
(E1
) = E_Variable
1441 and then Present
(Hiding_Loop_Variable
(E1
))
1442 and then not Warnings_Off_E1
1443 and then Warn_On_Hiding
1446 ("?h?for loop implicitly declares loop variable!",
1447 Hiding_Loop_Variable
(E1
));
1449 Error_Msg_Sloc
:= Sloc
(E1
);
1451 ("\?h?declaration hides & declared#!",
1452 Hiding_Loop_Variable
(E1
));
1459 -- Check for unset reference. If type of object has
1460 -- preelaborable initialization, warning is misleading.
1462 if Warn_On_No_Value_Assigned
1463 and then Present
(UR
)
1464 and then not Known_To_Have_Preelab_Init
(Etype
(E1
))
1467 -- Don't issue warning if appearing inside Initial_Condition
1468 -- pragma or aspect, since that expression is not evaluated
1469 -- at the point where it occurs in the source.
1471 if In_Pragma_Expression
(UR
, Name_Initial_Condition
) then
1475 -- Here we issue the warning, all checks completed
1477 -- If we have a return statement, this was a case of an OUT
1478 -- parameter not being set at the time of the return. (Note:
1479 -- it can't be N_Extended_Return_Statement, because those
1480 -- are only for functions, and functions do not allow OUT
1483 if not Is_Trivial_Subprogram
(Scope
(E1
)) then
1484 if Nkind
(UR
) = N_Simple_Return_Statement
1485 and then not Has_Pragma_Unmodified_Check_Spec
(E1
)
1487 if not Warnings_Off_E1
1488 and then not Has_Junk_Name
(E1
)
1491 ("?v?OUT parameter& not set before return",
1495 -- If the unset reference is a selected component
1496 -- prefix from source, mention the component as well.
1497 -- If the selected component comes from expansion, all
1498 -- we know is that the entity is not fully initialized
1499 -- at the point of the reference. Locate a random
1500 -- uninitialized component to get a better message.
1502 elsif Nkind
(Parent
(UR
)) = N_Selected_Component
then
1503 -- Suppress possibly superfluous warning if component
1504 -- is known to exist and is partially initialized.
1506 if not Has_Discriminants
(Etype
(E1
))
1508 Is_Partially_Initialized_Type
1509 (Etype
(Parent
(UR
)), False)
1514 Error_Msg_Node_2
:= Selector_Name
(Parent
(UR
));
1516 if not Comes_From_Source
(Parent
(UR
)) then
1521 Comp
:= First_Component
(E1T
);
1522 while Present
(Comp
) loop
1523 if Nkind
(Parent
(Comp
)) =
1524 N_Component_Declaration
1525 and then No
(Expression
(Parent
(Comp
)))
1527 Error_Msg_Node_2
:= Comp
;
1531 Next_Component
(Comp
);
1536 -- Issue proper warning. This is a case of referencing
1537 -- a variable before it has been explicitly assigned.
1538 -- For access types, UR was only set for dereferences,
1539 -- so the issue is that the value may be null.
1541 if not Warnings_Off_E1
then
1542 if Is_Access_Type
(Etype
(Parent
(UR
))) then
1543 Error_Msg_N
("??`&.&` may be null!", UR
);
1546 ("??`&.&` may be referenced before "
1547 & "it has a value!", UR
);
1551 -- All other cases of unset reference active
1553 elsif not Warnings_Off_E1
then
1555 ("??& may be referenced before it has a value!", UR
);
1564 -- Then check for unreferenced entities. Note that we are only
1565 -- interested in entities whose Referenced flag is not set.
1567 if not Referenced_Check_Spec
(E1
)
1569 -- If Referenced_As_LHS is set, then that's still interesting
1570 -- (potential "assigned but never read" case), but not if we
1571 -- have pragma Unreferenced, which cancels this warning.
1573 and then (not Referenced_As_LHS_Check_Spec
(E1
)
1574 or else not Has_Unreferenced
(E1
))
1576 -- Check that warnings on unreferenced entities are enabled
1579 ((Check_Unreferenced
and then not Is_Formal
(E1
))
1581 -- Case of warning on unreferenced formal
1583 or else (Check_Unreferenced_Formals
and then Is_Formal
(E1
))
1585 -- Case of warning on unread variables modified by an
1586 -- assignment, or an OUT parameter if it is the only one.
1588 or else (Warn_On_Modified_Unread
1589 and then Referenced_As_LHS_Check_Spec
(E1
))
1591 -- Case of warning on any unread OUT parameter (note such
1592 -- indications are only set if the appropriate warning
1593 -- options were set, so no need to recheck here.)
1595 or else Referenced_As_Out_Parameter_Check_Spec
(E1
))
1597 -- All other entities, including local packages that cannot be
1598 -- referenced from elsewhere, including those declared within a
1601 and then (Is_Object
(E1
)
1602 or else Is_Type
(E1
)
1603 or else Ekind
(E1
) = E_Label
1604 or else Ekind
(E1
) in E_Exception
1607 or else Is_Overloadable
(E1
)
1609 -- Package case, if the main unit is a package spec
1610 -- or generic package spec, then there may be a
1611 -- corresponding body that references this package
1612 -- in some other file. Otherwise we can be sure
1613 -- that there is no other reference.
1616 (Ekind
(E1
) = E_Package
1618 not Is_Package_Or_Generic_Package
1619 (Cunit_Entity
(Current_Sem_Unit
))))
1621 -- Consider private type referenced if full view is referenced.
1622 -- If there is not full view, this is a generic type on which
1623 -- warnings are also useful.
1626 not (Is_Private_Type
(E1
)
1627 and then Present
(Full_View
(E1
))
1628 and then Referenced
(Full_View
(E1
)))
1630 -- Don't worry about full view, only about private type
1632 and then not Has_Private_Declaration
(E1
)
1634 -- Eliminate dispatching operations from consideration, we
1635 -- cannot tell if these are referenced or not in any easy
1636 -- manner (note this also catches Adjust/Finalize/Initialize).
1638 and then not Is_Dispatching_Operation
(E1
)
1640 -- Check entity that can be publicly referenced (we do not give
1641 -- messages for such entities, since there could be other
1642 -- units, not involved in this compilation, that contain
1643 -- relevant references.
1645 and then not Publicly_Referenceable
(E1
)
1647 -- Class wide types are marked as source entities, but they are
1648 -- not really source entities, and are always created, so we do
1649 -- not care if they are not referenced.
1651 and then Ekind
(E1
) /= E_Class_Wide_Type
1653 -- Objects other than parameters of task types are allowed to
1654 -- be non-referenced, since they start up tasks.
1656 and then ((Ekind
(E1
) /= E_Variable
1657 and then Ekind
(E1
) /= E_Constant
1658 and then Ekind
(E1
) /= E_Component
)
1660 -- Check that E1T is not a task or a composite type
1661 -- with a task component.
1663 or else not Has_Task
(E1T
))
1665 -- For subunits, only place warnings on the main unit itself,
1666 -- since parent units are not completely compiled.
1668 and then (Nkind
(Unit
(Cunit
(Main_Unit
))) /= N_Subunit
1669 or else Get_Source_Unit
(E1
) = Main_Unit
)
1671 -- No warning on a return object, because these are often
1672 -- created with a single expression and an implicit return.
1673 -- If the object is a variable there will be a warning
1674 -- indicating that it could be declared constant.
1677 (Ekind
(E1
) = E_Constant
and then Is_Return_Object
(E1
))
1679 -- Suppress warnings in internal units if not in -gnatg mode
1680 -- (these would be junk warnings for an applications program,
1681 -- since they refer to problems in internal units).
1683 if GNAT_Mode
or else not In_Internal_Unit
(E1
) then
1684 -- We do not immediately flag the error. This is because we
1685 -- have not expanded generic bodies yet, and they may have
1686 -- the missing reference. So instead we park the entity on a
1687 -- list, for later processing. However for the case of an
1688 -- accept statement we want to output messages now, since
1689 -- we know we already have all information at hand, and we
1690 -- also want to have separate warnings for each accept
1691 -- statement for the same entry.
1693 if Present
(Anod
) then
1694 pragma Assert
(Is_Formal
(E1
));
1696 -- The unreferenced entity is E1, but post the warning
1697 -- on the body entity for this accept statement.
1699 if not Warnings_Off_E1
then
1700 Warn_On_Unreferenced_Entity
1701 (E1
, Body_Formal
(E1
, Accept_Statement
=> Anod
));
1704 elsif not Warnings_Off_E1
1705 and then not Has_Junk_Name
(E1
)
1708 and then Nkind
(Unit_Declaration_Node
(Scope
(E1
)))
1709 = N_Generic_Subprogram_Declaration
1711 Unreferenced_Entities
.Append
1712 (Generic_Body_Formal
(E1
));
1714 Unreferenced_Entities
.Append
(E1
);
1719 -- Generic units are referenced in the generic body, but if they
1720 -- are not public and never instantiated we want to force a
1721 -- warning on them. We treat them as redundant constructs to
1724 elsif Is_Generic_Subprogram
(E1
)
1725 and then not Is_Instantiated
(E1
)
1726 and then not Publicly_Referenceable
(E1
)
1727 and then Warn_On_Redundant_Constructs
1729 if not Warnings_Off_E1
and then not Has_Junk_Name
(E1
) then
1730 Unreferenced_Entities
.Append
(E1
);
1732 -- Force warning on entity
1734 Set_Referenced
(E1
, False);
1739 -- Recurse into nested package or block. Do not recurse into a formal
1740 -- package, because the corresponding body is not analyzed.
1743 if (Is_Package_Or_Generic_Package
(E1
)
1744 and then Nkind
(Parent
(E1
)) = N_Package_Specification
1746 Nkind
(Original_Node
(Unit_Declaration_Node
(E1
))) /=
1747 N_Formal_Package_Declaration
)
1749 or else Ekind
(E1
) = E_Block
1751 Check_References
(E1
);
1756 end Check_References
;
1758 ---------------------------
1759 -- Check_Unset_Reference --
1760 ---------------------------
1762 procedure Check_Unset_Reference
(N
: Node_Id
) is
1763 Typ
: constant Entity_Id
:= Etype
(N
);
1765 function Is_OK_Fully_Initialized
return Boolean;
1766 -- This function returns true if the given node N is fully initialized
1767 -- so that the reference is safe as far as this routine is concerned.
1768 -- Safe generally means that the type of N is a fully initialized type.
1769 -- The one special case is that for access types, which are always fully
1770 -- initialized, we don't consider a dereference OK since it will surely
1771 -- be dereferencing a null value, which won't do.
1773 function Prefix_Has_Dereference
(Pref
: Node_Id
) return Boolean;
1774 -- Used to test indexed or selected component or slice to see if the
1775 -- evaluation of the prefix depends on a dereference, and if so, returns
1776 -- True, in which case we always check the prefix, even if we know that
1777 -- the referenced component is initialized. Pref is the prefix to test.
1779 -----------------------------
1780 -- Is_OK_Fully_Initialized --
1781 -----------------------------
1783 function Is_OK_Fully_Initialized
return Boolean is
1785 if Is_Access_Type
(Typ
) and then Is_Dereferenced
(N
) then
1788 -- A type subject to pragma Default_Initial_Condition may be fully
1789 -- default initialized depending on inheritance and the argument of
1790 -- the pragma (SPARK RM 3.1 and SPARK RM 7.3.3).
1792 elsif Has_Fully_Default_Initializing_DIC_Pragma
(Typ
) then
1796 return Is_Fully_Initialized_Type
(Typ
);
1798 end Is_OK_Fully_Initialized
;
1800 ----------------------------
1801 -- Prefix_Has_Dereference --
1802 ----------------------------
1804 function Prefix_Has_Dereference
(Pref
: Node_Id
) return Boolean is
1806 -- If prefix is of an access type, it certainly needs a dereference
1808 if Is_Access_Type
(Etype
(Pref
)) then
1811 -- If prefix is explicit dereference, that's a dereference for sure
1813 elsif Nkind
(Pref
) = N_Explicit_Dereference
then
1816 -- If prefix is itself a component reference or slice check prefix
1818 elsif Nkind
(Pref
) = N_Slice
1819 or else Nkind
(Pref
) = N_Indexed_Component
1820 or else Nkind
(Pref
) = N_Selected_Component
1822 return Prefix_Has_Dereference
(Prefix
(Pref
));
1824 -- All other cases do not involve a dereference
1829 end Prefix_Has_Dereference
;
1831 -- Start of processing for Check_Unset_Reference
1834 -- Nothing to do if warnings suppressed
1836 if Warning_Mode
= Suppress
then
1840 -- Ignore reference unless it comes from source. Almost always if we
1841 -- have a reference from generated code, it is bogus (e.g. calls to init
1842 -- procs to set default discriminant values).
1844 if not Comes_From_Source
(Original_Node
(N
)) then
1848 -- Otherwise see what kind of node we have. If the entity already has an
1849 -- unset reference, it is not necessarily the earliest in the text,
1850 -- because resolution of the prefix of selected components is completed
1851 -- before the resolution of the selected component itself. As a result,
1852 -- given (R /= null and then R.X > 0), the occurrences of R are examined
1853 -- in right-to-left order. If there is already an unset reference, we
1854 -- check whether N is earlier before proceeding.
1858 -- For identifier or expanded name, examine the entity involved
1860 when N_Expanded_Name
1864 E
: constant Entity_Id
:= Entity
(N
);
1867 if Ekind
(E
) in E_Variable | E_Out_Parameter
1868 and then Never_Set_In_Source_Check_Spec
(E
)
1869 and then not Has_Initial_Value
(E
)
1870 and then (No
(Unset_Reference
(E
))
1872 Earlier_In_Extended_Unit
1873 (N
, Unset_Reference
(E
)))
1874 and then not Has_Pragma_Unmodified_Check_Spec
(E
)
1875 and then not Warnings_Off_Check_Spec
(E
)
1876 and then not Has_Junk_Name
(E
)
1878 -- We may have an unset reference. The first test is whether
1879 -- this is an access to a discriminant of a record or a
1880 -- component with default initialization. Both of these
1881 -- cases can be ignored, since the actual object that is
1882 -- referenced is definitely initialized. Note that this
1883 -- covers the case of reading discriminants of an OUT
1884 -- parameter, which is OK even in Ada 83.
1886 -- Note that we are only interested in a direct reference to
1887 -- a record component here. If the reference is through an
1888 -- access type, then the access object is being referenced,
1889 -- not the record, and still deserves an unset reference.
1891 if Nkind
(Parent
(N
)) = N_Selected_Component
1892 and not Is_Access_Type
(Typ
)
1895 ES
: constant Entity_Id
:=
1896 Entity
(Selector_Name
(Parent
(N
)));
1898 if Ekind
(ES
) = E_Discriminant
1900 (Present
(Declaration_Node
(ES
))
1902 Present
(Expression
(Declaration_Node
(ES
))))
1909 -- Exclude fully initialized types
1911 if Is_OK_Fully_Initialized
then
1915 -- Here we have a potential unset reference. But before we
1916 -- get worried about it, we have to make sure that the
1917 -- entity declaration is in the same procedure as the
1918 -- reference, since if they are in separate procedures, then
1919 -- we have no idea about sequential execution.
1921 -- The tests in the loop below catch all such cases, but do
1922 -- allow the reference to appear in a loop, block, or
1923 -- package spec that is nested within the declaring scope.
1924 -- As always, it is possible to construct cases where the
1925 -- warning is wrong, that is why it is a warning.
1927 Potential_Unset_Reference
: declare
1929 SE
: constant Entity_Id
:= Scope
(E
);
1931 function Within_Postcondition
return Boolean;
1932 -- Returns True if N is within a Postcondition, a
1933 -- Refined_Post, an Ensures component in a Test_Case,
1934 -- or a Contract_Cases.
1936 --------------------------
1937 -- Within_Postcondition --
1938 --------------------------
1940 function Within_Postcondition
return Boolean is
1945 while Present
(Nod
) loop
1946 if Nkind
(Nod
) = N_Pragma
1948 Pragma_Name_Unmapped
(Nod
)
1949 in Name_Postcondition
1951 | Name_Contract_Cases
1955 elsif Present
(Parent
(Nod
)) then
1958 if Nkind
(P
) = N_Pragma
1959 and then Pragma_Name
(P
) = Name_Test_Case
1960 and then Nod
= Test_Case_Arg
(P
, Name_Ensures
)
1965 -- Prevent the search from going too far
1967 elsif Is_Body_Or_Package_Declaration
(Nod
) then
1971 Nod
:= Parent
(Nod
);
1975 end Within_Postcondition
;
1977 -- Start of processing for Potential_Unset_Reference
1980 SR
:= Current_Scope
;
1982 if SR
= Standard_Standard
1983 or else Is_Subprogram
(SR
)
1984 or else Is_Concurrent_Body
(SR
)
1985 or else Is_Concurrent_Type
(SR
)
1993 -- Case of reference has an access type. This is a
1994 -- special case since access types are always set to null
1995 -- so cannot be truly uninitialized, but we still want to
1996 -- warn about cases of obvious null dereference.
1998 if Is_Access_Type
(Typ
) then
1999 Access_Type_Case
: declare
2003 (N
: Node_Id
) return Traverse_Result
;
2004 -- Process function for instantiation of Traverse
2005 -- below. Checks if N contains reference to E other
2006 -- than a dereference.
2008 function Ref_In
(Nod
: Node_Id
) return Boolean;
2009 -- Determines whether Nod contains a reference to
2010 -- the entity E that is not a dereference.
2017 (N
: Node_Id
) return Traverse_Result
2020 if Is_Entity_Name
(N
)
2021 and then Entity
(N
) = E
2022 and then not Is_Dereferenced
(N
)
2034 function Ref_In
(Nod
: Node_Id
) return Boolean is
2035 function Traverse
is new Traverse_Func
(Process
);
2037 return Traverse
(Nod
) = Abandon
;
2040 -- Start of processing for Access_Type_Case
2043 -- Don't bother if we are inside an instance, since
2044 -- the compilation of the generic template is where
2045 -- the warning should be issued.
2051 -- Don't bother if this is not the main unit. If we
2052 -- try to give this warning for with'ed units, we
2053 -- get some false positives, since we do not record
2054 -- references in other units.
2056 if not In_Extended_Main_Source_Unit
(E
)
2058 not In_Extended_Main_Source_Unit
(N
)
2063 -- We are only interested in dereferences
2065 if not Is_Dereferenced
(N
) then
2069 -- One more check, don't bother with references
2070 -- that are inside conditional statements or WHILE
2071 -- loops if the condition references the entity in
2072 -- question. This avoids most false positives.
2079 if Nkind
(P
) in N_If_Statement | N_Elsif_Part
2080 and then Ref_In
(Condition
(P
))
2084 elsif Nkind
(P
) = N_Loop_Statement
2085 and then Present
(Iteration_Scheme
(P
))
2087 Ref_In
(Condition
(Iteration_Scheme
(P
)))
2092 end Access_Type_Case
;
2095 -- One more check, don't bother if we are within a
2096 -- postcondition, since the expression occurs in a
2097 -- place unrelated to the actual test.
2099 if not Within_Postcondition
then
2101 -- Here we definitely have a case for giving a warning
2102 -- for a reference to an unset value. But we don't
2103 -- give the warning now. Instead set Unset_Reference
2104 -- in the identifier involved. The reason for this is
2105 -- that if we find the variable is never ever assigned
2106 -- a value then that warning is more important and
2107 -- there is no point in giving the reference warning.
2109 -- If this is an identifier, set the field directly
2111 if Nkind
(N
) = N_Identifier
then
2112 Set_Unset_Reference
(E
, N
);
2114 -- Otherwise it is an expanded name, so set the field
2115 -- of the actual identifier for the reference.
2118 Set_Unset_Reference
(E
, Selector_Name
(N
));
2121 end Potential_Unset_Reference
;
2125 -- Indexed component or slice
2127 when N_Indexed_Component
2130 -- If prefix does not involve dereferencing an access type, then
2131 -- we know we are OK if the component type is fully initialized,
2132 -- since the component will have been set as part of the default
2135 if not Prefix_Has_Dereference
(Prefix
(N
))
2136 and then Is_OK_Fully_Initialized
2140 -- Look at prefix in access type case, or if the component is not
2141 -- fully initialized.
2144 Check_Unset_Reference
(Prefix
(N
));
2149 when N_Selected_Component
=>
2151 Pref
: constant Node_Id
:= Prefix
(N
);
2152 Ent
: constant Entity_Id
:= Entity
(Selector_Name
(N
));
2155 -- If prefix involves dereferencing an access type, always
2156 -- check the prefix, since the issue then is whether this
2157 -- access value is null.
2159 if Prefix_Has_Dereference
(Pref
) then
2162 -- Always go to prefix if no selector entity is set. Can this
2163 -- happen in the normal case? Not clear, but it definitely can
2164 -- happen in error cases.
2169 -- For a record component, check some cases where we have
2170 -- reasonable cause to consider that the component is known to
2171 -- be or probably is initialized. In this case, we don't care
2172 -- if the prefix itself was explicitly initialized.
2174 -- Discriminants are always considered initialized
2176 elsif Ekind
(Ent
) = E_Discriminant
then
2179 -- An explicitly initialized component is certainly initialized
2181 elsif Nkind
(Parent
(Ent
)) = N_Component_Declaration
2182 and then Present
(Expression
(Parent
(Ent
)))
2186 -- A fully initialized component is initialized
2188 elsif Is_OK_Fully_Initialized
then
2192 -- If none of those cases apply, check the record type prefix
2194 Check_Unset_Reference
(Pref
);
2197 -- Type conversions can appear in assignment statements both
2198 -- as variable names and as expressions. We examine their own
2199 -- expressions only when processing their parent node.
2201 when N_Type_Conversion
=>
2202 Check_Unset_Reference
(Expression
(N
));
2204 -- For explicit dereference, always check prefix, which will generate
2205 -- an unset reference (since this is a case of dereferencing null).
2207 when N_Explicit_Dereference
=>
2208 Check_Unset_Reference
(Prefix
(N
));
2210 -- All other cases are not cases of an unset reference
2215 end Check_Unset_Reference
;
2217 ------------------------
2218 -- Check_Unused_Withs --
2219 ------------------------
2221 procedure Check_Unused_Withs
(Spec_Unit
: Unit_Number_Type
:= No_Unit
) is
2223 Munite
: constant Entity_Id
:= Cunit_Entity
(Main_Unit
);
2224 -- This is needed for checking the special renaming case
2226 procedure Check_One_Unit
(Unit
: Unit_Number_Type
);
2227 -- Subsidiary procedure, performs checks for specified unit
2229 --------------------
2230 -- Check_One_Unit --
2231 --------------------
2233 procedure Check_One_Unit
(Unit
: Unit_Number_Type
) is
2234 Cnode
: constant Node_Id
:= Cunit
(Unit
);
2236 Is_Visible_Renaming
: Boolean := False;
2238 procedure Check_Inner_Package
(Pack
: Entity_Id
);
2239 -- Pack is a package local to a unit in a with_clause. Both the unit
2240 -- and Pack are referenced. If none of the entities in Pack are
2241 -- referenced, then the only occurrence of Pack is in a USE clause
2242 -- or a pragma, and a warning is worthwhile as well.
2244 function Check_System_Aux
(Lunit
: Entity_Id
) return Boolean;
2245 -- Before giving a warning on a with_clause for System, check whether
2246 -- a system extension is present.
2248 function Find_Package_Renaming
2250 L
: Entity_Id
) return Entity_Id
;
2251 -- The only reference to a context unit may be in a renaming
2252 -- declaration. If this renaming declares a visible entity, do not
2253 -- warn that the context clause could be moved to the body, because
2254 -- the renaming may be intended to re-export the unit.
2256 function Has_Visible_Entities
(P
: Entity_Id
) return Boolean;
2257 -- This function determines if a package has any visible entities.
2258 -- True is returned if there is at least one declared visible entity,
2259 -- otherwise False is returned (e.g. case of only pragmas present).
2261 -------------------------
2262 -- Check_Inner_Package --
2263 -------------------------
2265 procedure Check_Inner_Package
(Pack
: Entity_Id
) is
2267 Un
: constant Node_Id
:= Sinfo
.Nodes
.Unit
(Cnode
);
2269 function Check_Use_Clause
(N
: Node_Id
) return Traverse_Result
;
2270 -- If N is a use_clause for Pack, emit warning
2272 procedure Check_Use_Clauses
is new
2273 Traverse_Proc
(Check_Use_Clause
);
2275 ----------------------
2276 -- Check_Use_Clause --
2277 ----------------------
2279 function Check_Use_Clause
(N
: Node_Id
) return Traverse_Result
is
2281 if Nkind
(N
) = N_Use_Package_Clause
2282 and then Entity
(Name
(N
)) = Pack
2284 -- Suppress message if any serious errors detected that turn
2285 -- off expansion, and thus result in false positives for
2288 if Serious_Errors_Detected
= 0 then
2289 Error_Msg_Qual_Level
:= 1;
2290 Error_Msg_NE
-- CODEFIX
2291 ("?u?no entities of package& are referenced!",
2293 Error_Msg_Qual_Level
:= 0;
2298 end Check_Use_Clause
;
2300 -- Start of processing for Check_Inner_Package
2303 E
:= First_Entity
(Pack
);
2304 while Present
(E
) loop
2305 if Referenced_Check_Spec
(E
) then
2312 -- No entities of the package are referenced. Check whether the
2313 -- reference to the package itself is a use clause, and if so
2314 -- place a warning on it.
2316 Check_Use_Clauses
(Un
);
2317 end Check_Inner_Package
;
2319 ----------------------
2320 -- Check_System_Aux --
2321 ----------------------
2323 function Check_System_Aux
(Lunit
: Entity_Id
) return Boolean is
2327 if Chars
(Lunit
) = Name_System
2328 and then Scope
(Lunit
) = Standard_Standard
2329 and then Present_System_Aux
2331 Ent
:= First_Entity
(System_Aux_Id
);
2332 while Present
(Ent
) loop
2333 if Referenced_Check_Spec
(Ent
) then
2342 end Check_System_Aux
;
2344 ---------------------------
2345 -- Find_Package_Renaming --
2346 ---------------------------
2348 function Find_Package_Renaming
2350 L
: Entity_Id
) return Entity_Id
2356 Is_Visible_Renaming
:= False;
2358 E1
:= First_Entity
(P
);
2359 while Present
(E1
) loop
2360 if Ekind
(E1
) = E_Package
and then Renamed_Entity
(E1
) = L
then
2361 Is_Visible_Renaming
:= not Is_Hidden
(E1
);
2364 elsif Ekind
(E1
) = E_Package
2365 and then No
(Renamed_Entity
(E1
))
2366 and then not Is_Generic_Instance
(E1
)
2368 R
:= Find_Package_Renaming
(E1
, L
);
2371 Is_Visible_Renaming
:= not Is_Hidden
(R
);
2380 end Find_Package_Renaming
;
2382 --------------------------
2383 -- Has_Visible_Entities --
2384 --------------------------
2386 function Has_Visible_Entities
(P
: Entity_Id
) return Boolean is
2390 -- If unit in context is not a package, it is a subprogram that
2391 -- is not called or a generic unit that is not instantiated
2392 -- in the current unit, and warning is appropriate.
2394 if Ekind
(P
) /= E_Package
then
2398 -- If unit comes from a limited_with clause, look for declaration
2399 -- of shadow entities.
2401 if Present
(Limited_View
(P
)) then
2402 E
:= First_Entity
(Limited_View
(P
));
2404 E
:= First_Entity
(P
);
2407 while Present
(E
) and then E
/= First_Private_Entity
(P
) loop
2408 if Comes_From_Source
(E
) or else Present
(Limited_View
(P
)) then
2416 end Has_Visible_Entities
;
2425 -- Start of processing for Check_One_Unit
2428 -- Only do check in units that are part of the extended main unit.
2429 -- This is actually a necessary restriction, because in the case of
2430 -- subprogram acting as its own specification, there can be with's in
2431 -- subunits that we will not see.
2433 if not In_Extended_Main_Source_Unit
(Cnode
) then
2437 -- Loop through context items in this unit
2439 Item
:= First
(Context_Items
(Cnode
));
2440 while Present
(Item
) loop
2441 if Nkind
(Item
) = N_With_Clause
2442 and then not Implicit_With
(Item
)
2443 and then In_Extended_Main_Source_Unit
(Item
)
2445 -- Guard for no entity present. Not clear under what conditions
2446 -- this happens, but it does occur, and since this is only a
2447 -- warning, we just suppress the warning in this case.
2449 and then Nkind
(Name
(Item
)) in N_Has_Entity
2450 and then Present
(Entity
(Name
(Item
)))
2452 Lunit
:= Entity
(Name
(Item
));
2454 -- Check if this unit is referenced (skip the check if this
2455 -- is explicitly marked by a pragma Unreferenced).
2457 if not Referenced
(Lunit
) and then not Has_Unreferenced
(Lunit
)
2459 -- Suppress warnings in internal units if not in -gnatg mode
2460 -- (these would be junk warnings for an application program,
2461 -- since they refer to problems in internal units).
2463 if GNAT_Mode
or else not Is_Internal_Unit
(Unit
) then
2464 -- Here we definitely have a non-referenced unit. If it
2465 -- is the special call for a spec unit, then just set the
2466 -- flag to be read later.
2468 if Unit
= Spec_Unit
then
2469 Set_Unreferenced_In_Spec
(Item
);
2471 -- Otherwise simple unreferenced message, but skip this
2472 -- if no visible entities, because that is most likely a
2473 -- case where warning would be false positive (e.g. a
2474 -- package with only a linker options pragma and nothing
2475 -- else or a pragma elaborate with a body library task).
2477 elsif Has_Visible_Entities
(Lunit
) then
2478 Error_Msg_N
-- CODEFIX
2479 ("?u?unit& is not referenced!", Name
(Item
));
2483 -- If main unit is a renaming of this unit, then we consider
2484 -- the with to be OK (obviously it is needed in this case).
2485 -- This may be transitive: the unit in the with_clause may
2486 -- itself be a renaming, in which case both it and the main
2487 -- unit rename the same ultimate package.
2489 elsif Present
(Renamed_Entity
(Munite
))
2491 (Renamed_Entity
(Munite
) = Lunit
2492 or else Renamed_Entity
(Munite
) = Renamed_Entity
(Lunit
))
2496 -- If this unit is referenced, and it is a package, we do
2497 -- another test, to see if any of the entities in the package
2498 -- are referenced. If none of the entities are referenced, we
2499 -- still post a warning. This occurs if the only use of the
2500 -- package is in a use clause, or in a package renaming
2501 -- declaration. This check is skipped for packages that are
2502 -- renamed in a spec, since the entities in such a package are
2503 -- visible to clients via the renaming.
2505 elsif Ekind
(Lunit
) = E_Package
2506 and then not Renamed_In_Spec
(Lunit
)
2508 -- If Is_Instantiated is set, it means that the package is
2509 -- implicitly instantiated (this is the case of parent
2510 -- instance or an actual for a generic package formal), and
2511 -- this counts as a reference.
2513 if Is_Instantiated
(Lunit
) then
2516 -- If no entities in package, and there is a pragma
2517 -- Elaborate_Body present, then assume that this with is
2518 -- done for purposes of this elaboration.
2520 elsif No
(First_Entity
(Lunit
))
2521 and then Has_Pragma_Elaborate_Body
(Lunit
)
2525 -- Otherwise see if any entities have been referenced
2528 if Limited_Present
(Item
) then
2529 Ent
:= First_Entity
(Limited_View
(Lunit
));
2531 Ent
:= First_Entity
(Lunit
);
2535 -- No more entities, and we did not find one that was
2536 -- referenced. Means we have a definite case of a with
2537 -- none of whose entities was referenced.
2541 -- If in spec, just set the flag
2543 if Unit
= Spec_Unit
then
2544 Set_No_Entities_Ref_In_Spec
(Item
);
2546 elsif Check_System_Aux
(Lunit
) then
2549 -- Else the warning may be needed
2552 -- Warn if we unreferenced flag set and we have
2553 -- not had serious errors. The reason we inhibit
2554 -- the message if there are errors is to prevent
2555 -- false positives from disabling expansion.
2557 if not Has_Unreferenced
(Lunit
)
2558 and then Serious_Errors_Detected
= 0
2560 -- Get possible package renaming
2562 Pack
:= Find_Package_Renaming
(Munite
, Lunit
);
2564 -- No warning if either the package or its
2565 -- renaming is used as a generic actual.
2567 if Used_As_Generic_Actual
(Lunit
)
2571 Used_As_Generic_Actual
(Pack
))
2576 -- Here we give the warning
2578 Error_Msg_N
-- CODEFIX
2579 ("?u?no entities of & are referenced!",
2582 -- Flag renaming of package as well. If
2583 -- the original package has warnings off,
2584 -- we suppress the warning on the renaming
2588 and then not Has_Warnings_Off
(Lunit
)
2589 and then not Has_Unreferenced
(Pack
)
2591 Error_Msg_NE
-- CODEFIX
2592 ("?u?no entities of& are referenced!",
2593 Unit_Declaration_Node
(Pack
), Pack
);
2600 -- Case of entity being referenced. The reference may
2601 -- come from a limited_with_clause, in which case the
2602 -- limited view of the entity carries the flag.
2604 elsif Referenced_Check_Spec
(Ent
)
2605 or else Referenced_As_LHS_Check_Spec
(Ent
)
2606 or else Referenced_As_Out_Parameter_Check_Spec
(Ent
)
2608 (From_Limited_With
(Ent
)
2609 and then Is_Incomplete_Type
(Ent
)
2610 and then Present
(Non_Limited_View
(Ent
))
2611 and then Referenced
(Non_Limited_View
(Ent
)))
2613 -- This means that the with is indeed fine, in that
2614 -- it is definitely needed somewhere, and we can
2615 -- quit worrying about this one...
2617 -- Except for one little detail: if either of the
2618 -- flags was set during spec processing, this is
2619 -- where we complain that the with could be moved
2620 -- from the spec. If the spec contains a visible
2621 -- renaming of the package, inhibit warning to move
2622 -- with_clause to body.
2624 if Ekind
(Munite
) = E_Package_Body
then
2626 Find_Package_Renaming
2627 (Spec_Entity
(Munite
), Lunit
);
2632 -- If a renaming is present in the spec do not warn
2633 -- because the body or child unit may depend on it.
2636 and then Renamed_Entity
(Pack
) = Lunit
2640 elsif Unreferenced_In_Spec
(Item
) then
2641 Error_Msg_N
-- CODEFIX
2642 ("?u?unit& is not referenced in spec!",
2645 elsif No_Entities_Ref_In_Spec
(Item
) then
2646 Error_Msg_N
-- CODEFIX
2647 ("?u?no entities of & are referenced in spec!",
2651 if Ekind
(Ent
) = E_Package
then
2652 Check_Inner_Package
(Ent
);
2658 if not Is_Visible_Renaming
then
2659 Error_Msg_N
-- CODEFIX
2660 ("\?u?with clause might be moved to body!",
2666 -- Move to next entity to continue search
2674 -- For a generic package, the only interesting kind of
2675 -- reference is an instantiation, since entities cannot be
2676 -- referenced directly.
2678 elsif Is_Generic_Unit
(Lunit
) then
2680 -- Unit was never instantiated, set flag for case of spec
2681 -- call, or give warning for normal call.
2683 if not Is_Instantiated
(Lunit
) then
2684 if Unit
= Spec_Unit
then
2685 Set_Unreferenced_In_Spec
(Item
);
2687 Error_Msg_N
-- CODEFIX
2688 ("?u?unit& is never instantiated!", Name
(Item
));
2691 -- If unit was indeed instantiated, make sure that flag is
2692 -- not set showing it was uninstantiated in the spec, and if
2693 -- so, give warning.
2695 elsif Unreferenced_In_Spec
(Item
) then
2697 ("?u?unit& is not instantiated in spec!", Name
(Item
));
2698 Error_Msg_N
-- CODEFIX
2699 ("\?u?with clause can be moved to body!", Name
(Item
));
2708 -- Start of processing for Check_Unused_Withs
2711 -- Immediate return if no semantics or warning flag not set
2713 if not Check_Withs
or else Operating_Mode
= Check_Syntax
then
2717 -- Flag any unused with clauses. For a subunit, check only the units
2718 -- in its context, not those of the parent, which may be needed by other
2719 -- subunits. We will get the full warnings when we compile the parent,
2720 -- but the following is helpful when compiling a subunit by itself.
2722 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Subunit
then
2723 if Current_Sem_Unit
= Main_Unit
then
2724 Check_One_Unit
(Main_Unit
);
2730 -- Process specified units
2732 if Spec_Unit
= No_Unit
then
2734 -- For main call, check all units
2736 for Unit
in Main_Unit
.. Last_Unit
loop
2737 Check_One_Unit
(Unit
);
2741 -- For call for spec, check only the spec
2743 Check_One_Unit
(Spec_Unit
);
2745 end Check_Unused_Withs
;
2747 ---------------------------------
2748 -- Generic_Package_Spec_Entity --
2749 ---------------------------------
2751 function Generic_Package_Spec_Entity
(E
: Entity_Id
) return Boolean is
2755 if Is_Package_Body_Entity
(E
) then
2761 if S
= Standard_Standard
then
2764 elsif Ekind
(S
) = E_Generic_Package
then
2767 elsif Ekind
(S
) = E_Package
then
2775 end Generic_Package_Spec_Entity
;
2777 ----------------------
2778 -- Goto_Spec_Entity --
2779 ----------------------
2781 function Goto_Spec_Entity
(E
: Entity_Id
) return Entity_Id
is
2783 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
2784 return Spec_Entity
(E
);
2788 end Goto_Spec_Entity
;
2794 function Has_Junk_Name
(E
: Entity_Id
) return Boolean is
2795 function Match
(S
: String) return Boolean;
2796 -- Return true if substring S is found in Name_Buffer (1 .. Name_Len)
2802 function Match
(S
: String) return Boolean is
2803 Slen1
: constant Integer := S
'Length - 1;
2806 for J
in 1 .. Name_Len
- S
'Length + 1 loop
2807 if Name_Buffer
(J
.. J
+ Slen1
) = S
then
2815 -- Start of processing for Has_Junk_Name
2818 Get_Unqualified_Decoded_Name_String
(Chars
(E
));
2821 Match
("discard") or else
2822 Match
("dummy") or else
2823 Match
("ignore") or else
2824 Match
("junk") or else
2825 Match
("unuse") or else
2826 Match
("tmp") or else
2830 --------------------------------------
2831 -- Has_Pragma_Unmodified_Check_Spec --
2832 --------------------------------------
2834 function Has_Pragma_Unmodified_Check_Spec
2835 (E
: Entity_Id
) return Boolean
2838 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
2840 -- Note: use of OR instead of OR ELSE here is deliberate, we want
2841 -- to mess with Unmodified flags on both body and spec entities.
2842 -- Has_Unmodified has side effects!
2844 return Has_Unmodified
(E
)
2846 Has_Unmodified
(Spec_Entity
(E
));
2849 return Has_Unmodified
(E
);
2851 end Has_Pragma_Unmodified_Check_Spec
;
2853 ----------------------------------------
2854 -- Has_Pragma_Unreferenced_Check_Spec --
2855 ----------------------------------------
2857 function Has_Pragma_Unreferenced_Check_Spec
2858 (E
: Entity_Id
) return Boolean
2861 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
2863 -- Note: use of OR here instead of OR ELSE is deliberate, we want
2864 -- to mess with flags on both entities.
2866 return Has_Unreferenced
(E
)
2868 Has_Unreferenced
(Spec_Entity
(E
));
2871 return Has_Unreferenced
(E
);
2873 end Has_Pragma_Unreferenced_Check_Spec
;
2879 procedure Initialize
is
2881 Warnings_Off_Pragmas
.Init
;
2882 Unreferenced_Entities
.Init
;
2883 In_Out_Warnings
.Init
;
2886 ---------------------------------------------
2887 -- Is_Attribute_And_Known_Value_Comparison --
2888 ---------------------------------------------
2890 function Is_Attribute_And_Known_Value_Comparison
2891 (Op
: Node_Id
) return Boolean
2893 Orig_Op
: constant Node_Id
:= Original_Node
(Op
);
2897 Nkind
(Orig_Op
) in N_Op_Compare
2898 and then Nkind
(Original_Node
(Left_Opnd
(Orig_Op
))) =
2899 N_Attribute_Reference
2900 and then Compile_Time_Known_Value
(Right_Opnd
(Orig_Op
));
2901 end Is_Attribute_And_Known_Value_Comparison
;
2903 ------------------------------------
2904 -- Never_Set_In_Source_Check_Spec --
2905 ------------------------------------
2907 function Never_Set_In_Source_Check_Spec
(E
: Entity_Id
) return Boolean is
2909 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
2910 return Never_Set_In_Source
(E
)
2912 Never_Set_In_Source
(Spec_Entity
(E
));
2914 return Never_Set_In_Source
(E
);
2916 end Never_Set_In_Source_Check_Spec
;
2918 -------------------------------------
2919 -- Operand_Has_Warnings_Suppressed --
2920 -------------------------------------
2922 function Operand_Has_Warnings_Suppressed
(N
: Node_Id
) return Boolean is
2924 function Check_For_Warnings
(N
: Node_Id
) return Traverse_Result
;
2925 -- Function used to check one node to see if it is or was originally
2926 -- a reference to an entity for which Warnings are off. If so, Abandon
2927 -- is returned, otherwise OK_Orig is returned to continue the traversal
2928 -- of the original expression.
2930 function Traverse
is new Traverse_Func
(Check_For_Warnings
);
2931 -- Function used to traverse tree looking for warnings
2933 ------------------------
2934 -- Check_For_Warnings --
2935 ------------------------
2937 function Check_For_Warnings
(N
: Node_Id
) return Traverse_Result
is
2938 R
: constant Node_Id
:= Original_Node
(N
);
2941 if Nkind
(R
) in N_Has_Entity
2942 and then Present
(Entity
(R
))
2943 and then Has_Warnings_Off
(Entity
(R
))
2949 end Check_For_Warnings
;
2951 -- Start of processing for Operand_Has_Warnings_Suppressed
2954 return Traverse
(N
) = Abandon
;
2955 end Operand_Has_Warnings_Suppressed
;
2957 -----------------------------------------
2958 -- Output_Non_Modified_In_Out_Warnings --
2959 -----------------------------------------
2961 procedure Output_Non_Modified_In_Out_Warnings
is
2963 function Warn_On_In_Out
(E
: Entity_Id
) return Boolean;
2964 -- Given a formal parameter entity E, determines if there is a reason to
2965 -- suppress IN OUT warnings (not modified, could be IN) for formals of
2966 -- the subprogram. We suppress these warnings if Warnings Off is set, or
2967 -- if we have seen the address of the subprogram being taken, or if the
2968 -- subprogram is used as a generic actual (in the latter cases the
2969 -- context may force use of IN OUT, even if the parameter is not
2970 -- modified for this particular case).
2972 --------------------
2973 -- Warn_On_In_Out --
2974 --------------------
2976 function Warn_On_In_Out
(E
: Entity_Id
) return Boolean is
2977 S
: constant Entity_Id
:= Scope
(E
);
2978 SE
: constant Entity_Id
:= Spec_Entity
(E
);
2981 -- Do not warn if address is taken, since funny business may be going
2982 -- on in treating the parameter indirectly as IN OUT.
2984 if Address_Taken
(S
)
2985 or else (Present
(SE
) and then Address_Taken
(Scope
(SE
)))
2989 -- Do not warn if used as a generic actual, since the generic may be
2990 -- what is forcing the use of an "unnecessary" IN OUT.
2992 elsif Used_As_Generic_Actual
(S
)
2993 or else (Present
(SE
) and then Used_As_Generic_Actual
(Scope
(SE
)))
2997 -- Else test warnings off on the subprogram
2999 elsif Warnings_Off
(S
) then
3002 -- All tests for suppressing warning failed
3009 -- Start of processing for Output_Non_Modified_In_Out_Warnings
3012 -- Loop through entities for which a warning may be needed
3014 for J
in In_Out_Warnings
.First
.. In_Out_Warnings
.Last
loop
3016 E1
: constant Entity_Id
:= In_Out_Warnings
.Table
(J
);
3019 -- Suppress warning in specific cases (see details in comments for
3020 -- No_Warn_On_In_Out).
3022 if Warn_On_In_Out
(E1
) then
3023 -- If -gnatwk is set then output message that it could be IN
3025 if not Is_Trivial_Subprogram
(Scope
(E1
)) then
3026 if Warn_On_Constant
then
3028 ("?k?formal parameter & is not modified!", E1
);
3030 ("\?k?mode could be IN instead of `IN OUT`!", E1
);
3032 -- We do not generate warnings for IN OUT parameters
3033 -- unless we have at least -gnatwu. This is deliberately
3034 -- inconsistent with the treatment of variables, but
3035 -- otherwise we get too many unexpected warnings in
3038 elsif Check_Unreferenced
then
3040 ("?u?formal parameter& is read but "
3041 & "never assigned!", E1
);
3045 -- Kill any other warnings on this entity, since this is the
3046 -- one that should dominate any other unreferenced warning.
3048 Set_Warnings_Off
(E1
);
3052 end Output_Non_Modified_In_Out_Warnings
;
3054 ----------------------------------------
3055 -- Output_Obsolescent_Entity_Warnings --
3056 ----------------------------------------
3058 procedure Output_Obsolescent_Entity_Warnings
(N
: Node_Id
; E
: Entity_Id
) is
3059 P
: constant Node_Id
:= Parent
(N
);
3065 -- Do not output message if we are the scope of standard. This means
3066 -- we have a reference from a context clause from when it is originally
3067 -- processed, and that's too early to tell whether it is an obsolescent
3068 -- unit doing the with'ing. In Sem_Ch10.Analyze_Compilation_Unit we make
3069 -- sure that we have a later call when the scope is available. This test
3070 -- also eliminates all messages for use clauses, which is fine (we do
3071 -- not want messages for use clauses, since they are always redundant
3072 -- with respect to the associated with clause).
3074 if S
= Standard_Standard
then
3078 -- Do not output message if we are in scope of an obsolescent package
3082 if Is_Obsolescent
(S
) then
3087 exit when S
= Standard_Standard
;
3090 -- Here we will output the message
3092 Error_Msg_Sloc
:= Sloc
(E
);
3094 -- Case of with clause
3096 if Nkind
(P
) = N_With_Clause
then
3097 if Ekind
(E
) = E_Package
then
3099 ("?j?with of obsolescent package& declared#", N
, E
);
3100 elsif Ekind
(E
) = E_Procedure
then
3102 ("?j?with of obsolescent procedure& declared#", N
, E
);
3105 ("?j?with of obsolescent function& declared#", N
, E
);
3108 -- If we do not have a with clause, then ignore any reference to an
3109 -- obsolescent package name. We only want to give the one warning of
3110 -- withing the package, not one each time it is used to qualify.
3112 elsif Ekind
(E
) = E_Package
then
3115 -- Procedure call statement
3117 elsif Nkind
(P
) = N_Procedure_Call_Statement
then
3119 ("??call to obsolescent procedure& declared#", N
, E
);
3123 elsif Nkind
(P
) = N_Function_Call
then
3125 ("??call to obsolescent function& declared#", N
, E
);
3127 -- Reference to obsolescent type
3129 elsif Is_Type
(E
) then
3131 ("??reference to obsolescent type& declared#", N
, E
);
3133 -- Reference to obsolescent component
3135 elsif Ekind
(E
) in E_Component | E_Discriminant
then
3137 ("??reference to obsolescent component& declared#", N
, E
);
3139 -- Reference to obsolescent variable
3141 elsif Ekind
(E
) = E_Variable
then
3143 ("??reference to obsolescent variable& declared#", N
, E
);
3145 -- Reference to obsolescent constant
3147 elsif Ekind
(E
) = E_Constant
or else Ekind
(E
) in Named_Kind
then
3149 ("??reference to obsolescent constant& declared#", N
, E
);
3151 -- Reference to obsolescent enumeration literal
3153 elsif Ekind
(E
) = E_Enumeration_Literal
then
3155 ("??reference to obsolescent enumeration literal& declared#", N
, E
);
3157 -- Generic message for any other case we missed
3161 ("??reference to obsolescent entity& declared#", N
, E
);
3164 -- Output additional warning if present
3166 for J
in Obsolescent_Warnings
.First
.. Obsolescent_Warnings
.Last
loop
3167 if Obsolescent_Warnings
.Table
(J
).Ent
= E
then
3168 String_To_Name_Buffer
(Obsolescent_Warnings
.Table
(J
).Msg
);
3169 Error_Msg_Strlen
:= Name_Len
;
3170 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
3171 Error_Msg_N
("\\??~", N
);
3175 end Output_Obsolescent_Entity_Warnings
;
3177 ----------------------------------
3178 -- Output_Unreferenced_Messages --
3179 ----------------------------------
3181 procedure Output_Unreferenced_Messages
is
3183 for J
in Unreferenced_Entities
.First
.. Unreferenced_Entities
.Last
loop
3184 Warn_On_Unreferenced_Entity
(Unreferenced_Entities
.Table
(J
));
3186 end Output_Unreferenced_Messages
;
3188 -----------------------------------------
3189 -- Output_Unused_Warnings_Off_Warnings --
3190 -----------------------------------------
3192 procedure Output_Unused_Warnings_Off_Warnings
is
3194 for J
in Warnings_Off_Pragmas
.First
.. Warnings_Off_Pragmas
.Last
loop
3196 Wentry
: Warnings_Off_Entry
renames Warnings_Off_Pragmas
.Table
(J
);
3197 N
: Node_Id
renames Wentry
.N
;
3198 E
: Node_Id
renames Wentry
.E
;
3201 -- Turn off Warnings_Off, or we won't get the warning
3203 Set_Warnings_Off
(E
, False);
3205 -- Nothing to do if pragma was used to suppress a general warning
3207 if Warnings_Off_Used
(E
) then
3210 -- If pragma was used both in unmodified and unreferenced contexts
3211 -- then that's as good as the general case, no warning.
3213 elsif Warnings_Off_Used_Unmodified
(E
)
3215 Warnings_Off_Used_Unreferenced
(E
)
3219 -- Used only in context where Unmodified would have worked
3221 elsif Warnings_Off_Used_Unmodified
(E
) then
3223 ("?.w?could use Unmodified instead of "
3224 & "Warnings Off for &", Pragma_Identifier
(N
), E
);
3226 -- Used only in context where Unreferenced would have worked
3228 elsif Warnings_Off_Used_Unreferenced
(E
) then
3230 ("?.w?could use Unreferenced instead of "
3231 & "Warnings Off for &", Pragma_Identifier
(N
), E
);
3237 ("?.w?pragma Warnings Off for & unused, "
3238 & "could be omitted", N
, E
);
3242 end Output_Unused_Warnings_Off_Warnings
;
3244 ---------------------------
3245 -- Referenced_Check_Spec --
3246 ---------------------------
3248 function Referenced_Check_Spec
(E
: Entity_Id
) return Boolean is
3250 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
3251 return Referenced
(E
) or else Referenced
(Spec_Entity
(E
));
3253 return Referenced
(E
);
3255 end Referenced_Check_Spec
;
3257 ----------------------------------
3258 -- Referenced_As_LHS_Check_Spec --
3259 ----------------------------------
3261 function Referenced_As_LHS_Check_Spec
(E
: Entity_Id
) return Boolean is
3263 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
3264 return Referenced_As_LHS
(E
)
3265 or else Referenced_As_LHS
(Spec_Entity
(E
));
3267 return Referenced_As_LHS
(E
);
3269 end Referenced_As_LHS_Check_Spec
;
3271 --------------------------------------------
3272 -- Referenced_As_Out_Parameter_Check_Spec --
3273 --------------------------------------------
3275 function Referenced_As_Out_Parameter_Check_Spec
3276 (E
: Entity_Id
) return Boolean
3279 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
3280 return Referenced_As_Out_Parameter
(E
)
3281 or else Referenced_As_Out_Parameter
(Spec_Entity
(E
));
3283 return Referenced_As_Out_Parameter
(E
);
3285 end Referenced_As_Out_Parameter_Check_Spec
;
3287 --------------------------------------
3288 -- Warn_On_Constant_Valid_Condition --
3289 --------------------------------------
3291 procedure Warn_On_Constant_Valid_Condition
(Op
: Node_Id
) is
3292 Left
: constant Node_Id
:= Left_Opnd
(Op
);
3293 Right
: constant Node_Id
:= Right_Opnd
(Op
);
3295 function Comes_From_Simple_Condition_In_Source
3296 (Op
: Node_Id
) return Boolean;
3297 -- Return True if Op comes from a simple condition present in the source
3299 -------------------------------------------
3300 -- Comes_From_Simple_Condition_In_Source --
3301 -------------------------------------------
3303 function Comes_From_Simple_Condition_In_Source
3304 (Op
: Node_Id
) return Boolean
3306 Orig_Op
: constant Node_Id
:= Original_Node
(Op
);
3309 if not Comes_From_Source
(Orig_Op
) then
3313 -- We do not want to give warnings on a membership test with a mark
3314 -- for a subtype that is predicated, see also Exp_Ch4.Expand_N_In.
3316 if Nkind
(Orig_Op
) = N_In
then
3318 Orig_Rop
: constant Node_Id
:=
3319 Original_Node
(Right_Opnd
(Orig_Op
));
3321 if Is_Entity_Name
(Orig_Rop
)
3322 and then Is_Type
(Entity
(Orig_Rop
))
3323 and then Present
(Predicate_Function
(Entity
(Orig_Rop
)))
3331 end Comes_From_Simple_Condition_In_Source
;
3333 True_Result
: Boolean;
3334 False_Result
: Boolean;
3337 -- Determine the potential outcome of the comparison assuming that the
3338 -- scalar operands are valid.
3340 if Constant_Condition_Warnings
3341 and then Comes_From_Simple_Condition_In_Source
(Op
)
3342 and then Is_Scalar_Type
(Etype
(Left
))
3343 and then Is_Scalar_Type
(Etype
(Right
))
3345 -- Do not consider instances because the check was already performed
3348 and then not In_Instance
3350 -- Do not consider comparisons between two static expressions such as
3351 -- constants or literals because those values cannot be invalidated.
3353 and then not (Is_Static_Expression
(Left
)
3354 and then Is_Static_Expression
(Right
))
3356 -- Do not consider comparison between an attribute reference and a
3357 -- compile-time known value since this is most likely a conditional
3360 and then not Is_Attribute_And_Known_Value_Comparison
(Op
)
3362 -- Do not consider internal files to allow for various assertions and
3363 -- safeguards within our runtime.
3365 and then not In_Internal_Unit
(Op
)
3369 Assume_Valid
=> True,
3370 True_Result
=> True_Result
,
3371 False_Result
=> False_Result
);
3373 -- Warn on a possible evaluation to False / True in the presence of
3374 -- invalid values. But issue no warning for an assertion expression
3375 -- (or a subexpression thereof); in particular, we don't want a
3376 -- warning about an assertion that will always succeed.
3378 if In_Assertion_Expression_Pragma
(Op
) then
3381 elsif True_Result
then
3383 ("condition can only be False if invalid values present?c?", Op
);
3385 elsif False_Result
then
3387 ("condition can only be True if invalid values present?c?", Op
);
3390 end Warn_On_Constant_Valid_Condition
;
3392 -----------------------------
3393 -- Warn_On_Known_Condition --
3394 -----------------------------
3396 procedure Warn_On_Known_Condition
(C
: Node_Id
) is
3397 Test_Result
: Boolean := False;
3398 -- Force initialization to facilitate static analysis
3400 function Is_Known_Branch
return Boolean;
3401 -- If the type of the condition is Boolean, the constant value of the
3402 -- condition is a boolean literal. If the type is a derived boolean
3403 -- type, the constant is wrapped in a type conversion of the derived
3404 -- literal. If the value of the condition is not a literal, no warnings
3405 -- can be produced. This function returns True if the result can be
3406 -- determined, and Test_Result is set True/False accordingly. Otherwise
3407 -- False is returned, and Test_Result is unchanged.
3409 procedure Track
(N
: Node_Id
);
3410 -- Adds continuation warning(s) pointing to reason (assignment or test)
3411 -- for the operand of the conditional having a known value (or at least
3412 -- enough is known about the value to issue the warning).
3414 ---------------------
3415 -- Is_Known_Branch --
3416 ---------------------
3418 function Is_Known_Branch
return Boolean is
3420 if Etype
(C
) = Standard_Boolean
3421 and then Is_Entity_Name
(C
)
3423 (Entity
(C
) = Standard_False
or else Entity
(C
) = Standard_True
)
3425 Test_Result
:= Entity
(C
) = Standard_True
;
3428 elsif Is_Boolean_Type
(Etype
(C
))
3429 and then Nkind
(C
) = N_Unchecked_Type_Conversion
3430 and then Is_Entity_Name
(Expression
(C
))
3431 and then Ekind
(Entity
(Expression
(C
))) = E_Enumeration_Literal
3434 Chars
(Entity
(Expression
(C
))) = Chars
(Standard_True
);
3440 end Is_Known_Branch
;
3446 procedure Track
(N
: Node_Id
) is
3448 procedure Rec
(Sub_N
: Node_Id
);
3449 -- Recursive helper to do the work of Track, so we can refer to N's
3450 -- Sloc in error messages. Sub_N is initially N, and a proper subnode
3451 -- when recursively walking comparison operations.
3453 procedure Rec
(Sub_N
: Node_Id
) is
3454 Orig
: constant Node_Id
:= Original_Node
(Sub_N
);
3456 if Nkind
(Orig
) in N_Op_Compare
then
3457 Rec
(Left_Opnd
(Orig
));
3458 Rec
(Right_Opnd
(Orig
));
3460 elsif Is_Entity_Name
(Orig
) and then Is_Object
(Entity
(Orig
)) then
3462 CV
: constant Node_Id
:= Current_Value
(Entity
(Orig
));
3464 if Present
(CV
) then
3465 Error_Msg_Sloc
:= Sloc
(CV
);
3467 if Nkind
(CV
) not in N_Subexpr
then
3468 Error_Msg_N
("\\??(see test #)", N
);
3470 elsif Nkind
(Parent
(CV
)) =
3471 N_Case_Statement_Alternative
3473 Error_Msg_N
("\\??(see case alternative #)", N
);
3476 Error_Msg_N
("\\??(see assignment #)", N
);
3489 Orig
: constant Node_Id
:= Original_Node
(C
);
3492 -- Start of processing for Warn_On_Known_Condition
3495 -- Adjust SCO condition if from source
3498 and then Comes_From_Source
(Orig
)
3499 and then Is_Known_Branch
3502 Atrue
: Boolean := Test_Result
;
3504 if Present
(Parent
(C
)) and then Nkind
(Parent
(C
)) = N_Op_Not
then
3508 Set_SCO_Condition
(Orig
, Atrue
);
3512 -- Argument replacement in an inlined body can make conditions static.
3513 -- Do not emit warnings in this case.
3515 if In_Inlined_Body
then
3519 if Constant_Condition_Warnings
3520 and then Is_Known_Branch
3521 and then Comes_From_Source
(Orig
)
3522 and then Nkind
(Orig
) in N_Has_Entity
3523 and then not In_Instance
3525 -- Don't warn if comparison of result of attribute against a constant
3526 -- value, since this is likely legitimate conditional compilation.
3528 if Is_Attribute_And_Known_Value_Comparison
(C
) then
3532 -- See if this is in a statement or a declaration
3536 -- If tree is not attached, do not issue warning (this is very
3537 -- peculiar, and probably arises from some other error condition).
3542 -- If we are in a declaration, then no warning, since in practice
3543 -- conditionals in declarations are used for intended tests which
3544 -- may be known at compile time, e.g. things like
3546 -- x : constant Integer := 2 + (Word'Size = 32);
3548 -- And a warning is annoying in such cases
3550 elsif Nkind
(P
) in N_Declaration
3552 Nkind
(P
) in N_Later_Decl_Item
3556 -- Don't warn in assert or check pragma, since presumably tests in
3557 -- such a context are very definitely intended, and might well be
3558 -- known at compile time. Note that we have to test the original
3559 -- node, since assert pragmas get rewritten at analysis time.
3561 elsif Nkind
(Original_Node
(P
)) = N_Pragma
3563 Pragma_Name_Unmapped
(Original_Node
(P
))
3564 in Name_Assert | Name_Check
3569 exit when Is_Statement
(P
);
3573 -- Here we issue the warning unless some sub-operand has warnings
3574 -- set off, in which case we suppress the warning for the node. If
3575 -- the original expression is an inequality, it has been expanded
3576 -- into a negation, and the value of the original expression is the
3577 -- negation of the equality. If the expression is an entity that
3578 -- appears within a negation, it is clearer to flag the negation
3579 -- itself, and report on its constant value.
3581 if not Operand_Has_Warnings_Suppressed
(C
) then
3583 True_Branch
: Boolean := Test_Result
;
3584 Cond
: Node_Id
:= C
;
3586 if Present
(Parent
(C
))
3587 and then Nkind
(Parent
(C
)) = N_Op_Not
3589 True_Branch
:= not True_Branch
;
3593 -- Suppress warning if this is True/False of a derived boolean
3594 -- type with Nonzero_Is_True, which gets rewritten as Boolean
3597 if Is_Entity_Name
(Original_Node
(C
))
3598 and then Ekind
(Entity
(Original_Node
(C
)))
3599 = E_Enumeration_Literal
3600 and then Nonzero_Is_True
(Etype
(Original_Node
(C
)))
3604 -- Give warning for nontrivial always True/False case
3608 Error_Msg_N
("condition is always True?c?", Cond
);
3610 Error_Msg_N
("condition is always False?c?", Cond
);
3618 end Warn_On_Known_Condition
;
3620 ---------------------------------------
3621 -- Warn_On_Modified_As_Out_Parameter --
3622 ---------------------------------------
3624 function Warn_On_Modified_As_Out_Parameter
(E
: Entity_Id
) return Boolean is
3627 (Warn_On_Modified_Unread
and then Is_Only_Out_Parameter
(E
))
3628 or else Warn_On_All_Unread_Out_Parameters
;
3629 end Warn_On_Modified_As_Out_Parameter
;
3631 ---------------------------------
3632 -- Warn_On_Overlapping_Actuals --
3633 ---------------------------------
3635 procedure Warn_On_Overlapping_Actuals
(Subp
: Entity_Id
; N
: Node_Id
) is
3636 function Explicitly_By_Reference
(Formal_Id
: Entity_Id
) return Boolean;
3637 -- Returns True iff the type of Formal_Id is explicitly by-reference
3639 function Refer_Same_Object
3641 Act2
: Node_Id
) return Boolean;
3642 -- Two names are known to refer to the same object if the two names
3643 -- are known to denote the same object; or one of the names is a
3644 -- selected_component, indexed_component, or slice and its prefix is
3645 -- known to refer to the same object as the other name; or one of the
3646 -- two names statically denotes a renaming declaration whose renamed
3647 -- object_name is known to refer to the same object as the other name
3648 -- (RM 6.4.1(6.11/3))
3650 -----------------------------
3651 -- Explicitly_By_Reference --
3652 -----------------------------
3654 function Explicitly_By_Reference
3655 (Formal_Id
: Entity_Id
)
3658 Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Formal_Id
));
3660 if Present
(Typ
) then
3661 return Is_By_Reference_Type
(Typ
)
3662 or else Convention
(Typ
) = Convention_Ada_Pass_By_Reference
;
3666 end Explicitly_By_Reference
;
3668 -----------------------
3669 -- Refer_Same_Object --
3670 -----------------------
3672 function Refer_Same_Object
3674 Act2
: Node_Id
) return Boolean
3678 Denotes_Same_Object
(Act1
, Act2
)
3679 or else Denotes_Same_Prefix
(Act1
, Act2
);
3680 end Refer_Same_Object
;
3689 -- Start of processing for Warn_On_Overlapping_Actuals
3692 -- Exclude calls rewritten as enumeration literals
3694 if Nkind
(N
) not in N_Subprogram_Call | N_Entry_Call_Statement
then
3697 -- Guard against previous errors
3699 elsif Error_Posted
(N
) then
3703 -- If a call C has two or more parameters of mode in out or out that are
3704 -- of an elementary type, then the call is legal only if for each name
3705 -- N that is passed as a parameter of mode in out or out to the call C,
3706 -- there is no other name among the other parameters of mode in out or
3707 -- out to C that is known to denote the same object (RM 6.4.1(6.15/3))
3708 -- This has been clarified in AI12-0216 to indicate that the illegality
3709 -- only occurs if both formals are of an elementary type, because of the
3710 -- nondeterminism on the write-back of the corresponding actuals.
3711 -- Earlier versions of the language made it illegal if only one of the
3712 -- actuals was an elementary parameter that overlapped a composite
3713 -- actual, and both were writable.
3715 -- If appropriate warning switch is set, we also report warnings on
3716 -- overlapping parameters that are composite types. Users find these
3717 -- warnings useful, and they are used in style guides.
3719 -- It is also worthwhile to warn on overlaps of composite objects when
3720 -- only one of the formals is (in)-out. Note that the RM rule above is
3721 -- a legality rule. We choose to implement this check as a warning to
3722 -- avoid major incompatibilities with legacy code.
3724 -- Note also that the rule in 6.4.1 (6.17/3), introduced by AI12-0324,
3725 -- is potentially more expensive to verify, and is not yet implemented.
3727 Form1
:= First_Formal
(Subp
);
3728 Act1
:= First_Actual
(N
);
3729 while Present
(Form1
) and then Present
(Act1
) loop
3731 Form2
:= Next_Formal
(Form1
);
3732 Act2
:= Next_Actual
(Act1
);
3733 while Present
(Form2
) and then Present
(Act2
) loop
3735 -- Ignore formals of generic types; they will be examined when
3738 if Is_Generic_Type
(Etype
(Form1
))
3739 or else Is_Generic_Type
(Etype
(Form2
))
3743 elsif Refer_Same_Object
(Act1
, Act2
) then
3745 -- Case 1: two writable elementary parameters that overlap
3747 if (Is_Elementary_Type
(Etype
(Form1
))
3748 and then Is_Elementary_Type
(Etype
(Form2
))
3749 and then Ekind
(Form1
) /= E_In_Parameter
3750 and then Ekind
(Form2
) /= E_In_Parameter
)
3752 -- Case 2: two composite parameters that overlap, one of
3753 -- which is writable.
3755 or else (Is_Composite_Type
(Etype
(Form1
))
3756 and then Is_Composite_Type
(Etype
(Form2
))
3757 and then (Ekind
(Form1
) /= E_In_Parameter
3758 or else Ekind
(Form2
) /= E_In_Parameter
))
3760 -- Case 3: an elementary writable parameter that overlaps
3763 or else (Is_Elementary_Type
(Etype
(Form1
))
3764 and then Ekind
(Form1
) /= E_In_Parameter
3765 and then Is_Composite_Type
(Etype
(Form2
)))
3767 or else (Is_Elementary_Type
(Etype
(Form2
))
3768 and then Ekind
(Form2
) /= E_In_Parameter
3769 and then Is_Composite_Type
(Etype
(Form1
)))
3772 -- Guard against previous errors
3774 if No
(Etype
(Act1
))
3775 or else No
(Etype
(Act2
))
3779 -- If type is explicitly by-reference, then it is not
3780 -- covered by the legality rule, which only applies to
3781 -- elementary types. Actually, the aliasing is most
3782 -- likely intended, so don't emit a warning either.
3784 elsif Explicitly_By_Reference
(Form1
)
3785 or else Explicitly_By_Reference
(Form2
)
3789 -- We only report warnings on overlapping arrays and record
3790 -- types if switch is set.
3792 elsif not Warn_On_Overlap
3793 and then not (Is_Elementary_Type
(Etype
(Form1
))
3795 Is_Elementary_Type
(Etype
(Form2
)))
3799 -- Here we may need to issue overlap message
3804 -- Overlap checking is an error only in Ada 2012. For
3805 -- earlier versions of Ada, this is a warning.
3807 Ada_Version
< Ada_2012
3809 -- Overlap is only illegal since Ada 2012 and only for
3810 -- elementary types (passed by copy). For other types
3811 -- we always have a warning in all versions. This is
3812 -- clarified by AI12-0216.
3815 (Is_Elementary_Type
(Etype
(Form1
))
3816 and then Is_Elementary_Type
(Etype
(Form2
)))
3818 -- debug flag -gnatd.E changes the error to a warning
3819 -- even in Ada 2012 mode.
3821 or else Error_To_Warning
;
3823 -- For greater clarity, give name of formal
3825 Error_Msg_Node_2
:= Form2
;
3827 -- This is one of the messages
3830 ("<.i<writable actual for & overlaps with actual for &",
3836 Next_Formal
(Form2
);
3840 Next_Formal
(Form1
);
3843 end Warn_On_Overlapping_Actuals
;
3845 ------------------------------
3846 -- Warn_On_Suspicious_Index --
3847 ------------------------------
3849 procedure Warn_On_Suspicious_Index
(Name
: Entity_Id
; X
: Node_Id
) is
3852 -- Set to lower bound for a suspicious type
3855 -- Entity for array reference
3860 function Is_Suspicious_Type
(Typ
: Entity_Id
) return Boolean;
3861 -- Tests to see if Typ is a type for which we may have a suspicious
3862 -- index, namely an unconstrained array type, whose lower bound is
3863 -- either zero or one. If so, True is returned, and Low_Bound is set
3864 -- to this lower bound. If not, False is returned, and Low_Bound is
3865 -- undefined on return.
3867 -- For now, we limit this to standard string types, so any other
3868 -- unconstrained types return False. We may change our minds on this
3869 -- later on, but strings seem the most important case.
3871 procedure Test_Suspicious_Index
;
3872 -- Test if index is of suspicious type and if so, generate warning
3874 ------------------------
3875 -- Is_Suspicious_Type --
3876 ------------------------
3878 function Is_Suspicious_Type
(Typ
: Entity_Id
) return Boolean is
3882 if Is_Array_Type
(Typ
)
3883 and then not Is_Constrained
(Typ
)
3884 and then Number_Dimensions
(Typ
) = 1
3885 and then Is_Standard_String_Type
(Typ
)
3886 and then not Has_Warnings_Off
(Typ
)
3888 LB
:= Type_Low_Bound
(Etype
(First_Index
(Typ
)));
3890 if Compile_Time_Known_Value
(LB
) then
3891 Low_Bound
:= Expr_Value
(LB
);
3892 return Low_Bound
= Uint_0
or else Low_Bound
= Uint_1
;
3897 end Is_Suspicious_Type
;
3899 ---------------------------
3900 -- Test_Suspicious_Index --
3901 ---------------------------
3903 procedure Test_Suspicious_Index
is
3905 function Length_Reference
(N
: Node_Id
) return Boolean;
3906 -- Check if node N is of the form Name'Length
3909 -- Generate first warning line
3911 procedure Warn_On_Index_Below_Lower_Bound
;
3912 -- Generate a warning on indexing the array with a literal value
3913 -- below the lower bound of the index type.
3915 procedure Warn_On_Literal_Index
;
3916 -- Generate a warning on indexing the array with a literal value
3918 ----------------------
3919 -- Length_Reference --
3920 ----------------------
3922 function Length_Reference
(N
: Node_Id
) return Boolean is
3923 R
: constant Node_Id
:= Original_Node
(N
);
3926 Nkind
(R
) = N_Attribute_Reference
3927 and then Attribute_Name
(R
) = Name_Length
3928 and then Is_Entity_Name
(Prefix
(R
))
3929 and then Entity
(Prefix
(R
)) = Ent
;
3930 end Length_Reference
;
3938 Error_Msg_Uint_1
:= Low_Bound
;
3939 Error_Msg_FE
-- CODEFIX
3940 ("?w?index for& may assume lower bound of^", X
, Ent
);
3943 -------------------------------------
3944 -- Warn_On_Index_Below_Lower_Bound --
3945 -------------------------------------
3947 procedure Warn_On_Index_Below_Lower_Bound
is
3949 if Is_Standard_String_Type
(Typ
) then
3951 (Compile_Time_Constraint_Error
3953 Msg
=> "?w?string index should be positive"));
3956 (Compile_Time_Constraint_Error
3958 Msg
=> "?w?index out of the allowed range"));
3960 end Warn_On_Index_Below_Lower_Bound
;
3962 ---------------------------
3963 -- Warn_On_Literal_Index --
3964 ---------------------------
3966 procedure Warn_On_Literal_Index
is
3970 -- Case where original form of subscript is an integer literal
3972 if Nkind
(Original_Node
(X
)) = N_Integer_Literal
then
3973 if Intval
(X
) = Low_Bound
then
3974 Error_Msg_FE
-- CODEFIX
3975 ("\?w?suggested replacement: `&''First`", X
, Ent
);
3977 Error_Msg_Uint_1
:= Intval
(X
) - Low_Bound
;
3978 Error_Msg_FE
-- CODEFIX
3979 ("\?w?suggested replacement: `&''First + ^`", X
, Ent
);
3983 -- Case where original form of subscript is more complex
3986 -- Build string X'First - 1 + expression where the expression
3987 -- is the original subscript. If the expression starts with "1
3988 -- + ", then the "- 1 + 1" is elided.
3990 Error_Msg_String
(1 .. 13) := "'First - 1 + ";
3991 Error_Msg_Strlen
:= 13;
3994 Sref
: Source_Ptr
:= Sloc
(First_Node
(Original_Node
(X
)));
3995 Tref
: constant Source_Buffer_Ptr
:=
3996 Source_Text
(Get_Source_File_Index
(Sref
));
3997 -- Tref (Sref) is used to scan the subscript
4000 -- Parentheses counter when scanning subscript
4003 -- Tref (Sref) points to start of subscript
4005 -- Elide - 1 if subscript starts with 1 +
4007 if Tref
(Sref
.. Sref
+ 2) = "1 +" then
4008 Error_Msg_Strlen
:= Error_Msg_Strlen
- 6;
4011 elsif Tref
(Sref
.. Sref
+ 1) = "1+" then
4012 Error_Msg_Strlen
:= Error_Msg_Strlen
- 6;
4016 -- Now we will copy the subscript to the string buffer
4020 -- Count parens, exit if terminating right paren. Note
4021 -- check to ignore paren appearing as character literal.
4023 if Tref
(Sref
+ 1) = '''
4025 Tref
(Sref
- 1) = '''
4029 if Tref
(Sref
) = '(' then
4031 elsif Tref
(Sref
) = ')' then
4037 -- Done if terminating double dot (slice case)
4040 and then (Tref
(Sref
.. Sref
+ 1) = ".."
4042 Tref
(Sref
.. Sref
+ 2) = " ..");
4044 -- Quit if we have hit EOF character, something wrong
4046 if Tref
(Sref
) = EOF
then
4050 -- String literals are too much of a pain to handle
4052 if Tref
(Sref
) = '"' or else Tref
(Sref
) = '%' then
4056 -- If we have a 'Range reference, then this is a case
4057 -- where we cannot easily give a replacement. Don't try.
4059 if Tref
(Sref
.. Sref
+ 4) = "range"
4060 and then Tref
(Sref
- 1) < 'A'
4061 and then Tref
(Sref
+ 5) < 'A'
4066 -- Else store next character
4068 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
4069 Error_Msg_String
(Error_Msg_Strlen
) := Tref
(Sref
);
4072 -- If we get more than 40 characters then the expression
4073 -- is too long to copy, or something has gone wrong. In
4074 -- either case, just skip the attempt at a suggested fix.
4076 if Error_Msg_Strlen
> 40 then
4082 -- Replacement subscript is now in string buffer
4084 Error_Msg_FE
-- CODEFIX
4085 ("\?w?suggested replacement: `&~`", Original_Node
(X
), Ent
);
4087 end Warn_On_Literal_Index
;
4089 -- Start of processing for Test_Suspicious_Index
4092 -- Nothing to do if subscript does not come from source (we don't
4093 -- want to give garbage warnings on compiler expanded code, e.g. the
4094 -- loops generated for slice assignments. Such junk warnings would
4095 -- be placed on source constructs with no subscript in sight).
4097 if not Comes_From_Source
(Original_Node
(X
)) then
4101 -- Case where subscript is a constant integer
4103 if Nkind
(X
) = N_Integer_Literal
then
4105 -- Case where subscript is lower than the lowest possible bound.
4106 -- This might be the case for example when programmers try to
4107 -- access a string at index 0, as they are used to in other
4108 -- programming languages like C.
4110 if Intval
(X
) < Low_Bound
then
4111 Warn_On_Index_Below_Lower_Bound
;
4113 Warn_On_Literal_Index
;
4116 -- Case where subscript is of the form X'Length
4118 elsif Length_Reference
(X
) then
4120 Error_Msg_Node_2
:= Ent
;
4122 ("\?w?suggest replacement of `&''Length` by `&''Last`",
4125 -- Case where subscript is of the form X'Length - expression
4127 elsif Nkind
(X
) = N_Op_Subtract
4128 and then Length_Reference
(Left_Opnd
(X
))
4131 Error_Msg_Node_2
:= Ent
;
4133 ("\?w?suggest replacement of `&''Length` by `&''Last`",
4134 Left_Opnd
(X
), Ent
);
4136 end Test_Suspicious_Index
;
4138 -- Start of processing for Warn_On_Suspicious_Index
4141 -- Only process if warnings activated
4143 if Warn_On_Assumed_Low_Bound
then
4145 -- Test if array is simple entity name
4147 if Is_Entity_Name
(Name
) then
4149 -- Test if array is parameter of unconstrained string type
4151 Ent
:= Entity
(Name
);
4155 and then Is_Suspicious_Type
(Typ
)
4156 and then not Low_Bound_Tested
(Ent
)
4158 Test_Suspicious_Index
;
4162 end Warn_On_Suspicious_Index
;
4164 -------------------------------
4165 -- Warn_On_Suspicious_Update --
4166 -------------------------------
4168 procedure Warn_On_Suspicious_Update
(N
: Node_Id
) is
4169 Par
: constant Node_Id
:= Parent
(N
);
4173 -- Only process if warnings activated
4175 if Warn_On_Suspicious_Contract
then
4176 if Nkind
(Par
) in N_Op_Eq | N_Op_Ne
then
4177 if N
= Left_Opnd
(Par
) then
4178 Arg
:= Right_Opnd
(Par
);
4180 Arg
:= Left_Opnd
(Par
);
4183 if Same_Object
(Prefix
(N
), Arg
) then
4184 if Nkind
(Par
) = N_Op_Eq
then
4186 ("suspicious equality test with modified version of "
4187 & "same object?.t?", Par
);
4190 ("suspicious inequality test with modified version of "
4191 & "same object?.t?", Par
);
4196 end Warn_On_Suspicious_Update
;
4198 --------------------------------------
4199 -- Warn_On_Unassigned_Out_Parameter --
4200 --------------------------------------
4202 procedure Warn_On_Unassigned_Out_Parameter
4203 (Return_Node
: Node_Id
;
4204 Scope_Id
: Entity_Id
)
4209 -- Ignore if procedure or return statement does not come from source
4211 if not Comes_From_Source
(Scope_Id
)
4212 or else not Comes_From_Source
(Return_Node
)
4217 -- Before we issue the warning, add an ad hoc defence against the most
4218 -- common case of false positives with this warning which is the case
4219 -- where there is a Boolean OUT parameter that has been set, and whose
4220 -- meaning is "ignore the values of the other parameters". We can't of
4221 -- course reliably tell this case at compile time, but the following
4222 -- test kills a lot of false positives, without generating a significant
4223 -- number of false negatives (missed real warnings).
4225 Form
:= First_Formal
(Scope_Id
);
4226 while Present
(Form
) loop
4227 if Ekind
(Form
) = E_Out_Parameter
4228 and then Root_Type
(Etype
(Form
)) = Standard_Boolean
4229 and then not Never_Set_In_Source_Check_Spec
(Form
)
4237 -- Loop through formals
4239 Form
:= First_Formal
(Scope_Id
);
4240 while Present
(Form
) loop
4242 -- We are only interested in OUT parameters that come from source
4243 -- and are never set in the source, and furthermore only in scalars
4244 -- since non-scalars generate too many false positives.
4246 if Ekind
(Form
) = E_Out_Parameter
4247 and then Never_Set_In_Source_Check_Spec
(Form
)
4248 and then Is_Scalar_Type
(Etype
(Form
))
4249 and then No
(Unset_Reference
(Form
))
4251 -- Here all conditions are met, record possible unset reference
4253 Set_Unset_Reference
(Form
, Return_Node
);
4258 end Warn_On_Unassigned_Out_Parameter
;
4260 ---------------------------------
4261 -- Warn_On_Unreferenced_Entity --
4262 ---------------------------------
4264 procedure Warn_On_Unreferenced_Entity
4265 (Spec_E
: Entity_Id
;
4266 Body_E
: Entity_Id
:= Empty
)
4268 E
: Entity_Id
:= Spec_E
;
4271 if not Referenced_Check_Spec
(E
)
4272 and then not Has_Pragma_Unreferenced_Check_Spec
(E
)
4273 and then not Warnings_Off_Check_Spec
(E
)
4274 and then not Has_Junk_Name
(Spec_E
)
4275 and then not Is_Exported
(Spec_E
)
4280 -- Case of variable that is assigned but not read. We suppress
4281 -- the message if the variable is volatile, has an address
4282 -- clause, is aliased, or is a renaming, or is imported.
4284 if Referenced_As_LHS_Check_Spec
(E
) then
4285 if Warn_On_Modified_Unread
4286 and then No
(Address_Clause
(E
))
4287 and then not Is_Volatile
(E
)
4288 and then not Is_Imported
(E
)
4289 and then not Is_Aliased
(E
)
4290 and then No
(Renamed_Object
(E
))
4292 if not Has_Pragma_Unmodified_Check_Spec
(E
) then
4293 Error_Msg_N
-- CODEFIX
4294 ("?m?variable & is assigned but never read!", E
);
4297 Set_Last_Assignment
(E
, Empty
);
4300 -- Normal case of neither assigned nor read (exclude variables
4301 -- referenced as out parameters, since we already generated
4302 -- appropriate warnings at the call point in this case).
4304 elsif not Referenced_As_Out_Parameter
(E
) then
4306 -- We suppress the message for types for which a valid
4307 -- pragma Unreferenced_Objects has been given, otherwise
4308 -- we go ahead and give the message.
4310 if not Has_Pragma_Unreferenced_Objects
(Etype
(E
)) then
4312 -- Distinguish renamed case in message
4314 if Present
(Renamed_Object
(E
))
4315 and then Comes_From_Source
(Renamed_Object
(E
))
4317 Error_Msg_N
-- CODEFIX
4318 ("?u?renamed variable & is not referenced!", E
);
4320 Error_Msg_N
-- CODEFIX
4321 ("?u?variable & is not referenced!", E
);
4327 if not Has_Pragma_Unreferenced_Objects
(Etype
(E
)) then
4328 if Present
(Renamed_Object
(E
))
4329 and then Comes_From_Source
(Renamed_Object
(E
))
4331 Error_Msg_N
-- CODEFIX
4332 ("?u?renamed constant & is not referenced!", E
);
4334 Error_Msg_N
-- CODEFIX
4335 ("?u?constant & is not referenced!", E
);
4339 when E_In_Out_Parameter
4342 -- Do not emit message for formals of a renaming, because they
4343 -- are never referenced explicitly.
4345 if Nkind
(Original_Node
(Unit_Declaration_Node
(Scope
(E
)))) /=
4346 N_Subprogram_Renaming_Declaration
4348 -- Suppress this message for an IN OUT parameter of a
4349 -- non-scalar type, since it is normal to have only an
4350 -- assignment in such a case.
4352 if Ekind
(E
) = E_In_Parameter
4353 or else not Referenced_As_LHS_Check_Spec
(E
)
4354 or else Is_Scalar_Type
(Etype
(E
))
4356 if Present
(Body_E
) then
4361 S
: Node_Id
:= Scope
(E
);
4363 if Ekind
(S
) = E_Subprogram_Body
then
4366 while Nkind
(S
) not in
4367 N_Expression_Function |
4369 N_Subprogram_Renaming_Declaration |
4376 S
:= Corresponding_Spec
(S
);
4380 -- Do not warn for dispatching operations, because
4381 -- that causes too much noise. Also do not warn for
4382 -- trivial subprograms (e.g. stubs).
4384 if (No
(S
) or else not Is_Dispatching_Operation
(S
))
4385 and then not Is_Trivial_Subprogram
(Scope
(E
))
4386 and then Check_Unreferenced_Formals
4388 Error_Msg_NE
-- CODEFIX
4389 ("?f?formal parameter & is not referenced!",
4396 when E_Out_Parameter
=>
4399 when E_Discriminant
=>
4400 Error_Msg_N
("?u?discriminant & is not referenced!", E
);
4402 when E_Named_Integer
4405 Error_Msg_N
-- CODEFIX
4406 ("?u?named number & is not referenced!", E
);
4408 when Formal_Object_Kind
=>
4409 Error_Msg_N
-- CODEFIX
4410 ("?u?formal object & is not referenced!", E
);
4412 when E_Enumeration_Literal
=>
4413 Error_Msg_N
-- CODEFIX
4414 ("?u?literal & is not referenced!", E
);
4417 Error_Msg_N
-- CODEFIX
4418 ("?u?function & is not referenced!", E
);
4421 Error_Msg_N
-- CODEFIX
4422 ("?u?procedure & is not referenced!", E
);
4425 Error_Msg_N
-- CODEFIX
4426 ("?u?package & is not referenced!", E
);
4429 Error_Msg_N
-- CODEFIX
4430 ("?u?exception & is not referenced!", E
);
4433 Error_Msg_N
-- CODEFIX
4434 ("?u?label & is not referenced!", E
);
4436 when E_Generic_Procedure
=>
4437 Error_Msg_N
-- CODEFIX
4438 ("?u?generic procedure & is never instantiated!", E
);
4440 when E_Generic_Function
=>
4441 Error_Msg_N
-- CODEFIX
4442 ("?u?generic function & is never instantiated!", E
);
4445 Error_Msg_N
-- CODEFIX
4446 ("?u?type & is not referenced!", E
);
4449 Error_Msg_N
-- CODEFIX
4450 ("?u?& is not referenced!", E
);
4453 -- Kill warnings on the entity on which the message has been posted
4454 -- (nothing is posted on out parameters because back end might be
4455 -- able to uncover an uninitialized path, and warn accordingly).
4457 if Ekind
(E
) /= E_Out_Parameter
then
4458 Set_Warnings_Off
(E
);
4461 end Warn_On_Unreferenced_Entity
;
4463 --------------------------------
4464 -- Warn_On_Useless_Assignment --
4465 --------------------------------
4467 procedure Warn_On_Useless_Assignment
4469 N
: Node_Id
:= Empty
)
4474 function Check_Ref
(N
: Node_Id
) return Traverse_Result
;
4475 -- Used to instantiate Traverse_Func. Returns Abandon if a reference to
4476 -- the entity in question is found.
4478 function Test_No_Refs
is new Traverse_Func
(Check_Ref
);
4484 function Check_Ref
(N
: Node_Id
) return Traverse_Result
is
4486 -- Check reference to our identifier. We use name equality here
4487 -- because the exception handlers have not yet been analyzed. This
4488 -- is not quite right, but it really does not matter that we fail
4489 -- to output the warning in some obscure cases of name clashes.
4491 if Nkind
(N
) = N_Identifier
and then Chars
(N
) = Chars
(Ent
) then
4498 -- Start of processing for Warn_On_Useless_Assignment
4501 -- Check if this is a case we want to warn on, a scalar or access
4502 -- variable with the last assignment field set, with warnings enabled,
4503 -- and which is not imported or exported. We also check that it is OK
4504 -- to capture the value. We are not going to capture any value, but
4505 -- the warning message depends on the same kind of conditions.
4507 -- If the assignment appears as an out-parameter in a call within an
4508 -- expression function it may be detected twice: once when expression
4509 -- itself is analyzed, and once when the constructed body is analyzed.
4510 -- We don't want to emit a spurious warning in this case.
4512 if Is_Assignable
(Ent
)
4513 and then not Is_Return_Object
(Ent
)
4514 and then Present
(Last_Assignment
(Ent
))
4515 and then Last_Assignment
(Ent
) /= N
4516 and then not Is_Imported
(Ent
)
4517 and then not Is_Exported
(Ent
)
4518 and then Safe_To_Capture_Value
(N
, Ent
)
4519 and then not Has_Pragma_Unreferenced_Check_Spec
(Ent
)
4520 and then not Has_Junk_Name
(Ent
)
4522 -- Before we issue the message, check covering exception handlers.
4523 -- Search up tree for enclosing statement sequences and handlers.
4525 P
:= Parent
(Last_Assignment
(Ent
));
4526 while Present
(P
) loop
4528 -- Something is really wrong if we don't find a handled statement
4529 -- sequence, so just suppress the warning.
4532 Set_Last_Assignment
(Ent
, Empty
);
4535 -- When we hit a package/subprogram body, issue warning and exit
4537 elsif Nkind
(P
) in N_Entry_Body
4542 -- Case of assigned value never referenced
4546 LA
: constant Node_Id
:= Last_Assignment
(Ent
);
4549 -- Don't give this for OUT and IN OUT formals, since
4550 -- clearly caller may reference the assigned value. Also
4551 -- never give such warnings for internal variables. In
4552 -- either case, word the warning in a conditional way,
4553 -- because in the case of a component of a controlled
4554 -- type, the assigned value might be referenced in the
4555 -- Finalize operation, so we can't make a definitive
4556 -- statement that it's never referenced.
4558 if Ekind
(Ent
) = E_Variable
4559 and then not Is_Internal_Name
(Chars
(Ent
))
4561 -- Give appropriate message, distinguishing between
4562 -- assignment statements and out parameters.
4564 if Nkind
(Parent
(LA
)) in N_Parameter_Association
4565 | N_Procedure_Call_Statement
4567 if Warn_On_All_Unread_Out_Parameters
then
4569 ("?.o?& modified by call, but value might not "
4570 & "be referenced", LA
, Ent
);
4573 Error_Msg_NE
-- CODEFIX
4574 ("?m?possibly useless assignment to&, value "
4575 & "might not be referenced!", LA
, Ent
);
4580 -- Case of assigned value overwritten
4584 LA
: constant Node_Id
:= Last_Assignment
(Ent
);
4587 Error_Msg_Sloc
:= Sloc
(N
);
4589 -- Give appropriate message, distinguishing between
4590 -- assignment statements and out parameters.
4592 if Nkind
(Parent
(LA
)) in N_Procedure_Call_Statement
4593 | N_Parameter_Association
4596 ("?m?& modified by call, but value overwritten #!",
4599 Error_Msg_NE
-- CODEFIX
4600 ("?m?useless assignment to&, value overwritten #!",
4606 -- Clear last assignment indication and we are done
4608 Set_Last_Assignment
(Ent
, Empty
);
4611 -- Enclosing handled sequence of statements
4613 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
4615 -- Check exception handlers present
4617 if Present
(Exception_Handlers
(P
)) then
4619 -- If we are not at the top level, we regard an inner
4620 -- exception handler as a decisive indicator that we should
4621 -- not generate the warning, since the variable in question
4622 -- may be accessed after an exception in the outer block.
4624 if Nkind
(Parent
(P
)) not in N_Entry_Body
4629 Set_Last_Assignment
(Ent
, Empty
);
4632 -- Otherwise we are at the outer level. An exception
4633 -- handler is significant only if it references the
4634 -- variable in question, or if the entity in question
4635 -- is an OUT or IN OUT parameter, in which case
4636 -- the caller can reference it after the exception
4637 -- handler completes.
4640 if Is_Formal
(Ent
) then
4641 Set_Last_Assignment
(Ent
, Empty
);
4645 X
:= First
(Exception_Handlers
(P
));
4646 while Present
(X
) loop
4647 if Test_No_Refs
(X
) = Abandon
then
4648 Set_Last_Assignment
(Ent
, Empty
);
4662 end Warn_On_Useless_Assignment
;
4664 ---------------------------------
4665 -- Warn_On_Useless_Assignments --
4666 ---------------------------------
4668 procedure Warn_On_Useless_Assignments
(E
: Entity_Id
) is
4672 if Warn_On_Modified_Unread
4673 and then In_Extended_Main_Source_Unit
(E
)
4675 Ent
:= First_Entity
(E
);
4676 while Present
(Ent
) loop
4677 Warn_On_Useless_Assignment
(Ent
);
4681 end Warn_On_Useless_Assignments
;
4683 -----------------------------
4684 -- Warnings_Off_Check_Spec --
4685 -----------------------------
4687 function Warnings_Off_Check_Spec
(E
: Entity_Id
) return Boolean is
4689 if Is_Formal
(E
) and then Present
(Spec_Entity
(E
)) then
4691 -- Note: use of OR here instead of OR ELSE is deliberate, we want
4692 -- to mess with flags on both entities.
4694 return Has_Warnings_Off
(E
)
4696 Has_Warnings_Off
(Spec_Entity
(E
));
4699 return Has_Warnings_Off
(E
);
4701 end Warnings_Off_Check_Spec
;