]>
Commit | Line | Data |
---|---|---|
d6f39728 | 1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ W A R N -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
e977c0cf | 9 | -- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- |
d6f39728 | 10 | -- -- |
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- -- | |
80df182a | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
d6f39728 | 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 -- | |
80df182a | 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. -- | |
d6f39728 | 20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
e78e8c8e | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
d6f39728 | 23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
d6f39728 | 26 | with Atree; use Atree; |
8255b799 | 27 | with Debug; use Debug; |
d6f39728 | 28 | with Einfo; use Einfo; |
29 | with Errout; use Errout; | |
c0d40c9a | 30 | with Exp_Code; use Exp_Code; |
d6f39728 | 31 | with Fname; use Fname; |
32 | with Lib; use Lib; | |
c0d40c9a | 33 | with Namet; use Namet; |
d6f39728 | 34 | with Nlists; use Nlists; |
35 | with Opt; use Opt; | |
902e2182 | 36 | with Par_SCO; use Par_SCO; |
8063f750 | 37 | with Rtsfind; use Rtsfind; |
d6f39728 | 38 | with Sem; use Sem; |
9dfe12ae | 39 | with Sem_Ch8; use Sem_Ch8; |
d55c93e0 | 40 | with Sem_Aux; use Sem_Aux; |
c0d40c9a | 41 | with Sem_Eval; use Sem_Eval; |
d6f39728 | 42 | with Sem_Util; use Sem_Util; |
43 | with Sinfo; use Sinfo; | |
44 | with Sinput; use Sinput; | |
45 | with Snames; use Snames; | |
46 | with Stand; use Stand; | |
c0d40c9a | 47 | with Stringt; use Stringt; |
c0d40c9a | 48 | with Uintp; use Uintp; |
d6f39728 | 49 | |
50 | package body Sem_Warn is | |
51 | ||
52 | -- The following table collects Id's of entities that are potentially | |
53 | -- unreferenced. See Check_Unset_Reference for further details. | |
8063f750 | 54 | -- ??? Check_Unset_Reference has zero information about this table. |
d6f39728 | 55 | |
56 | package Unreferenced_Entities is new Table.Table ( | |
57 | Table_Component_Type => Entity_Id, | |
58 | Table_Index_Type => Nat, | |
59 | Table_Low_Bound => 1, | |
60 | Table_Initial => Alloc.Unreferenced_Entities_Initial, | |
61 | Table_Increment => Alloc.Unreferenced_Entities_Increment, | |
62 | Table_Name => "Unreferenced_Entities"); | |
63 | ||
4540a696 | 64 | -- The following table collects potential warnings for IN OUT parameters |
65 | -- that are referenced but not modified. These warnings are processed when | |
1a34e48c | 66 | -- the front end calls the procedure Output_Non_Modified_In_Out_Warnings. |
4540a696 | 67 | -- The reason that we defer output of these messages is that we want to |
68 | -- detect the case where the relevant procedure is used as a generic actual | |
1a34e48c | 69 | -- in an instantiation, since we suppress the warnings in this case. The |
059bd36a | 70 | -- flag Used_As_Generic_Actual will be set in this case, but only at the |
71 | -- point of usage. Similarly, we suppress the message if the address of the | |
72 | -- procedure is taken, where the flag Address_Taken may be set later. | |
4540a696 | 73 | |
8063f750 | 74 | package In_Out_Warnings is new Table.Table ( |
75 | Table_Component_Type => Entity_Id, | |
76 | Table_Index_Type => Nat, | |
77 | Table_Low_Bound => 1, | |
78 | Table_Initial => Alloc.In_Out_Warnings_Initial, | |
79 | Table_Increment => Alloc.In_Out_Warnings_Increment, | |
80 | Table_Name => "In_Out_Warnings"); | |
81 | ||
059bd36a | 82 | -------------------------------------------------------- |
83 | -- Handling of Warnings Off, Unmodified, Unreferenced -- | |
84 | -------------------------------------------------------- | |
85 | ||
86 | -- The functions Has_Warnings_Off, Has_Unmodified, Has_Unreferenced must | |
87 | -- generally be used instead of Warnings_Off, Has_Pragma_Unmodified and | |
88 | -- Has_Pragma_Unreferenced, as noted in the specs in Einfo. | |
89 | ||
90 | -- In order to avoid losing warnings in -gnatw.w (warn on unnecessary | |
91 | -- warnings off pragma) mode, i.e. to avoid false negatives, the code | |
92 | -- must follow some important rules. | |
93 | ||
94 | -- Call these functions as late as possible, after completing all other | |
95 | -- tests, just before the warnings is given. For example, don't write: | |
96 | ||
97 | -- if not Has_Warnings_Off (E) | |
98 | -- and then some-other-predicate-on-E then .. | |
99 | ||
100 | -- Instead the following is preferred | |
101 | ||
1a34e48c | 102 | -- if some-other-predicate-on-E |
059bd36a | 103 | -- and then Has_Warnings_Off (E) |
104 | ||
105 | -- This way if some-other-predicate is false, we avoid a false indication | |
106 | -- that a Warnings (Off,E) pragma was useful in preventing a warning. | |
107 | ||
108 | -- The second rule is that if both Has_Unmodified and Has_Warnings_Off, or | |
109 | -- Has_Unreferenced and Has_Warnings_Off are called, make sure that the | |
110 | -- call to Has_Unmodified/Has_Unreferenced comes first, this way we record | |
111 | -- that the Warnings (Off) could have been Unreferenced or Unmodified. In | |
112 | -- fact Has_Unmodified/Has_Unreferenced includes a test for Warnings Off, | |
113 | -- and so a subsequent test is not needed anyway (though it is harmless). | |
114 | ||
9dfe12ae | 115 | ----------------------- |
116 | -- Local Subprograms -- | |
117 | ----------------------- | |
118 | ||
119 | function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean; | |
120 | -- This returns true if the entity E is declared within a generic package. | |
121 | -- The point of this is to detect variables which are not assigned within | |
122 | -- the generic, but might be assigned outside the package for any given | |
8063f750 | 123 | -- instance. These are cases where we leave the warnings to be posted for |
124 | -- the instance, when we will know more. | |
125 | ||
126 | function Goto_Spec_Entity (E : Entity_Id) return Entity_Id; | |
127 | -- If E is a parameter entity for a subprogram body, then this function | |
128 | -- returns the corresponding spec entity, if not, E is returned unchanged. | |
129 | ||
4540a696 | 130 | function Has_Pragma_Unmodified_Check_Spec (E : Entity_Id) return Boolean; |
131 | -- Tests Has_Pragma_Unmodified flag for entity E. If E is not a formal, | |
132 | -- this is simply the setting of the flag Has_Pragma_Unmodified. If E is | |
133 | -- a body formal, the setting of the flag in the corresponding spec is | |
134 | -- also checked (and True returned if either flag is True). | |
135 | ||
8063f750 | 136 | function Has_Pragma_Unreferenced_Check_Spec (E : Entity_Id) return Boolean; |
137 | -- Tests Has_Pragma_Unreferenced flag for entity E. If E is not a formal, | |
138 | -- this is simply the setting of the flag Has_Pragma_Unreferenced. If E is | |
139 | -- a body formal, the setting of the flag in the corresponding spec is | |
140 | -- also checked (and True returned if either flag is True). | |
141 | ||
142 | function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean; | |
143 | -- Tests Never_Set_In_Source status for entity E. If E is not a formal, | |
144 | -- this is simply the setting of the flag Never_Set_In_Source. If E is | |
145 | -- a body formal, the setting of the flag in the corresponding spec is | |
146 | -- also checked (and False returned if either flag is False). | |
9dfe12ae | 147 | |
f15731c4 | 148 | function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean; |
c5797b4f | 149 | -- This function traverses the expression tree represented by the node N |
150 | -- and determines if any sub-operand is a reference to an entity for which | |
151 | -- the Warnings_Off flag is set. True is returned if such an entity is | |
152 | -- encountered, and False otherwise. | |
d6f39728 | 153 | |
8063f750 | 154 | function Referenced_Check_Spec (E : Entity_Id) return Boolean; |
155 | -- Tests Referenced status for entity E. If E is not a formal, this is | |
156 | -- simply the setting of the flag Referenced. If E is a body formal, the | |
157 | -- setting of the flag in the corresponding spec is also checked (and True | |
158 | -- returned if either flag is True). | |
159 | ||
160 | function Referenced_As_LHS_Check_Spec (E : Entity_Id) return Boolean; | |
161 | -- Tests Referenced_As_LHS status for entity E. If E is not a formal, this | |
162 | -- is simply the setting of the flag Referenced_As_LHS. If E is a body | |
163 | -- formal, the setting of the flag in the corresponding spec is also | |
164 | -- checked (and True returned if either flag is True). | |
165 | ||
ed683f94 | 166 | function Referenced_As_Out_Parameter_Check_Spec |
167 | (E : Entity_Id) return Boolean; | |
168 | -- Tests Referenced_As_Out_Parameter status for entity E. If E is not a | |
169 | -- formal, this is simply the setting of Referenced_As_Out_Parameter. If E | |
170 | -- is a body formal, the setting of the flag in the corresponding spec is | |
171 | -- also checked (and True returned if either flag is True). | |
172 | ||
8063f750 | 173 | procedure Warn_On_Unreferenced_Entity |
174 | (Spec_E : Entity_Id; | |
175 | Body_E : Entity_Id := Empty); | |
176 | -- Output warnings for unreferenced entity E. For the case of an entry | |
177 | -- formal, Body_E is the corresponding body entity for a particular | |
178 | -- accept statement, and the message is posted on Body_E. In all other | |
179 | -- cases, Body_E is ignored and must be Empty. | |
180 | ||
059bd36a | 181 | function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean; |
182 | -- Returns True if Warnings_Off is set for the entity E or (in the case | |
183 | -- where there is a Spec_Entity), Warnings_Off is set for the Spec_Entity. | |
184 | ||
c0d40c9a | 185 | -------------------------- |
186 | -- Check_Code_Statement -- | |
187 | -------------------------- | |
188 | ||
189 | procedure Check_Code_Statement (N : Node_Id) is | |
190 | begin | |
191 | -- If volatile, nothing to worry about | |
192 | ||
193 | if Is_Asm_Volatile (N) then | |
194 | return; | |
195 | end if; | |
196 | ||
197 | -- Warn if no input or no output | |
198 | ||
199 | Setup_Asm_Inputs (N); | |
200 | ||
201 | if No (Asm_Input_Value) then | |
503f7fd3 | 202 | Error_Msg_F |
8063f750 | 203 | ("?code statement with no inputs should usually be Volatile!", N); |
c0d40c9a | 204 | return; |
205 | end if; | |
206 | ||
207 | Setup_Asm_Outputs (N); | |
208 | ||
209 | if No (Asm_Output_Variable) then | |
503f7fd3 | 210 | Error_Msg_F |
8063f750 | 211 | ("?code statement with no outputs should usually be Volatile!", N); |
c0d40c9a | 212 | return; |
213 | end if; | |
214 | ||
215 | -- Check multiple code statements in a row | |
cc285c23 | 216 | |
c0d40c9a | 217 | if Is_List_Member (N) |
218 | and then Present (Prev (N)) | |
219 | and then Nkind (Prev (N)) = N_Code_Statement | |
220 | then | |
503f7fd3 | 221 | Error_Msg_F |
8063f750 | 222 | ("?code statements in sequence should usually be Volatile!", N); |
c0d40c9a | 223 | Error_Msg_F |
8063f750 | 224 | ("\?(suggest using template with multiple instructions)!", N); |
c0d40c9a | 225 | end if; |
226 | end Check_Code_Statement; | |
227 | ||
8255b799 | 228 | --------------------------------- |
229 | -- Check_Infinite_Loop_Warning -- | |
230 | --------------------------------- | |
231 | ||
232 | -- The case we look for is a while loop which tests a local variable, where | |
233 | -- there is no obvious direct or possible indirect update of the variable | |
234 | -- within the body of the loop. | |
235 | ||
236 | procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is | |
006b904a | 237 | Expression : Node_Id := Empty; |
238 | -- Set to WHILE or EXIT WHEN condition to be tested | |
8255b799 | 239 | |
8063f750 | 240 | Ref : Node_Id := Empty; |
006b904a | 241 | -- Reference in Expression to variable that might not be modified |
e0c76917 | 242 | -- in loop, indicating a possible infinite loop. |
8255b799 | 243 | |
244 | Var : Entity_Id := Empty; | |
245 | -- Corresponding entity (entity of Ref) | |
246 | ||
e0c76917 | 247 | Function_Call_Found : Boolean := False; |
248 | -- True if Find_Var found a function call in the condition | |
249 | ||
8255b799 | 250 | procedure Find_Var (N : Node_Id); |
8063f750 | 251 | -- Inspect condition to see if it depends on a single entity reference. |
252 | -- If so, Ref is set to point to the reference node, and Var is set to | |
253 | -- the referenced Entity. | |
8255b799 | 254 | |
255 | function Has_Indirection (T : Entity_Id) return Boolean; | |
256 | -- If the controlling variable is an access type, or is a record type | |
257 | -- with access components, assume that it is changed indirectly and | |
258 | -- suppress the warning. As a concession to low-level programming, in | |
259 | -- particular within Declib, we also suppress warnings on a record | |
260 | -- type that contains components of type Address or Short_Address. | |
261 | ||
262 | function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean; | |
263 | -- Given an entity name, see if the name appears to have something to | |
264 | -- do with I/O or network stuff, and if so, return True. Used to kill | |
265 | -- some false positives on a heuristic basis that such functions will | |
266 | -- likely have some strange side effect dependencies. A rather funny | |
267 | -- kludge, but warning messages are in the heuristics business. | |
268 | ||
269 | function Test_Ref (N : Node_Id) return Traverse_Result; | |
270 | -- Test for reference to variable in question. Returns Abandon if | |
006b904a | 271 | -- matching reference found. Used in instantiation of No_Ref_Found. |
8255b799 | 272 | |
006b904a | 273 | function No_Ref_Found is new Traverse_Func (Test_Ref); |
8255b799 | 274 | -- Function to traverse body of procedure. Returns Abandon if matching |
275 | -- reference found. | |
276 | ||
277 | -------------- | |
278 | -- Find_Var -- | |
279 | -------------- | |
280 | ||
281 | procedure Find_Var (N : Node_Id) is | |
282 | begin | |
283 | -- Condition is a direct variable reference | |
284 | ||
285 | if Is_Entity_Name (N) then | |
286 | Ref := N; | |
287 | Var := Entity (Ref); | |
288 | ||
ed683f94 | 289 | -- Case of condition is a comparison with compile time known value |
8255b799 | 290 | |
291 | elsif Nkind (N) in N_Op_Compare then | |
292 | if Compile_Time_Known_Value (Right_Opnd (N)) then | |
293 | Find_Var (Left_Opnd (N)); | |
294 | ||
295 | elsif Compile_Time_Known_Value (Left_Opnd (N)) then | |
296 | Find_Var (Right_Opnd (N)); | |
297 | ||
298 | -- Ignore any other comparison | |
299 | ||
300 | else | |
301 | return; | |
302 | end if; | |
303 | ||
ed683f94 | 304 | -- If condition is a negation, check its operand |
8255b799 | 305 | |
306 | elsif Nkind (N) = N_Op_Not then | |
307 | Find_Var (Right_Opnd (N)); | |
308 | ||
ed683f94 | 309 | -- Case of condition is function call |
8255b799 | 310 | |
311 | elsif Nkind (N) = N_Function_Call then | |
312 | ||
e0c76917 | 313 | Function_Call_Found := True; |
314 | ||
8255b799 | 315 | -- Forget it if function name is not entity, who knows what |
316 | -- we might be calling? | |
317 | ||
318 | if not Is_Entity_Name (Name (N)) then | |
319 | return; | |
320 | ||
059bd36a | 321 | -- Forget it if function name is suspicious. A strange test |
322 | -- but warning generation is in the heuristics business! | |
8255b799 | 323 | |
059bd36a | 324 | elsif Is_Suspicious_Function_Name (Entity (Name (N))) then |
8255b799 | 325 | return; |
326 | ||
059bd36a | 327 | -- Forget it if warnings are suppressed on function entity |
8255b799 | 328 | |
059bd36a | 329 | elsif Has_Warnings_Off (Entity (Name (N))) then |
8255b799 | 330 | return; |
331 | end if; | |
332 | ||
333 | -- OK, see if we have one argument | |
334 | ||
335 | declare | |
336 | PA : constant List_Id := Parameter_Associations (N); | |
337 | ||
338 | begin | |
339 | -- One argument, so check the argument | |
340 | ||
341 | if Present (PA) | |
342 | and then List_Length (PA) = 1 | |
343 | then | |
344 | if Nkind (First (PA)) = N_Parameter_Association then | |
345 | Find_Var (Explicit_Actual_Parameter (First (PA))); | |
346 | else | |
347 | Find_Var (First (PA)); | |
348 | end if; | |
349 | ||
ed683f94 | 350 | -- Not one argument |
8255b799 | 351 | |
352 | else | |
353 | return; | |
354 | end if; | |
355 | end; | |
356 | ||
ed683f94 | 357 | -- Any other kind of node is not something we warn for |
8255b799 | 358 | |
359 | else | |
360 | return; | |
361 | end if; | |
362 | end Find_Var; | |
363 | ||
364 | --------------------- | |
365 | -- Has_Indirection -- | |
366 | --------------------- | |
367 | ||
368 | function Has_Indirection (T : Entity_Id) return Boolean is | |
369 | Comp : Entity_Id; | |
370 | Rec : Entity_Id; | |
371 | ||
372 | begin | |
373 | if Is_Access_Type (T) then | |
374 | return True; | |
375 | ||
376 | elsif Is_Private_Type (T) | |
377 | and then Present (Full_View (T)) | |
378 | and then Is_Access_Type (Full_View (T)) | |
379 | then | |
380 | return True; | |
381 | ||
382 | elsif Is_Record_Type (T) then | |
383 | Rec := T; | |
384 | ||
385 | elsif Is_Private_Type (T) | |
386 | and then Present (Full_View (T)) | |
387 | and then Is_Record_Type (Full_View (T)) | |
388 | then | |
389 | Rec := Full_View (T); | |
390 | else | |
391 | return False; | |
392 | end if; | |
393 | ||
394 | Comp := First_Component (Rec); | |
395 | while Present (Comp) loop | |
396 | if Is_Access_Type (Etype (Comp)) | |
397 | or else Is_Descendent_Of_Address (Etype (Comp)) | |
398 | then | |
399 | return True; | |
400 | end if; | |
401 | ||
402 | Next_Component (Comp); | |
403 | end loop; | |
404 | ||
405 | return False; | |
406 | end Has_Indirection; | |
407 | ||
408 | --------------------------------- | |
409 | -- Is_Suspicious_Function_Name -- | |
410 | --------------------------------- | |
411 | ||
412 | function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean is | |
413 | S : Entity_Id; | |
414 | ||
415 | function Substring_Present (S : String) return Boolean; | |
416 | -- Returns True if name buffer has given string delimited by non- | |
417 | -- alphabetic characters or by end of string. S is lower case. | |
418 | ||
419 | ----------------------- | |
420 | -- Substring_Present -- | |
421 | ----------------------- | |
422 | ||
423 | function Substring_Present (S : String) return Boolean is | |
424 | Len : constant Natural := S'Length; | |
425 | ||
426 | begin | |
427 | for J in 1 .. Name_Len - (Len - 1) loop | |
428 | if Name_Buffer (J .. J + (Len - 1)) = S | |
429 | and then | |
430 | (J = 1 | |
431 | or else Name_Buffer (J - 1) not in 'a' .. 'z') | |
432 | and then | |
433 | (J + Len > Name_Len | |
434 | or else Name_Buffer (J + Len) not in 'a' .. 'z') | |
435 | then | |
436 | return True; | |
437 | end if; | |
438 | end loop; | |
439 | ||
440 | return False; | |
441 | end Substring_Present; | |
442 | ||
ed683f94 | 443 | -- Start of processing for Is_Suspicious_Function_Name |
8255b799 | 444 | |
445 | begin | |
446 | S := E; | |
447 | while Present (S) and then S /= Standard_Standard loop | |
448 | Get_Name_String (Chars (S)); | |
449 | ||
450 | if Substring_Present ("io") | |
451 | or else Substring_Present ("file") | |
452 | or else Substring_Present ("network") | |
453 | then | |
454 | return True; | |
455 | else | |
456 | S := Scope (S); | |
457 | end if; | |
458 | end loop; | |
459 | ||
460 | return False; | |
461 | end Is_Suspicious_Function_Name; | |
462 | ||
463 | -------------- | |
464 | -- Test_Ref -- | |
465 | -------------- | |
466 | ||
467 | function Test_Ref (N : Node_Id) return Traverse_Result is | |
468 | begin | |
006b904a | 469 | -- Waste of time to look at the expression we are testing |
8255b799 | 470 | |
006b904a | 471 | if N = Expression then |
8255b799 | 472 | return Skip; |
473 | ||
ed683f94 | 474 | -- Direct reference to variable in question |
8255b799 | 475 | |
476 | elsif Is_Entity_Name (N) | |
477 | and then Present (Entity (N)) | |
478 | and then Entity (N) = Var | |
479 | then | |
d3931fdc | 480 | -- If this is an lvalue, then definitely abandon, since |
8255b799 | 481 | -- this could be a direct modification of the variable. |
482 | ||
483 | if May_Be_Lvalue (N) then | |
484 | return Abandon; | |
485 | end if; | |
486 | ||
487 | -- If we appear in the context of a procedure call, then also | |
488 | -- abandon, since there may be issues of non-visible side | |
489 | -- effects going on in the call. | |
490 | ||
491 | declare | |
492 | P : Node_Id; | |
ed683f94 | 493 | |
8255b799 | 494 | begin |
495 | P := N; | |
496 | loop | |
497 | P := Parent (P); | |
498 | exit when P = Loop_Statement; | |
499 | ||
aab73971 | 500 | -- Abandon if at procedure call, or something strange is |
501 | -- going on (perhaps a node with no parent that should | |
502 | -- have one but does not?) As always, for a warning we | |
503 | -- prefer to just abandon the warning than get into the | |
504 | -- business of complaining about the tree structure here! | |
505 | ||
506 | if No (P) or else Nkind (P) = N_Procedure_Call_Statement then | |
8255b799 | 507 | return Abandon; |
508 | end if; | |
509 | end loop; | |
510 | end; | |
511 | ||
512 | -- Reference to variable renaming variable in question | |
513 | ||
514 | elsif Is_Entity_Name (N) | |
515 | and then Present (Entity (N)) | |
516 | and then Ekind (Entity (N)) = E_Variable | |
517 | and then Present (Renamed_Object (Entity (N))) | |
518 | and then Is_Entity_Name (Renamed_Object (Entity (N))) | |
519 | and then Entity (Renamed_Object (Entity (N))) = Var | |
520 | and then May_Be_Lvalue (N) | |
521 | then | |
522 | return Abandon; | |
523 | ||
524 | -- Call to subprogram | |
525 | ||
526 | elsif Nkind (N) = N_Procedure_Call_Statement | |
527 | or else Nkind (N) = N_Function_Call | |
528 | then | |
8063f750 | 529 | -- If subprogram is within the scope of the entity we are dealing |
530 | -- with as the loop variable, then it could modify this parameter, | |
531 | -- so we abandon in this case. In the case of a subprogram that is | |
532 | -- not an entity we also abandon. The check for no entity being | |
533 | -- present is a defense against previous errors. | |
8255b799 | 534 | |
535 | if not Is_Entity_Name (Name (N)) | |
8063f750 | 536 | or else No (Entity (Name (N))) |
8255b799 | 537 | or else Scope_Within (Entity (Name (N)), Scope (Var)) |
538 | then | |
539 | return Abandon; | |
540 | end if; | |
5d714e68 | 541 | |
edfaec46 | 542 | -- If any of the arguments are of type access to subprogram, then |
543 | -- we may have funny side effects, so no warning in this case. | |
544 | ||
545 | declare | |
546 | Actual : Node_Id; | |
547 | begin | |
548 | Actual := First_Actual (N); | |
549 | while Present (Actual) loop | |
550 | if Is_Access_Subprogram_Type (Etype (Actual)) then | |
551 | return Abandon; | |
552 | else | |
553 | Next_Actual (Actual); | |
554 | end if; | |
555 | end loop; | |
556 | end; | |
557 | ||
5d714e68 | 558 | -- Declaration of the variable in question |
559 | ||
560 | elsif Nkind (N) = N_Object_Declaration | |
561 | and then Defining_Identifier (N) = Var | |
562 | then | |
563 | return Abandon; | |
8255b799 | 564 | end if; |
565 | ||
566 | -- All OK, continue scan | |
567 | ||
568 | return OK; | |
569 | end Test_Ref; | |
570 | ||
571 | -- Start of processing for Check_Infinite_Loop_Warning | |
572 | ||
573 | begin | |
006b904a | 574 | -- Skip processing if debug flag gnatd.w is set |
8255b799 | 575 | |
006b904a | 576 | if Debug_Flag_Dot_W then |
577 | return; | |
578 | end if; | |
579 | ||
5d714e68 | 580 | -- Deal with Iteration scheme present |
006b904a | 581 | |
582 | declare | |
583 | Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); | |
584 | ||
585 | begin | |
5d714e68 | 586 | if Present (Iter) then |
006b904a | 587 | |
5d714e68 | 588 | -- While iteration |
006b904a | 589 | |
5d714e68 | 590 | if Present (Condition (Iter)) then |
591 | ||
592 | -- Skip processing for while iteration with conditions actions, | |
593 | -- since they make it too complicated to get the warning right. | |
006b904a | 594 | |
5d714e68 | 595 | if Present (Condition_Actions (Iter)) then |
596 | return; | |
597 | end if; | |
006b904a | 598 | |
5d714e68 | 599 | -- Capture WHILE condition |
600 | ||
601 | Expression := Condition (Iter); | |
602 | ||
603 | -- For iteration, do not process, since loop will always terminate | |
604 | ||
605 | elsif Present (Loop_Parameter_Specification (Iter)) then | |
606 | return; | |
607 | end if; | |
006b904a | 608 | end if; |
609 | end; | |
610 | ||
611 | -- Check chain of EXIT statements, we only process loops that have a | |
612 | -- single exit condition (either a single EXIT WHEN statement, or a | |
613 | -- WHILE loop not containing any EXIT WHEN statements). | |
614 | ||
615 | declare | |
616 | Ident : constant Node_Id := Identifier (Loop_Statement); | |
617 | Exit_Stmt : Node_Id; | |
618 | ||
619 | begin | |
620 | -- If we don't have a proper chain set, ignore call entirely. This | |
621 | -- happens because of previous errors. | |
622 | ||
623 | if No (Entity (Ident)) | |
624 | or else Ekind (Entity (Ident)) /= E_Loop | |
625 | then | |
626 | return; | |
627 | end if; | |
628 | ||
629 | -- Otherwise prepare to scan list of EXIT statements | |
630 | ||
631 | Exit_Stmt := First_Exit_Statement (Entity (Ident)); | |
632 | while Present (Exit_Stmt) loop | |
633 | ||
634 | -- Check for EXIT WHEN | |
635 | ||
636 | if Present (Condition (Exit_Stmt)) then | |
637 | ||
638 | -- Quit processing if EXIT WHEN in WHILE loop, or more than | |
639 | -- one EXIT WHEN statement present in the loop. | |
640 | ||
641 | if Present (Expression) then | |
642 | return; | |
643 | ||
644 | -- Otherwise capture condition from EXIT WHEN statement | |
645 | ||
646 | else | |
647 | Expression := Condition (Exit_Stmt); | |
648 | end if; | |
649 | end if; | |
650 | ||
651 | Exit_Stmt := Next_Exit_Statement (Exit_Stmt); | |
652 | end loop; | |
653 | end; | |
654 | ||
655 | -- Return if no condition to test | |
656 | ||
657 | if No (Expression) then | |
8255b799 | 658 | return; |
659 | end if; | |
660 | ||
661 | -- Initial conditions met, see if condition is of right form | |
662 | ||
006b904a | 663 | Find_Var (Expression); |
8255b799 | 664 | |
ba14ef4a | 665 | -- Nothing to do if local variable from source not found. If it's a |
666 | -- renaming, it is probably renaming something too complicated to deal | |
667 | -- with here. | |
8255b799 | 668 | |
669 | if No (Var) | |
670 | or else Ekind (Var) /= E_Variable | |
671 | or else Is_Library_Level_Entity (Var) | |
672 | or else not Comes_From_Source (Var) | |
ba14ef4a | 673 | or else Nkind (Parent (Var)) = N_Object_Renaming_Declaration |
8255b799 | 674 | then |
675 | return; | |
676 | ||
677 | -- Nothing to do if there is some indirection involved (assume that the | |
678 | -- designated variable might be modified in some way we don't see). | |
e0c76917 | 679 | -- However, if no function call was found, then we don't care about |
680 | -- indirections, because the condition must be something like "while X | |
681 | -- /= null loop", so we don't care if X.all is modified in the loop. | |
8255b799 | 682 | |
e0c76917 | 683 | elsif Function_Call_Found and then Has_Indirection (Etype (Var)) then |
8255b799 | 684 | return; |
685 | ||
686 | -- Same sort of thing for volatile variable, might be modified by | |
687 | -- some other task or by the operating system in some way. | |
688 | ||
689 | elsif Is_Volatile (Var) then | |
690 | return; | |
691 | end if; | |
692 | ||
693 | -- Filter out case of original statement sequence starting with delay. | |
694 | -- We assume this is a multi-tasking program and that the condition | |
695 | -- is affected by other threads (some kind of busy wait). | |
696 | ||
697 | declare | |
698 | Fstm : constant Node_Id := | |
699 | Original_Node (First (Statements (Loop_Statement))); | |
700 | begin | |
701 | if Nkind (Fstm) = N_Delay_Relative_Statement | |
702 | or else Nkind (Fstm) = N_Delay_Until_Statement | |
703 | then | |
704 | return; | |
705 | end if; | |
706 | end; | |
707 | ||
708 | -- We have a variable reference of the right form, now we scan the loop | |
709 | -- body to see if it looks like it might not be modified | |
710 | ||
006b904a | 711 | if No_Ref_Found (Loop_Statement) = OK then |
8255b799 | 712 | Error_Msg_NE |
8063f750 | 713 | ("?variable& is not modified in loop body!", Ref, Var); |
8255b799 | 714 | Error_Msg_N |
8063f750 | 715 | ("\?possible infinite loop!", Ref); |
8255b799 | 716 | end if; |
717 | end Check_Infinite_Loop_Warning; | |
718 | ||
19b4517d | 719 | ---------------------------- |
720 | -- Check_Low_Bound_Tested -- | |
721 | ---------------------------- | |
722 | ||
723 | procedure Check_Low_Bound_Tested (Expr : Node_Id) is | |
724 | begin | |
725 | if Comes_From_Source (Expr) then | |
726 | declare | |
727 | L : constant Node_Id := Left_Opnd (Expr); | |
728 | R : constant Node_Id := Right_Opnd (Expr); | |
729 | begin | |
730 | if Nkind (L) = N_Attribute_Reference | |
731 | and then Attribute_Name (L) = Name_First | |
732 | and then Is_Entity_Name (Prefix (L)) | |
733 | and then Is_Formal (Entity (Prefix (L))) | |
19b4517d | 734 | then |
735 | Set_Low_Bound_Tested (Entity (Prefix (L))); | |
736 | end if; | |
f3f7771d | 737 | |
738 | if Nkind (R) = N_Attribute_Reference | |
739 | and then Attribute_Name (R) = Name_First | |
740 | and then Is_Entity_Name (Prefix (R)) | |
741 | and then Is_Formal (Entity (Prefix (R))) | |
742 | then | |
743 | Set_Low_Bound_Tested (Entity (Prefix (R))); | |
744 | end if; | |
19b4517d | 745 | end; |
746 | end if; | |
747 | end Check_Low_Bound_Tested; | |
748 | ||
d6f39728 | 749 | ---------------------- |
750 | -- Check_References -- | |
751 | ---------------------- | |
752 | ||
753 | procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is | |
4540a696 | 754 | E1 : Entity_Id; |
755 | E1T : Entity_Id; | |
756 | UR : Node_Id; | |
9dfe12ae | 757 | |
8063f750 | 758 | function Body_Formal |
759 | (E : Entity_Id; | |
760 | Accept_Statement : Node_Id) return Entity_Id; | |
761 | -- For an entry formal entity from an entry declaration, find the | |
1a34e48c | 762 | -- corresponding body formal from the given accept statement. |
8063f750 | 763 | |
9dfe12ae | 764 | function Missing_Subunits return Boolean; |
765 | -- We suppress warnings when there are missing subunits, because this | |
c5797b4f | 766 | -- may generate too many false positives: entities in a parent may only |
767 | -- be referenced in one of the subunits. We make an exception for | |
768 | -- subunits that contain no other stubs. | |
d6f39728 | 769 | |
770 | procedure Output_Reference_Error (M : String); | |
c5797b4f | 771 | -- Used to output an error message. Deals with posting the error on the |
772 | -- body formal in the accept case. | |
d6f39728 | 773 | |
774 | function Publicly_Referenceable (Ent : Entity_Id) return Boolean; | |
775 | -- This is true if the entity in question is potentially referenceable | |
c5797b4f | 776 | -- from another unit. This is true for entities in packages that are at |
777 | -- the library level. | |
d6f39728 | 778 | |
059bd36a | 779 | function Warnings_Off_E1 return Boolean; |
780 | -- Return True if Warnings_Off is set for E1, or for its Etype (E1T), | |
781 | -- or for the base type of E1T. | |
782 | ||
783 | ----------------- | |
784 | -- Body_Formal -- | |
785 | ----------------- | |
786 | ||
787 | function Body_Formal | |
788 | (E : Entity_Id; | |
789 | Accept_Statement : Node_Id) return Entity_Id | |
790 | is | |
791 | Body_Param : Node_Id; | |
792 | Body_E : Entity_Id; | |
793 | ||
794 | begin | |
795 | -- Loop to find matching parameter in accept statement | |
796 | ||
797 | Body_Param := First (Parameter_Specifications (Accept_Statement)); | |
798 | while Present (Body_Param) loop | |
799 | Body_E := Defining_Identifier (Body_Param); | |
800 | ||
801 | if Chars (Body_E) = Chars (E) then | |
802 | return Body_E; | |
803 | end if; | |
804 | ||
805 | Next (Body_Param); | |
806 | end loop; | |
807 | ||
808 | -- Should never fall through, should always find a match | |
809 | ||
810 | raise Program_Error; | |
811 | end Body_Formal; | |
812 | ||
5c99c290 | 813 | ---------------------- |
814 | -- Missing_Subunits -- | |
815 | ---------------------- | |
9dfe12ae | 816 | |
817 | function Missing_Subunits return Boolean is | |
818 | D : Node_Id; | |
819 | ||
820 | begin | |
821 | if not Unloaded_Subunits then | |
822 | ||
823 | -- Normal compilation, all subunits are present | |
824 | ||
825 | return False; | |
826 | ||
827 | elsif E /= Main_Unit_Entity then | |
828 | ||
829 | -- No warnings on a stub that is not the main unit | |
830 | ||
831 | return True; | |
832 | ||
833 | elsif Nkind (Unit_Declaration_Node (E)) in N_Proper_Body then | |
834 | D := First (Declarations (Unit_Declaration_Node (E))); | |
9dfe12ae | 835 | while Present (D) loop |
836 | ||
837 | -- No warnings if the proper body contains nested stubs | |
838 | ||
839 | if Nkind (D) in N_Body_Stub then | |
840 | return True; | |
841 | end if; | |
842 | ||
843 | Next (D); | |
844 | end loop; | |
845 | ||
846 | return False; | |
847 | ||
848 | else | |
c5797b4f | 849 | -- Missing stubs elsewhere |
9dfe12ae | 850 | |
851 | return True; | |
852 | end if; | |
853 | end Missing_Subunits; | |
854 | ||
d6f39728 | 855 | ---------------------------- |
856 | -- Output_Reference_Error -- | |
857 | ---------------------------- | |
858 | ||
859 | procedure Output_Reference_Error (M : String) is | |
860 | begin | |
780bfb21 | 861 | -- Never issue messages for internal names, nor for renamings |
4540a696 | 862 | |
780bfb21 | 863 | if Is_Internal_Name (Chars (E1)) |
864 | or else Nkind (Parent (E1)) = N_Object_Renaming_Declaration | |
865 | then | |
4540a696 | 866 | return; |
867 | end if; | |
868 | ||
8063f750 | 869 | -- Don't output message for IN OUT formal unless we have the warning |
870 | -- flag specifically set. It is a bit odd to distinguish IN OUT | |
871 | -- formals from other cases. This distinction is historical in | |
872 | -- nature. Warnings for IN OUT formals were added fairly late. | |
873 | ||
874 | if Ekind (E1) = E_In_Out_Parameter | |
875 | and then not Check_Unreferenced_Formals | |
876 | then | |
877 | return; | |
878 | end if; | |
879 | ||
d6f39728 | 880 | -- Other than accept case, post error on defining identifier |
881 | ||
882 | if No (Anod) then | |
883 | Error_Msg_N (M, E1); | |
884 | ||
885 | -- Accept case, find body formal to post the message | |
886 | ||
887 | else | |
8063f750 | 888 | Error_Msg_NE (M, Body_Formal (E1, Accept_Statement => Anod), E1); |
d6f39728 | 889 | |
d6f39728 | 890 | end if; |
891 | end Output_Reference_Error; | |
892 | ||
893 | ---------------------------- | |
894 | -- Publicly_Referenceable -- | |
895 | ---------------------------- | |
896 | ||
897 | function Publicly_Referenceable (Ent : Entity_Id) return Boolean is | |
9dfe12ae | 898 | P : Node_Id; |
899 | Prev : Node_Id; | |
d6f39728 | 900 | |
901 | begin | |
8063f750 | 902 | -- A formal parameter is never referenceable outside the body of its |
903 | -- subprogram or entry. | |
904 | ||
905 | if Is_Formal (Ent) then | |
906 | return False; | |
907 | end if; | |
908 | ||
c5797b4f | 909 | -- Examine parents to look for a library level package spec. But if |
910 | -- we find a body or block or other similar construct along the way, | |
911 | -- we cannot be referenced. | |
d6f39728 | 912 | |
9dfe12ae | 913 | Prev := Ent; |
914 | P := Parent (Ent); | |
f15731c4 | 915 | loop |
916 | case Nkind (P) is | |
d6f39728 | 917 | |
9dfe12ae | 918 | -- If we get to top of tree, then publicly referenceable |
d6f39728 | 919 | |
f15731c4 | 920 | when N_Empty => |
921 | return True; | |
d6f39728 | 922 | |
f15731c4 | 923 | -- If we reach a generic package declaration, then always |
924 | -- consider this referenceable, since any instantiation will | |
925 | -- have access to the entities in the generic package. Note | |
926 | -- that the package itself may not be instantiated, but then | |
c5797b4f | 927 | -- we will get a warning for the package entity. |
928 | ||
9dfe12ae | 929 | -- Note that generic formal parameters are themselves not |
8063f750 | 930 | -- publicly referenceable in an instance, and warnings on them |
931 | -- are useful. | |
d6f39728 | 932 | |
f15731c4 | 933 | when N_Generic_Package_Declaration => |
9dfe12ae | 934 | return |
935 | not Is_List_Member (Prev) | |
936 | or else List_Containing (Prev) | |
937 | /= Generic_Formal_Declarations (P); | |
938 | ||
8063f750 | 939 | -- Similarly, the generic formals of a generic subprogram are |
940 | -- not accessible. | |
84731ab2 | 941 | |
942 | when N_Generic_Subprogram_Declaration => | |
943 | if Is_List_Member (Prev) | |
944 | and then List_Containing (Prev) = | |
945 | Generic_Formal_Declarations (P) | |
946 | then | |
947 | return False; | |
948 | else | |
949 | P := Parent (P); | |
950 | end if; | |
951 | ||
952 | -- If we reach a subprogram body, entity is not referenceable | |
9dfe12ae | 953 | -- unless it is the defining entity of the body. This will |
954 | -- happen, e.g. when a function is an attribute renaming that | |
955 | -- is rewritten as a body. | |
956 | ||
957 | when N_Subprogram_Body => | |
958 | if Ent /= Defining_Entity (P) then | |
959 | return False; | |
960 | else | |
961 | P := Parent (P); | |
962 | end if; | |
f15731c4 | 963 | |
9dfe12ae | 964 | -- If we reach any other body, definitely not referenceable |
f15731c4 | 965 | |
966 | when N_Package_Body | | |
f15731c4 | 967 | N_Task_Body | |
968 | N_Entry_Body | | |
969 | N_Protected_Body | | |
970 | N_Block_Statement | | |
971 | N_Subunit => | |
972 | return False; | |
973 | ||
974 | -- For all other cases, keep looking up tree | |
975 | ||
976 | when others => | |
9dfe12ae | 977 | Prev := P; |
978 | P := Parent (P); | |
f15731c4 | 979 | end case; |
d6f39728 | 980 | end loop; |
981 | end Publicly_Referenceable; | |
982 | ||
059bd36a | 983 | --------------------- |
984 | -- Warnings_Off_E1 -- | |
985 | --------------------- | |
986 | ||
987 | function Warnings_Off_E1 return Boolean is | |
988 | begin | |
989 | return Has_Warnings_Off (E1T) | |
990 | or else Has_Warnings_Off (Base_Type (E1T)) | |
991 | or else Warnings_Off_Check_Spec (E1); | |
992 | end Warnings_Off_E1; | |
993 | ||
d6f39728 | 994 | -- Start of processing for Check_References |
995 | ||
996 | begin | |
c5797b4f | 997 | -- No messages if warnings are suppressed, or if we have detected any |
998 | -- real errors so far (this last check avoids junk messages resulting | |
999 | -- from errors, e.g. a subunit that is not loaded). | |
d6f39728 | 1000 | |
9dfe12ae | 1001 | if Warning_Mode = Suppress |
1002 | or else Serious_Errors_Detected /= 0 | |
1003 | then | |
1004 | return; | |
1005 | end if; | |
1006 | ||
d6f39728 | 1007 | -- We also skip the messages if any subunits were not loaded (see |
1008 | -- comment in Sem_Ch10 to understand how this is set, and why it is | |
1009 | -- necessary to suppress the warnings in this case). | |
1010 | ||
9dfe12ae | 1011 | if Missing_Subunits then |
d6f39728 | 1012 | return; |
1013 | end if; | |
1014 | ||
1015 | -- Otherwise loop through entities, looking for suspicious stuff | |
1016 | ||
1017 | E1 := First_Entity (E); | |
1018 | while Present (E1) loop | |
4540a696 | 1019 | E1T := Etype (E1); |
d6f39728 | 1020 | |
059bd36a | 1021 | -- We are only interested in source entities. We also don't issue |
1022 | -- warnings within instances, since the proper place for such | |
1023 | -- warnings is on the template when it is compiled. | |
d6f39728 | 1024 | |
8255b799 | 1025 | if Comes_From_Source (E1) |
4540a696 | 1026 | and then Instantiation_Location (Sloc (E1)) = No_Location |
8255b799 | 1027 | then |
8063f750 | 1028 | -- We are interested in variables and out/in-out parameters, but |
1029 | -- we exclude protected types, too complicated to worry about. | |
d6f39728 | 1030 | |
1031 | if Ekind (E1) = E_Variable | |
67278d60 | 1032 | or else |
1033 | (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter) | |
d6f39728 | 1034 | and then not Is_Protected_Type (Current_Scope)) |
1035 | then | |
8063f750 | 1036 | -- Case of an unassigned variable |
1037 | ||
1038 | -- First gather any Unset_Reference indication for E1. In the | |
1039 | -- case of a parameter, it is the Spec_Entity that is relevant. | |
9dfe12ae | 1040 | |
d24d7e81 | 1041 | if Ekind (E1) = E_Out_Parameter |
1042 | and then Present (Spec_Entity (E1)) | |
1043 | then | |
1044 | UR := Unset_Reference (Spec_Entity (E1)); | |
1045 | else | |
1046 | UR := Unset_Reference (E1); | |
1047 | end if; | |
1048 | ||
4540a696 | 1049 | -- Special processing for access types |
1050 | ||
059bd36a | 1051 | if Present (UR) |
4540a696 | 1052 | and then Is_Access_Type (E1T) |
d24d7e81 | 1053 | then |
c5797b4f | 1054 | -- For access types, the only time we made a UR entry was |
1055 | -- for a dereference, and so we post the appropriate warning | |
1056 | -- here (note that the dereference may not be explicit in | |
1057 | -- the source, for example in the case of a dispatching call | |
1058 | -- with an anonymous access controlling formal, or of an | |
6d94f7f9 | 1059 | -- assignment of a pointer involving discriminant check on |
1060 | -- the designated object). | |
d24d7e81 | 1061 | |
059bd36a | 1062 | if not Warnings_Off_E1 then |
1063 | Error_Msg_NE ("?& may be null!", UR, E1); | |
1064 | end if; | |
1065 | ||
d6f39728 | 1066 | goto Continue; |
9dfe12ae | 1067 | |
1068 | -- Case of variable that could be a constant. Note that we | |
1069 | -- never signal such messages for generic package entities, | |
1070 | -- since a given instance could have modifications outside | |
1071 | -- the package. | |
1072 | ||
1073 | elsif Warn_On_Constant | |
4540a696 | 1074 | and then (Ekind (E1) = E_Variable |
1075 | and then Has_Initial_Value (E1)) | |
8063f750 | 1076 | and then Never_Set_In_Source_Check_Spec (E1) |
1077 | and then not Address_Taken (E1) | |
9dfe12ae | 1078 | and then not Generic_Package_Spec_Entity (E1) |
1079 | then | |
84731ab2 | 1080 | -- A special case, if this variable is volatile and not |
1081 | -- imported, it is not helpful to tell the programmer | |
1082 | -- to mark the variable as constant, since this would be | |
1083 | -- illegal by virtue of RM C.6(13). | |
1084 | ||
1085 | if (Is_Volatile (E1) or else Has_Volatile_Components (E1)) | |
1086 | and then not Is_Imported (E1) | |
1087 | then | |
503f7fd3 | 1088 | Error_Msg_N |
8063f750 | 1089 | ("?& is not modified, volatile has no effect!", E1); |
1090 | ||
1091 | -- Another special case, Exception_Occurrence, this catches | |
1092 | -- the case of exception choice (and a bit more too, but not | |
1093 | -- worth doing more investigation here). | |
1094 | ||
4540a696 | 1095 | elsif Is_RTE (E1T, RE_Exception_Occurrence) then |
8063f750 | 1096 | null; |
1097 | ||
1098 | -- Here we give the warning if referenced and no pragma | |
4540a696 | 1099 | -- Unreferenced or Unmodified is present. |
8063f750 | 1100 | |
84731ab2 | 1101 | else |
4540a696 | 1102 | -- Variable case |
1103 | ||
8063f750 | 1104 | if Ekind (E1) = E_Variable then |
1105 | if Referenced_Check_Spec (E1) | |
1106 | and then not Has_Pragma_Unreferenced_Check_Spec (E1) | |
4540a696 | 1107 | and then not Has_Pragma_Unmodified_Check_Spec (E1) |
8063f750 | 1108 | then |
059bd36a | 1109 | if not Warnings_Off_E1 then |
3ba6a78b | 1110 | Error_Msg_N -- CODEFIX |
059bd36a | 1111 | ("?& is not modified, " |
1112 | & "could be declared constant!", | |
1113 | E1); | |
1114 | end if; | |
8063f750 | 1115 | end if; |
8063f750 | 1116 | end if; |
1117 | end if; | |
1118 | ||
4540a696 | 1119 | -- Other cases of a variable or parameter never set in source |
8063f750 | 1120 | |
1121 | elsif Never_Set_In_Source_Check_Spec (E1) | |
1122 | ||
1123 | -- No warning if warning for this case turned off | |
1124 | ||
1125 | and then Warn_On_No_Value_Assigned | |
1126 | ||
1127 | -- No warning if address taken somewhere | |
1128 | ||
1129 | and then not Address_Taken (E1) | |
1130 | ||
1131 | -- No warning if explicit initial value | |
1132 | ||
1133 | and then not Has_Initial_Value (E1) | |
1134 | ||
1135 | -- No warning for generic package spec entities, since we | |
1136 | -- might set them in a child unit or something like that | |
1137 | ||
1138 | and then not Generic_Package_Spec_Entity (E1) | |
1139 | ||
1140 | -- No warning if fully initialized type, except that for | |
1141 | -- this purpose we do not consider access types to qualify | |
1142 | -- as fully initialized types (relying on an access type | |
1143 | -- variable being null when it is never set is a bit odd!) | |
1144 | ||
1145 | -- Also we generate warning for an out parameter that is | |
1146 | -- never referenced, since again it seems odd to rely on | |
1147 | -- default initialization to set an out parameter value. | |
1148 | ||
4540a696 | 1149 | and then (Is_Access_Type (E1T) |
8063f750 | 1150 | or else Ekind (E1) = E_Out_Parameter |
4540a696 | 1151 | or else not Is_Fully_Initialized_Type (E1T)) |
8063f750 | 1152 | then |
1153 | -- Do not output complaint about never being assigned a | |
059bd36a | 1154 | -- value if a pragma Unmodified applies to the variable |
8063f750 | 1155 | -- we are examining, or if it is a parameter, if there is |
a57388e5 | 1156 | -- a pragma Unreferenced for the corresponding spec, or |
059bd36a | 1157 | -- if the type is marked as having unreferenced objects. |
1158 | -- The last is a little peculiar, but better too few than | |
1159 | -- too many warnings in this situation. | |
8063f750 | 1160 | |
059bd36a | 1161 | if Has_Pragma_Unreferenced_Objects (E1T) |
1162 | or else Has_Pragma_Unmodified_Check_Spec (E1) | |
8063f750 | 1163 | then |
1164 | null; | |
1165 | ||
4540a696 | 1166 | -- IN OUT parameter case where parameter is referenced. We |
1167 | -- separate this out, since this is the case where we delay | |
1168 | -- output of the warning until more information is available | |
1169 | -- (about use in an instantiation or address being taken). | |
1170 | ||
1171 | elsif Ekind (E1) = E_In_Out_Parameter | |
1172 | and then Referenced_Check_Spec (E1) | |
1173 | then | |
1174 | -- Suppress warning if private type, and the procedure | |
1175 | -- has a separate declaration in a different unit. This | |
1176 | -- is the case where the client of a package sees only | |
bf3e1520 | 1177 | -- the private type, and it may be quite reasonable |
a57388e5 | 1178 | -- for the logical view to be IN OUT, even if the |
4540a696 | 1179 | -- implementation ends up using access types or some |
1180 | -- other method to achieve the local effect of a | |
1181 | -- modification. On the other hand if the spec and body | |
1182 | -- are in the same unit, we are in the package body and | |
059bd36a | 1183 | -- there we have less excuse for a junk IN OUT parameter. |
4540a696 | 1184 | |
1185 | if Has_Private_Declaration (E1T) | |
1186 | and then Present (Spec_Entity (E1)) | |
1187 | and then not In_Same_Source_Unit (E1, Spec_Entity (E1)) | |
1188 | then | |
1189 | null; | |
1190 | ||
1191 | -- Suppress warning for any parameter of a dispatching | |
1192 | -- operation, since it is quite reasonable to have an | |
1193 | -- operation that is overridden, and for some subclasses | |
059bd36a | 1194 | -- needs the formal to be IN OUT and for others happens |
1195 | -- not to assign it. | |
4540a696 | 1196 | |
1197 | elsif Is_Dispatching_Operation | |
1198 | (Scope (Goto_Spec_Entity (E1))) | |
1199 | then | |
1200 | null; | |
1201 | ||
a57388e5 | 1202 | -- Suppress warning if composite type contains any access |
1203 | -- component, since the logical effect of modifying a | |
1204 | -- parameter may be achieved by modifying a referenced | |
1205 | -- object. | |
4540a696 | 1206 | |
1207 | elsif Is_Composite_Type (E1T) | |
1208 | and then Has_Access_Values (E1T) | |
1209 | then | |
1210 | null; | |
1211 | ||
865909d3 | 1212 | -- Suppress warning on formals of an entry body. All |
1213 | -- references are attached to the formal in the entry | |
1214 | -- declaration, which are marked Is_Entry_Formal. | |
1215 | ||
1216 | elsif Ekind (Scope (E1)) = E_Entry | |
1217 | and then not Is_Entry_Formal (E1) | |
1218 | then | |
1219 | null; | |
1220 | ||
4540a696 | 1221 | -- OK, looks like warning for an IN OUT parameter that |
1222 | -- could be IN makes sense, but we delay the output of | |
1223 | -- the warning, pending possibly finding out later on | |
1224 | -- that the associated subprogram is used as a generic | |
1225 | -- actual, or its address/access is taken. In these two | |
1226 | -- cases, we suppress the warning because the context may | |
1227 | -- force use of IN OUT, even if in this particular case | |
1a34e48c | 1228 | -- the formal is not modified. |
4540a696 | 1229 | |
1230 | else | |
1231 | In_Out_Warnings.Append (E1); | |
1232 | end if; | |
1233 | ||
1234 | -- Other cases of formals | |
8063f750 | 1235 | |
1236 | elsif Is_Formal (E1) then | |
059bd36a | 1237 | if not Is_Trivial_Subprogram (Scope (E1)) then |
1238 | if Referenced_Check_Spec (E1) then | |
1239 | if not Has_Pragma_Unmodified_Check_Spec (E1) | |
1240 | and then not Warnings_Off_E1 | |
1241 | then | |
1242 | Output_Reference_Error | |
1243 | ("?formal parameter& is read but " | |
1244 | & "never assigned!"); | |
1245 | end if; | |
1246 | ||
1247 | elsif not Has_Pragma_Unreferenced_Check_Spec (E1) | |
1248 | and then not Warnings_Off_E1 | |
1249 | then | |
4540a696 | 1250 | Output_Reference_Error |
059bd36a | 1251 | ("?formal parameter& is not referenced!"); |
4540a696 | 1252 | end if; |
8063f750 | 1253 | end if; |
1254 | ||
1255 | -- Case of variable | |
1256 | ||
1257 | else | |
1258 | if Referenced (E1) then | |
059bd36a | 1259 | if not Has_Unmodified (E1) |
1260 | and then not Warnings_Off_E1 | |
1261 | then | |
1262 | Output_Reference_Error | |
1263 | ("?variable& is read but never assigned!"); | |
1264 | end if; | |
1265 | ||
1266 | elsif not Has_Unreferenced (E1) | |
1267 | and then not Warnings_Off_E1 | |
1268 | then | |
3ba6a78b | 1269 | Output_Reference_Error -- CODEFIX |
8063f750 | 1270 | ("?variable& is never read and never assigned!"); |
1271 | end if; | |
1272 | ||
ed683f94 | 1273 | -- Deal with special case where this variable is hidden |
1274 | -- by a loop variable. | |
8063f750 | 1275 | |
1276 | if Ekind (E1) = E_Variable | |
1277 | and then Present (Hiding_Loop_Variable (E1)) | |
059bd36a | 1278 | and then not Warnings_Off_E1 |
8063f750 | 1279 | then |
503f7fd3 | 1280 | Error_Msg_N |
8063f750 | 1281 | ("?for loop implicitly declares loop variable!", |
1282 | Hiding_Loop_Variable (E1)); | |
1283 | ||
1284 | Error_Msg_Sloc := Sloc (E1); | |
1285 | Error_Msg_N | |
1286 | ("\?declaration hides & declared#!", | |
1287 | Hiding_Loop_Variable (E1)); | |
1288 | end if; | |
84731ab2 | 1289 | end if; |
8063f750 | 1290 | |
1291 | goto Continue; | |
d6f39728 | 1292 | end if; |
1293 | ||
8063f750 | 1294 | -- Check for unset reference |
d6f39728 | 1295 | |
9dfe12ae | 1296 | if Warn_On_No_Value_Assigned and then Present (UR) then |
d6f39728 | 1297 | |
8063f750 | 1298 | -- For other than access type, go back to original node to |
1299 | -- deal with case where original unset reference has been | |
1300 | -- rewritten during expansion. | |
d6f39728 | 1301 | |
8063f750 | 1302 | -- In some cases, the original node may be a type conversion |
1303 | -- or qualification, and in this case we want the object | |
1304 | -- entity inside. | |
d24d7e81 | 1305 | |
8063f750 | 1306 | UR := Original_Node (UR); |
d24d7e81 | 1307 | while Nkind (UR) = N_Type_Conversion |
1308 | or else Nkind (UR) = N_Qualified_Expression | |
1309 | loop | |
1310 | UR := Expression (UR); | |
1311 | end loop; | |
1312 | ||
8063f750 | 1313 | -- Here we issue the warning, all checks completed |
1314 | ||
1315 | -- If we have a return statement, this was a case of an OUT | |
1316 | -- parameter not being set at the time of the return. (Note: | |
1317 | -- it can't be N_Extended_Return_Statement, because those | |
1318 | -- are only for functions, and functions do not allow OUT | |
1319 | -- parameters.) | |
1320 | ||
059bd36a | 1321 | if not Is_Trivial_Subprogram (Scope (E1)) then |
1322 | if Nkind (UR) = N_Simple_Return_Statement | |
1323 | and then not Has_Pragma_Unmodified_Check_Spec (E1) | |
1324 | then | |
1325 | if not Warnings_Off_E1 then | |
1326 | Error_Msg_NE | |
1327 | ("?OUT parameter& not set before return", UR, E1); | |
1328 | end if; | |
8063f750 | 1329 | |
059bd36a | 1330 | -- If the unset reference is a selected component |
1331 | -- prefix from source, mention the component as well. | |
1332 | -- If the selected component comes from expansion, all | |
1333 | -- we know is that the entity is not fully initialized | |
1334 | -- at the point of the reference. Locate a random | |
1a34e48c | 1335 | -- uninitialized component to get a better message. |
d24d7e81 | 1336 | |
059bd36a | 1337 | elsif Nkind (Parent (UR)) = N_Selected_Component then |
1338 | Error_Msg_Node_2 := Selector_Name (Parent (UR)); | |
d24d7e81 | 1339 | |
059bd36a | 1340 | if not Comes_From_Source (Parent (UR)) then |
1341 | declare | |
1342 | Comp : Entity_Id; | |
d24d7e81 | 1343 | |
059bd36a | 1344 | begin |
1345 | Comp := First_Entity (E1T); | |
1346 | while Present (Comp) loop | |
1347 | if Ekind (Comp) = E_Component | |
1348 | and then Nkind (Parent (Comp)) = | |
67278d60 | 1349 | N_Component_Declaration |
059bd36a | 1350 | and then No (Expression (Parent (Comp))) |
1351 | then | |
1352 | Error_Msg_Node_2 := Comp; | |
1353 | exit; | |
1354 | end if; | |
1355 | ||
1356 | Next_Entity (Comp); | |
1357 | end loop; | |
1358 | end; | |
1359 | end if; | |
d24d7e81 | 1360 | |
059bd36a | 1361 | -- Issue proper warning. This is a case of referencing |
1362 | -- a variable before it has been explicitly assigned. | |
1363 | -- For access types, UR was only set for dereferences, | |
1364 | -- so the issue is that the value may be null. | |
1365 | ||
1366 | if not Is_Trivial_Subprogram (Scope (E1)) then | |
1367 | if not Warnings_Off_E1 then | |
1368 | if Is_Access_Type (Etype (Parent (UR))) then | |
1369 | Error_Msg_N ("?`&.&` may be null!", UR); | |
1370 | else | |
1371 | Error_Msg_N | |
1372 | ("?`&.&` may be referenced before " | |
1373 | & "it has a value!", UR); | |
1374 | end if; | |
1375 | end if; | |
1376 | end if; | |
9dfe12ae | 1377 | |
059bd36a | 1378 | -- All other cases of unset reference active |
8063f750 | 1379 | |
059bd36a | 1380 | elsif not Warnings_Off_E1 then |
8063f750 | 1381 | Error_Msg_N |
059bd36a | 1382 | ("?& may be referenced before it has a value!", |
8063f750 | 1383 | UR); |
1384 | end if; | |
d6f39728 | 1385 | end if; |
d24d7e81 | 1386 | |
1387 | goto Continue; | |
d6f39728 | 1388 | end if; |
1389 | end if; | |
1390 | ||
9dfe12ae | 1391 | -- Then check for unreferenced entities. Note that we are only |
059bd36a | 1392 | -- interested in entities whose Referenced flag is not set. |
d6f39728 | 1393 | |
8063f750 | 1394 | if not Referenced_Check_Spec (E1) |
d6f39728 | 1395 | |
059bd36a | 1396 | -- If Referenced_As_LHS is set, then that's still interesting |
1397 | -- (potential "assigned but never read" case), but not if we | |
a57388e5 | 1398 | -- have pragma Unreferenced, which cancels this warning. |
059bd36a | 1399 | |
1400 | and then (not Referenced_As_LHS_Check_Spec (E1) | |
1401 | or else not Has_Unreferenced (E1)) | |
1402 | ||
f15731c4 | 1403 | -- Check that warnings on unreferenced entities are enabled |
d6f39728 | 1404 | |
ed683f94 | 1405 | and then |
1406 | ((Check_Unreferenced and then not Is_Formal (E1)) | |
1407 | ||
1408 | -- Case of warning on unreferenced formal | |
1409 | ||
1410 | or else | |
1411 | (Check_Unreferenced_Formals and then Is_Formal (E1)) | |
1412 | ||
1413 | -- Case of warning on unread variables modified by an | |
a57388e5 | 1414 | -- assignment, or an OUT parameter if it is the only one. |
ed683f94 | 1415 | |
1416 | or else | |
1417 | (Warn_On_Modified_Unread | |
1418 | and then Referenced_As_LHS_Check_Spec (E1)) | |
1419 | ||
a57388e5 | 1420 | -- Case of warning on any unread OUT parameter (note |
ed683f94 | 1421 | -- such indications are only set if the appropriate |
1422 | -- warning options were set, so no need to recheck here. | |
1423 | ||
1424 | or else | |
1425 | Referenced_As_Out_Parameter_Check_Spec (E1)) | |
d6f39728 | 1426 | |
8dbc27c6 | 1427 | -- All other entities, including local packages that cannot be |
c5797b4f | 1428 | -- referenced from elsewhere, including those declared within a |
1429 | -- package body. | |
d6f39728 | 1430 | |
1431 | and then (Is_Object (E1) | |
1432 | or else | |
1433 | Is_Type (E1) | |
1434 | or else | |
1435 | Ekind (E1) = E_Label | |
1436 | or else | |
9dfe12ae | 1437 | Ekind (E1) = E_Exception |
1438 | or else | |
d6f39728 | 1439 | Ekind (E1) = E_Named_Integer |
1440 | or else | |
1441 | Ekind (E1) = E_Named_Real | |
1442 | or else | |
9dfe12ae | 1443 | Is_Overloadable (E1) |
e6d588f0 | 1444 | |
a57388e5 | 1445 | -- Package case, if the main unit is a package spec |
1446 | -- or generic package spec, then there may be a | |
1447 | -- corresponding body that references this package | |
1448 | -- in some other file. Otherwise we can be sure | |
1449 | -- that there is no other reference. | |
e6d588f0 | 1450 | |
9dfe12ae | 1451 | or else |
1452 | (Ekind (E1) = E_Package | |
e6d588f0 | 1453 | and then |
65149aa0 | 1454 | not Is_Package_Or_Generic_Package |
7ab0189d | 1455 | (Cunit_Entity (Current_Sem_Unit)))) |
d6f39728 | 1456 | |
c5797b4f | 1457 | -- Exclude instantiations, since there is no reason why every |
1458 | -- entity in an instantiation should be referenced. | |
d6f39728 | 1459 | |
1460 | and then Instantiation_Location (Sloc (E1)) = No_Location | |
1461 | ||
f15731c4 | 1462 | -- Exclude formal parameters from bodies if the corresponding |
1463 | -- spec entity has been referenced in the case where there is | |
1464 | -- a separate spec. | |
d6f39728 | 1465 | |
f15731c4 | 1466 | and then not (Is_Formal (E1) |
e977c0cf | 1467 | and then Ekind (Scope (E1)) = E_Subprogram_Body |
1468 | and then Present (Spec_Entity (E1)) | |
1469 | and then Referenced (Spec_Entity (E1))) | |
d6f39728 | 1470 | |
a57388e5 | 1471 | -- Consider private type referenced if full view is referenced. |
9dfe12ae | 1472 | -- If there is not full view, this is a generic type on which |
1473 | -- warnings are also useful. | |
d6f39728 | 1474 | |
9dfe12ae | 1475 | and then |
1476 | not (Is_Private_Type (E1) | |
e977c0cf | 1477 | and then Present (Full_View (E1)) |
9dfe12ae | 1478 | and then Referenced (Full_View (E1))) |
d6f39728 | 1479 | |
1480 | -- Don't worry about full view, only about private type | |
1481 | ||
1482 | and then not Has_Private_Declaration (E1) | |
1483 | ||
1484 | -- Eliminate dispatching operations from consideration, we | |
1485 | -- cannot tell if these are referenced or not in any easy | |
a57388e5 | 1486 | -- manner (note this also catches Adjust/Finalize/Initialize). |
d6f39728 | 1487 | |
1488 | and then not Is_Dispatching_Operation (E1) | |
1489 | ||
c5797b4f | 1490 | -- Check entity that can be publicly referenced (we do not give |
1491 | -- messages for such entities, since there could be other | |
1492 | -- units, not involved in this compilation, that contain | |
1493 | -- relevant references. | |
d6f39728 | 1494 | |
1495 | and then not Publicly_Referenceable (E1) | |
1496 | ||
c5797b4f | 1497 | -- Class wide types are marked as source entities, but they are |
1498 | -- not really source entities, and are always created, so we do | |
1499 | -- not care if they are not referenced. | |
d6f39728 | 1500 | |
1501 | and then Ekind (E1) /= E_Class_Wide_Type | |
1502 | ||
c5797b4f | 1503 | -- Objects other than parameters of task types are allowed to |
1504 | -- be non-referenced, since they start up tasks! | |
d6f39728 | 1505 | |
1506 | and then ((Ekind (E1) /= E_Variable | |
e977c0cf | 1507 | and then Ekind (E1) /= E_Constant |
1508 | and then Ekind (E1) /= E_Component) | |
1509 | or else not Is_Task_Type (E1T)) | |
f15731c4 | 1510 | |
c5797b4f | 1511 | -- For subunits, only place warnings on the main unit itself, |
a57388e5 | 1512 | -- since parent units are not completely compiled. |
f15731c4 | 1513 | |
1514 | and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit | |
e977c0cf | 1515 | or else Get_Source_Unit (E1) = Main_Unit) |
8255b799 | 1516 | |
1517 | -- No warning on a return object, because these are often | |
1518 | -- created with a single expression and an implicit return. | |
1519 | -- If the object is a variable there will be a warning | |
1520 | -- indicating that it could be declared constant. | |
1521 | ||
1522 | and then not | |
1523 | (Ekind (E1) = E_Constant and then Is_Return_Object (E1)) | |
d6f39728 | 1524 | then |
c5797b4f | 1525 | -- Suppress warnings in internal units if not in -gnatg mode |
1526 | -- (these would be junk warnings for an applications program, | |
a57388e5 | 1527 | -- since they refer to problems in internal units). |
d6f39728 | 1528 | |
1529 | if GNAT_Mode | |
e977c0cf | 1530 | or else not Is_Internal_File_Name |
1531 | (Unit_File_Name (Get_Source_Unit (E1))) | |
d6f39728 | 1532 | then |
c5797b4f | 1533 | -- We do not immediately flag the error. This is because we |
1534 | -- have not expanded generic bodies yet, and they may have | |
1535 | -- the missing reference. So instead we park the entity on a | |
8063f750 | 1536 | -- list, for later processing. However for the case of an |
1537 | -- accept statement we want to output messages now, since | |
1538 | -- we know we already have all information at hand, and we | |
1539 | -- also want to have separate warnings for each accept | |
1540 | -- statement for the same entry. | |
d6f39728 | 1541 | |
1542 | if Present (Anod) then | |
8063f750 | 1543 | pragma Assert (Is_Formal (E1)); |
1544 | ||
1545 | -- The unreferenced entity is E1, but post the warning | |
1546 | -- on the body entity for this accept statement. | |
1547 | ||
059bd36a | 1548 | if not Warnings_Off_E1 then |
1549 | Warn_On_Unreferenced_Entity | |
1550 | (E1, Body_Formal (E1, Accept_Statement => Anod)); | |
1551 | end if; | |
d6f39728 | 1552 | |
059bd36a | 1553 | elsif not Warnings_Off_E1 then |
8063f750 | 1554 | Unreferenced_Entities.Append (E1); |
d6f39728 | 1555 | end if; |
1556 | end if; | |
9dfe12ae | 1557 | |
c5797b4f | 1558 | -- Generic units are referenced in the generic body, but if they |
1559 | -- are not public and never instantiated we want to force a | |
1560 | -- warning on them. We treat them as redundant constructs to | |
1561 | -- minimize noise. | |
9dfe12ae | 1562 | |
1563 | elsif Is_Generic_Subprogram (E1) | |
1564 | and then not Is_Instantiated (E1) | |
1565 | and then not Publicly_Referenceable (E1) | |
1566 | and then Instantiation_Depth (Sloc (E1)) = 0 | |
1567 | and then Warn_On_Redundant_Constructs | |
1568 | then | |
059bd36a | 1569 | if not Warnings_Off_E1 then |
1570 | Unreferenced_Entities.Append (E1); | |
9dfe12ae | 1571 | |
8dbc27c6 | 1572 | -- Force warning on entity |
9dfe12ae | 1573 | |
059bd36a | 1574 | Set_Referenced (E1, False); |
1575 | end if; | |
d6f39728 | 1576 | end if; |
1577 | end if; | |
1578 | ||
a57388e5 | 1579 | -- Recurse into nested package or block. Do not recurse into a formal |
1580 | -- package, because the corresponding body is not analyzed. | |
d6f39728 | 1581 | |
1582 | <<Continue>> | |
65149aa0 | 1583 | if (Is_Package_Or_Generic_Package (E1) |
9dfe12ae | 1584 | and then Nkind (Parent (E1)) = N_Package_Specification |
1585 | and then | |
1586 | Nkind (Original_Node (Unit_Declaration_Node (E1))) | |
1587 | /= N_Formal_Package_Declaration) | |
1588 | ||
d6f39728 | 1589 | or else Ekind (E1) = E_Block |
1590 | then | |
1591 | Check_References (E1); | |
1592 | end if; | |
1593 | ||
1594 | Next_Entity (E1); | |
1595 | end loop; | |
1596 | end Check_References; | |
1597 | ||
1598 | --------------------------- | |
1599 | -- Check_Unset_Reference -- | |
1600 | --------------------------- | |
1601 | ||
1602 | procedure Check_Unset_Reference (N : Node_Id) is | |
8063f750 | 1603 | Typ : constant Entity_Id := Etype (N); |
1604 | ||
1605 | function Is_OK_Fully_Initialized return Boolean; | |
1606 | -- This function returns true if the given node N is fully initialized | |
1607 | -- so that the reference is safe as far as this routine is concerned. | |
1608 | -- Safe generally means that the type of N is a fully initialized type. | |
1609 | -- The one special case is that for access types, which are always fully | |
1610 | -- initialized, we don't consider a dereference OK since it will surely | |
1611 | -- be dereferencing a null value, which won't do. | |
1612 | ||
1613 | function Prefix_Has_Dereference (Pref : Node_Id) return Boolean; | |
1614 | -- Used to test indexed or selected component or slice to see if the | |
1615 | -- evaluation of the prefix depends on a dereference, and if so, returns | |
1616 | -- True, in which case we always check the prefix, even if we know that | |
1617 | -- the referenced component is initialized. Pref is the prefix to test. | |
1618 | ||
1619 | ----------------------------- | |
1620 | -- Is_OK_Fully_Initialized -- | |
1621 | ----------------------------- | |
1622 | ||
1623 | function Is_OK_Fully_Initialized return Boolean is | |
1624 | begin | |
1625 | if Is_Access_Type (Typ) and then Is_Dereferenced (N) then | |
1626 | return False; | |
1627 | else | |
1628 | return Is_Fully_Initialized_Type (Typ); | |
1629 | end if; | |
1630 | end Is_OK_Fully_Initialized; | |
1631 | ||
1632 | ---------------------------- | |
1633 | -- Prefix_Has_Dereference -- | |
1634 | ---------------------------- | |
1635 | ||
1636 | function Prefix_Has_Dereference (Pref : Node_Id) return Boolean is | |
1637 | begin | |
a57388e5 | 1638 | -- If prefix is of an access type, it certainly needs a dereference |
8063f750 | 1639 | |
1640 | if Is_Access_Type (Etype (Pref)) then | |
1641 | return True; | |
1642 | ||
1643 | -- If prefix is explicit dereference, that's a dereference for sure | |
1644 | ||
1645 | elsif Nkind (Pref) = N_Explicit_Dereference then | |
1646 | return True; | |
1647 | ||
1648 | -- If prefix is itself a component reference or slice check prefix | |
1649 | ||
1650 | elsif Nkind (Pref) = N_Slice | |
1651 | or else Nkind (Pref) = N_Indexed_Component | |
1652 | or else Nkind (Pref) = N_Selected_Component | |
1653 | then | |
1654 | return Prefix_Has_Dereference (Prefix (Pref)); | |
1655 | ||
1656 | -- All other cases do not involve a dereference | |
1657 | ||
1658 | else | |
1659 | return False; | |
1660 | end if; | |
1661 | end Prefix_Has_Dereference; | |
1662 | ||
1663 | -- Start of processing for Check_Unset_Reference | |
1664 | ||
d6f39728 | 1665 | begin |
1666 | -- Nothing to do if warnings suppressed | |
1667 | ||
1668 | if Warning_Mode = Suppress then | |
1669 | return; | |
1670 | end if; | |
1671 | ||
8063f750 | 1672 | -- Ignore reference unless it comes from source. Almost always if we |
1673 | -- have a reference from generated code, it is bogus (e.g. calls to init | |
1674 | -- procs to set default discriminant values). | |
9dfe12ae | 1675 | |
8063f750 | 1676 | if not Comes_From_Source (N) then |
9dfe12ae | 1677 | return; |
1678 | end if; | |
1679 | ||
a57388e5 | 1680 | -- Otherwise see what kind of node we have. If the entity already has an |
1681 | -- unset reference, it is not necessarily the earliest in the text, | |
1682 | -- because resolution of the prefix of selected components is completed | |
1683 | -- before the resolution of the selected component itself. As a result, | |
1684 | -- given (R /= null and then R.X > 0), the occurrences of R are examined | |
1685 | -- in right-to-left order. If there is already an unset reference, we | |
1686 | -- check whether N is earlier before proceeding. | |
d6f39728 | 1687 | |
1688 | case Nkind (N) is | |
8063f750 | 1689 | |
1a34e48c | 1690 | -- For identifier or expanded name, examine the entity involved |
8063f750 | 1691 | |
d6f39728 | 1692 | when N_Identifier | N_Expanded_Name => |
1693 | declare | |
9dfe12ae | 1694 | E : constant Entity_Id := Entity (N); |
d6f39728 | 1695 | |
1696 | begin | |
1697 | if (Ekind (E) = E_Variable | |
8063f750 | 1698 | or else |
1699 | Ekind (E) = E_Out_Parameter) | |
1700 | and then Never_Set_In_Source_Check_Spec (E) | |
1701 | and then not Has_Initial_Value (E) | |
d6f39728 | 1702 | and then (No (Unset_Reference (E)) |
8063f750 | 1703 | or else |
1704 | Earlier_In_Extended_Unit | |
1705 | (Sloc (N), Sloc (Unset_Reference (E)))) | |
059bd36a | 1706 | and then not Has_Pragma_Unmodified_Check_Spec (E) |
1707 | and then not Warnings_Off_Check_Spec (E) | |
d6f39728 | 1708 | then |
c5797b4f | 1709 | -- We may have an unset reference. The first test is whether |
8063f750 | 1710 | -- this is an access to a discriminant of a record or a |
c5797b4f | 1711 | -- component with default initialization. Both of these |
1712 | -- cases can be ignored, since the actual object that is | |
1713 | -- referenced is definitely initialized. Note that this | |
a57388e5 | 1714 | -- covers the case of reading discriminants of an OUT |
c5797b4f | 1715 | -- parameter, which is OK even in Ada 83. |
1716 | ||
1717 | -- Note that we are only interested in a direct reference to | |
a57388e5 | 1718 | -- a record component here. If the reference is through an |
9dfe12ae | 1719 | -- access type, then the access object is being referenced, |
1720 | -- not the record, and still deserves an unset reference. | |
1721 | ||
1722 | if Nkind (Parent (N)) = N_Selected_Component | |
8063f750 | 1723 | and not Is_Access_Type (Typ) |
9dfe12ae | 1724 | then |
1725 | declare | |
1726 | ES : constant Entity_Id := | |
1727 | Entity (Selector_Name (Parent (N))); | |
9dfe12ae | 1728 | begin |
1729 | if Ekind (ES) = E_Discriminant | |
8063f750 | 1730 | or else |
1731 | (Present (Declaration_Node (ES)) | |
1732 | and then | |
1733 | Present (Expression (Declaration_Node (ES)))) | |
9dfe12ae | 1734 | then |
1735 | return; | |
1736 | end if; | |
1737 | end; | |
1738 | end if; | |
1739 | ||
8063f750 | 1740 | -- Exclude fully initialized types |
1741 | ||
1742 | if Is_OK_Fully_Initialized then | |
1743 | return; | |
1744 | end if; | |
1745 | ||
d6f39728 | 1746 | -- Here we have a potential unset reference. But before we |
1747 | -- get worried about it, we have to make sure that the | |
1748 | -- entity declaration is in the same procedure as the | |
c5797b4f | 1749 | -- reference, since if they are in separate procedures, then |
1750 | -- we have no idea about sequential execution. | |
d6f39728 | 1751 | |
c5797b4f | 1752 | -- The tests in the loop below catch all such cases, but do |
1753 | -- allow the reference to appear in a loop, block, or | |
d6f39728 | 1754 | -- package spec that is nested within the declaring scope. |
1755 | -- As always, it is possible to construct cases where the | |
1756 | -- warning is wrong, that is why it is a warning! | |
1757 | ||
2b523281 | 1758 | Potential_Unset_Reference : declare |
d6f39728 | 1759 | SR : Entity_Id; |
1760 | SE : constant Entity_Id := Scope (E); | |
1761 | ||
2b523281 | 1762 | function Within_Postcondition return Boolean; |
1763 | -- Returns True iff N is within a Precondition | |
1764 | ||
1765 | -------------------------- | |
1766 | -- Within_Postcondition -- | |
1767 | -------------------------- | |
1768 | ||
1769 | function Within_Postcondition return Boolean is | |
1770 | Nod : Node_Id; | |
1771 | ||
1772 | begin | |
1773 | Nod := Parent (N); | |
1774 | while Present (Nod) loop | |
1775 | if Nkind (Nod) = N_Pragma | |
1776 | and then Pragma_Name (Nod) = Name_Postcondition | |
1777 | then | |
1778 | return True; | |
1779 | end if; | |
1780 | ||
1781 | Nod := Parent (Nod); | |
1782 | end loop; | |
1783 | ||
1784 | return False; | |
1785 | end Within_Postcondition; | |
1786 | ||
1787 | -- Start of processing for Potential_Unset_Reference | |
1788 | ||
d6f39728 | 1789 | begin |
1790 | SR := Current_Scope; | |
1791 | while SR /= SE loop | |
1792 | if SR = Standard_Standard | |
1793 | or else Is_Subprogram (SR) | |
1794 | or else Is_Concurrent_Body (SR) | |
1795 | or else Is_Concurrent_Type (SR) | |
1796 | then | |
1797 | return; | |
1798 | end if; | |
1799 | ||
1800 | SR := Scope (SR); | |
1801 | end loop; | |
1802 | ||
a57388e5 | 1803 | -- Case of reference has an access type. This is a |
1804 | -- special case since access types are always set to null | |
1805 | -- so cannot be truly uninitialized, but we still want to | |
c5797b4f | 1806 | -- warn about cases of obvious null dereference. |
9dfe12ae | 1807 | |
8063f750 | 1808 | if Is_Access_Type (Typ) then |
c5797b4f | 1809 | Access_Type_Case : declare |
9dfe12ae | 1810 | P : Node_Id; |
1811 | ||
1812 | function Process | |
8063f750 | 1813 | (N : Node_Id) return Traverse_Result; |
1a34e48c | 1814 | -- Process function for instantiation of Traverse |
a57388e5 | 1815 | -- below. Checks if N contains reference to E other |
c5797b4f | 1816 | -- than a dereference. |
9dfe12ae | 1817 | |
1818 | function Ref_In (Nod : Node_Id) return Boolean; | |
c5797b4f | 1819 | -- Determines whether Nod contains a reference to |
1820 | -- the entity E that is not a dereference. | |
1821 | ||
1822 | ------------- | |
1823 | -- Process -- | |
1824 | ------------- | |
9dfe12ae | 1825 | |
1826 | function Process | |
8063f750 | 1827 | (N : Node_Id) return Traverse_Result |
9dfe12ae | 1828 | is |
1829 | begin | |
1830 | if Is_Entity_Name (N) | |
1831 | and then Entity (N) = E | |
1832 | and then not Is_Dereferenced (N) | |
1833 | then | |
1834 | return Abandon; | |
1835 | else | |
1836 | return OK; | |
1837 | end if; | |
1838 | end Process; | |
1839 | ||
c5797b4f | 1840 | ------------ |
1841 | -- Ref_In -- | |
1842 | ------------ | |
1843 | ||
9dfe12ae | 1844 | function Ref_In (Nod : Node_Id) return Boolean is |
1845 | function Traverse is new Traverse_Func (Process); | |
9dfe12ae | 1846 | begin |
1847 | return Traverse (Nod) = Abandon; | |
1848 | end Ref_In; | |
1849 | ||
c5797b4f | 1850 | -- Start of processing for Access_Type_Case |
1851 | ||
9dfe12ae | 1852 | begin |
8063f750 | 1853 | -- Don't bother if we are inside an instance, since |
1854 | -- the compilation of the generic template is where | |
1855 | -- the warning should be issued. | |
9dfe12ae | 1856 | |
1857 | if In_Instance then | |
1858 | return; | |
1859 | end if; | |
1860 | ||
8063f750 | 1861 | -- Don't bother if this is not the main unit. If we |
1862 | -- try to give this warning for with'ed units, we | |
1863 | -- get some false positives, since we do not record | |
1864 | -- references in other units. | |
9dfe12ae | 1865 | |
1866 | if not In_Extended_Main_Source_Unit (E) | |
1867 | or else | |
1868 | not In_Extended_Main_Source_Unit (N) | |
1869 | then | |
1870 | return; | |
1871 | end if; | |
1872 | ||
8255b799 | 1873 | -- We are only interested in dereferences |
9dfe12ae | 1874 | |
1875 | if not Is_Dereferenced (N) then | |
1876 | return; | |
1877 | end if; | |
1878 | ||
1879 | -- One more check, don't bother with references | |
a57388e5 | 1880 | -- that are inside conditional statements or WHILE |
9dfe12ae | 1881 | -- loops if the condition references the entity in |
1882 | -- question. This avoids most false positives. | |
1883 | ||
1884 | P := Parent (N); | |
1885 | loop | |
1886 | P := Parent (P); | |
1887 | exit when No (P); | |
1888 | ||
1889 | if (Nkind (P) = N_If_Statement | |
1890 | or else | |
1891 | Nkind (P) = N_Elsif_Part) | |
1892 | and then Ref_In (Condition (P)) | |
1893 | then | |
1894 | return; | |
1895 | ||
1896 | elsif Nkind (P) = N_Loop_Statement | |
1897 | and then Present (Iteration_Scheme (P)) | |
1898 | and then | |
1899 | Ref_In (Condition (Iteration_Scheme (P))) | |
1900 | then | |
1901 | return; | |
1902 | end if; | |
1903 | end loop; | |
c5797b4f | 1904 | end Access_Type_Case; |
9dfe12ae | 1905 | end if; |
1906 | ||
2b523281 | 1907 | -- One more check, don't bother if we are within a |
1908 | -- postcondition pragma, since the expression occurs | |
1909 | -- in a place unrelated to the actual test. | |
9dfe12ae | 1910 | |
2b523281 | 1911 | if not Within_Postcondition then |
9dfe12ae | 1912 | |
2b523281 | 1913 | -- Here we definitely have a case for giving a warning |
1914 | -- for a reference to an unset value. But we don't | |
1915 | -- give the warning now. Instead set Unset_Reference | |
1916 | -- in the identifier involved. The reason for this is | |
1917 | -- that if we find the variable is never ever assigned | |
1918 | -- a value then that warning is more important and | |
1919 | -- there is no point in giving the reference warning. | |
9dfe12ae | 1920 | |
2b523281 | 1921 | -- If this is an identifier, set the field directly |
9dfe12ae | 1922 | |
2b523281 | 1923 | if Nkind (N) = N_Identifier then |
1924 | Set_Unset_Reference (E, N); | |
1925 | ||
1926 | -- Otherwise it is an expanded name, so set the field | |
1927 | -- of the actual identifier for the reference. | |
1928 | ||
1929 | else | |
1930 | Set_Unset_Reference (E, Selector_Name (N)); | |
1931 | end if; | |
d6f39728 | 1932 | end if; |
2b523281 | 1933 | end Potential_Unset_Reference; |
d6f39728 | 1934 | end if; |
1935 | end; | |
1936 | ||
8063f750 | 1937 | -- Indexed component or slice |
1938 | ||
9dfe12ae | 1939 | when N_Indexed_Component | N_Slice => |
9dfe12ae | 1940 | |
8063f750 | 1941 | -- If prefix does not involve dereferencing an access type, then |
1942 | -- we know we are OK if the component type is fully initialized, | |
1943 | -- since the component will have been set as part of the default | |
1944 | -- initialization. | |
9dfe12ae | 1945 | |
8063f750 | 1946 | if not Prefix_Has_Dereference (Prefix (N)) |
1947 | and then Is_OK_Fully_Initialized | |
9dfe12ae | 1948 | then |
8063f750 | 1949 | return; |
9dfe12ae | 1950 | |
8063f750 | 1951 | -- Look at prefix in access type case, or if the component is not |
1952 | -- fully initialized. | |
9dfe12ae | 1953 | |
1954 | else | |
1955 | Check_Unset_Reference (Prefix (N)); | |
1956 | end if; | |
d6f39728 | 1957 | |
8063f750 | 1958 | -- Record component |
1959 | ||
1960 | when N_Selected_Component => | |
1961 | declare | |
1962 | Pref : constant Node_Id := Prefix (N); | |
1963 | Ent : constant Entity_Id := Entity (Selector_Name (N)); | |
1964 | ||
1965 | begin | |
1966 | -- If prefix involves dereferencing an access type, always | |
1967 | -- check the prefix, since the issue then is whether this | |
1968 | -- access value is null. | |
1969 | ||
1970 | if Prefix_Has_Dereference (Pref) then | |
1971 | null; | |
1972 | ||
1973 | -- Always go to prefix if no selector entity is set. Can this | |
1974 | -- happen in the normal case? Not clear, but it definitely can | |
1975 | -- happen in error cases. | |
1976 | ||
1977 | elsif No (Ent) then | |
1978 | null; | |
1979 | ||
1980 | -- For a record component, check some cases where we have | |
1981 | -- reasonable cause to consider that the component is known to | |
1982 | -- be or probably is initialized. In this case, we don't care | |
1983 | -- if the prefix itself was explicitly initialized. | |
1984 | ||
1985 | -- Discriminants are always considered initialized | |
1986 | ||
1987 | elsif Ekind (Ent) = E_Discriminant then | |
1988 | return; | |
1989 | ||
1990 | -- An explicitly initialized component is certainly initialized | |
1991 | ||
1992 | elsif Nkind (Parent (Ent)) = N_Component_Declaration | |
1993 | and then Present (Expression (Parent (Ent))) | |
1994 | then | |
1995 | return; | |
1996 | ||
1997 | -- A fully initialized component is initialized | |
1998 | ||
1999 | elsif Is_OK_Fully_Initialized then | |
2000 | return; | |
2001 | end if; | |
2002 | ||
2003 | -- If none of those cases apply, check the record type prefix | |
2004 | ||
2005 | Check_Unset_Reference (Pref); | |
2006 | end; | |
2007 | ||
2008 | -- For type conversions or qualifications examine the expression | |
2009 | ||
d6f39728 | 2010 | when N_Type_Conversion | N_Qualified_Expression => |
2011 | Check_Unset_Reference (Expression (N)); | |
2012 | ||
8063f750 | 2013 | -- For explicit dereference, always check prefix, which will generate |
2014 | -- an unset reference (since this is a case of dereferencing null). | |
2015 | ||
2016 | when N_Explicit_Dereference => | |
2017 | Check_Unset_Reference (Prefix (N)); | |
2018 | ||
2019 | -- All other cases are not cases of an unset reference | |
2020 | ||
d6f39728 | 2021 | when others => |
2022 | null; | |
2023 | ||
2024 | end case; | |
2025 | end Check_Unset_Reference; | |
2026 | ||
2027 | ------------------------ | |
2028 | -- Check_Unused_Withs -- | |
2029 | ------------------------ | |
2030 | ||
2031 | procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit) is | |
2032 | Cnode : Node_Id; | |
2033 | Item : Node_Id; | |
2034 | Lunit : Node_Id; | |
2035 | Ent : Entity_Id; | |
2036 | ||
2037 | Munite : constant Entity_Id := Cunit_Entity (Main_Unit); | |
2038 | -- This is needed for checking the special renaming case | |
2039 | ||
2040 | procedure Check_One_Unit (Unit : Unit_Number_Type); | |
2041 | -- Subsidiary procedure, performs checks for specified unit | |
2042 | ||
2043 | -------------------- | |
2044 | -- Check_One_Unit -- | |
2045 | -------------------- | |
2046 | ||
2047 | procedure Check_One_Unit (Unit : Unit_Number_Type) is | |
2048 | Is_Visible_Renaming : Boolean := False; | |
2049 | Pack : Entity_Id; | |
2050 | ||
9dfe12ae | 2051 | procedure Check_Inner_Package (Pack : Entity_Id); |
a57388e5 | 2052 | -- Pack is a package local to a unit in a with_clause. Both the unit |
2053 | -- and Pack are referenced. If none of the entities in Pack are | |
2054 | -- referenced, then the only occurrence of Pack is in a USE clause | |
2055 | -- or a pragma, and a warning is worthwhile as well. | |
9dfe12ae | 2056 | |
2057 | function Check_System_Aux return Boolean; | |
a57388e5 | 2058 | -- Before giving a warning on a with_clause for System, check wheter |
2059 | -- a system extension is present. | |
9dfe12ae | 2060 | |
d6f39728 | 2061 | function Find_Package_Renaming |
2062 | (P : Entity_Id; | |
2063 | L : Entity_Id) return Entity_Id; | |
2064 | -- The only reference to a context unit may be in a renaming | |
a57388e5 | 2065 | -- declaration. If this renaming declares a visible entity, do not |
2066 | -- warn that the context clause could be moved to the body, because | |
2067 | -- the renaming may be intended to re-export the unit. | |
d6f39728 | 2068 | |
284a54ba | 2069 | function Has_Visible_Entities (P : Entity_Id) return Boolean; |
6bc4e5b9 | 2070 | -- This function determines if a package has any visible entities. |
2071 | -- True is returned if there is at least one declared visible entity, | |
2072 | -- otherwise False is returned (e.g. case of only pragmas present). | |
284a54ba | 2073 | |
9dfe12ae | 2074 | ------------------------- |
2075 | -- Check_Inner_Package -- | |
2076 | ------------------------- | |
2077 | ||
2078 | procedure Check_Inner_Package (Pack : Entity_Id) is | |
2079 | E : Entity_Id; | |
2080 | Un : constant Node_Id := Sinfo.Unit (Cnode); | |
2081 | ||
2082 | function Check_Use_Clause (N : Node_Id) return Traverse_Result; | |
aae50ddd | 2083 | -- If N is a use_clause for Pack, emit warning |
9dfe12ae | 2084 | |
2085 | procedure Check_Use_Clauses is new | |
2086 | Traverse_Proc (Check_Use_Clause); | |
2087 | ||
2088 | ---------------------- | |
2089 | -- Check_Use_Clause -- | |
2090 | ---------------------- | |
2091 | ||
2092 | function Check_Use_Clause (N : Node_Id) return Traverse_Result is | |
2093 | Nam : Node_Id; | |
2094 | ||
2095 | begin | |
2096 | if Nkind (N) = N_Use_Package_Clause then | |
2097 | Nam := First (Names (N)); | |
9dfe12ae | 2098 | while Present (Nam) loop |
2099 | if Entity (Nam) = Pack then | |
2100 | Error_Msg_Qual_Level := 1; | |
e977c0cf | 2101 | Error_Msg_NE -- CODEFIX |
8063f750 | 2102 | ("?no entities of package& are referenced!", |
9dfe12ae | 2103 | Nam, Pack); |
2104 | Error_Msg_Qual_Level := 0; | |
2105 | end if; | |
2106 | ||
2107 | Next (Nam); | |
2108 | end loop; | |
2109 | end if; | |
2110 | ||
2111 | return OK; | |
2112 | end Check_Use_Clause; | |
2113 | ||
2114 | -- Start of processing for Check_Inner_Package | |
2115 | ||
2116 | begin | |
2117 | E := First_Entity (Pack); | |
9dfe12ae | 2118 | while Present (E) loop |
8063f750 | 2119 | if Referenced_Check_Spec (E) then |
9dfe12ae | 2120 | return; |
2121 | end if; | |
2122 | ||
2123 | Next_Entity (E); | |
2124 | end loop; | |
2125 | ||
c5797b4f | 2126 | -- No entities of the package are referenced. Check whether the |
2127 | -- reference to the package itself is a use clause, and if so | |
2128 | -- place a warning on it. | |
9dfe12ae | 2129 | |
2130 | Check_Use_Clauses (Un); | |
2131 | end Check_Inner_Package; | |
2132 | ||
2133 | ---------------------- | |
2134 | -- Check_System_Aux -- | |
2135 | ---------------------- | |
2136 | ||
2137 | function Check_System_Aux return Boolean is | |
2138 | Ent : Entity_Id; | |
2139 | ||
2140 | begin | |
2141 | if Chars (Lunit) = Name_System | |
2142 | and then Scope (Lunit) = Standard_Standard | |
2143 | and then Present_System_Aux | |
2144 | then | |
2145 | Ent := First_Entity (System_Aux_Id); | |
9dfe12ae | 2146 | while Present (Ent) loop |
8063f750 | 2147 | if Referenced_Check_Spec (Ent) then |
9dfe12ae | 2148 | return True; |
2149 | end if; | |
2150 | ||
2151 | Next_Entity (Ent); | |
2152 | end loop; | |
2153 | end if; | |
2154 | ||
2155 | return False; | |
2156 | end Check_System_Aux; | |
2157 | ||
d6f39728 | 2158 | --------------------------- |
2159 | -- Find_Package_Renaming -- | |
2160 | --------------------------- | |
2161 | ||
2162 | function Find_Package_Renaming | |
2163 | (P : Entity_Id; | |
2164 | L : Entity_Id) return Entity_Id | |
2165 | is | |
2166 | E1 : Entity_Id; | |
2167 | R : Entity_Id; | |
2168 | ||
2169 | begin | |
2170 | Is_Visible_Renaming := False; | |
d6f39728 | 2171 | |
c5797b4f | 2172 | E1 := First_Entity (P); |
d6f39728 | 2173 | while Present (E1) loop |
2174 | if Ekind (E1) = E_Package | |
2175 | and then Renamed_Object (E1) = L | |
2176 | then | |
2177 | Is_Visible_Renaming := not Is_Hidden (E1); | |
2178 | return E1; | |
2179 | ||
2180 | elsif Ekind (E1) = E_Package | |
2181 | and then No (Renamed_Object (E1)) | |
2182 | and then not Is_Generic_Instance (E1) | |
2183 | then | |
2184 | R := Find_Package_Renaming (E1, L); | |
2185 | ||
2186 | if Present (R) then | |
2187 | Is_Visible_Renaming := not Is_Hidden (R); | |
2188 | return R; | |
2189 | end if; | |
2190 | end if; | |
2191 | ||
2192 | Next_Entity (E1); | |
2193 | end loop; | |
2194 | ||
2195 | return Empty; | |
2196 | end Find_Package_Renaming; | |
2197 | ||
284a54ba | 2198 | -------------------------- |
2199 | -- Has_Visible_Entities -- | |
2200 | -------------------------- | |
2201 | ||
2202 | function Has_Visible_Entities (P : Entity_Id) return Boolean is | |
2203 | E : Entity_Id; | |
2204 | ||
2205 | begin | |
284a54ba | 2206 | -- If unit in context is not a package, it is a subprogram that |
2207 | -- is not called or a generic unit that is not instantiated | |
2208 | -- in the current unit, and warning is appropriate. | |
2209 | ||
2210 | if Ekind (P) /= E_Package then | |
2211 | return True; | |
2212 | end if; | |
2213 | ||
2214 | -- If unit comes from a limited_with clause, look for declaration | |
2215 | -- of shadow entities. | |
2216 | ||
2217 | if Present (Limited_View (P)) then | |
2218 | E := First_Entity (Limited_View (P)); | |
2219 | else | |
2220 | E := First_Entity (P); | |
2221 | end if; | |
2222 | ||
2223 | while Present (E) | |
2224 | and then E /= First_Private_Entity (P) | |
2225 | loop | |
2226 | if Comes_From_Source (E) | |
2227 | or else Present (Limited_View (P)) | |
2228 | then | |
2229 | return True; | |
2230 | end if; | |
2231 | ||
2232 | Next_Entity (E); | |
2233 | end loop; | |
2234 | ||
2235 | return False; | |
2236 | end Has_Visible_Entities; | |
2237 | ||
d6f39728 | 2238 | -- Start of processing for Check_One_Unit |
2239 | ||
2240 | begin | |
2241 | Cnode := Cunit (Unit); | |
2242 | ||
c5797b4f | 2243 | -- Only do check in units that are part of the extended main unit. |
2244 | -- This is actually a necessary restriction, because in the case of | |
2245 | -- subprogram acting as its own specification, there can be with's in | |
2246 | -- subunits that we will not see. | |
d6f39728 | 2247 | |
2248 | if not In_Extended_Main_Source_Unit (Cnode) then | |
2249 | return; | |
e4bd5d4a | 2250 | |
c5797b4f | 2251 | -- In configurable run time mode, we remove the bodies of non-inlined |
2252 | -- subprograms, which may lead to spurious warnings, which are | |
2253 | -- clearly undesirable. | |
e4bd5d4a | 2254 | |
9dfe12ae | 2255 | elsif Configurable_Run_Time_Mode |
e4bd5d4a | 2256 | and then Is_Predefined_File_Name (Unit_File_Name (Unit)) |
2257 | then | |
2258 | return; | |
d6f39728 | 2259 | end if; |
2260 | ||
2261 | -- Loop through context items in this unit | |
2262 | ||
2263 | Item := First (Context_Items (Cnode)); | |
2264 | while Present (Item) loop | |
d6f39728 | 2265 | if Nkind (Item) = N_With_Clause |
2266 | and then not Implicit_With (Item) | |
2267 | and then In_Extended_Main_Source_Unit (Item) | |
2268 | then | |
2269 | Lunit := Entity (Name (Item)); | |
2270 | ||
c0d40c9a | 2271 | -- Check if this unit is referenced (skip the check if this |
2272 | -- is explicitly marked by a pragma Unreferenced). | |
d6f39728 | 2273 | |
c0d40c9a | 2274 | if not Referenced (Lunit) |
059bd36a | 2275 | and then not Has_Unreferenced (Lunit) |
c0d40c9a | 2276 | then |
c5797b4f | 2277 | -- Suppress warnings in internal units if not in -gnatg mode |
2278 | -- (these would be junk warnings for an application program, | |
c0d40c9a | 2279 | -- since they refer to problems in internal units). |
d6f39728 | 2280 | |
2281 | if GNAT_Mode | |
2282 | or else not Is_Internal_File_Name (Unit_File_Name (Unit)) | |
2283 | then | |
c5797b4f | 2284 | -- Here we definitely have a non-referenced unit. If it |
2285 | -- is the special call for a spec unit, then just set the | |
2286 | -- flag to be read later. | |
d6f39728 | 2287 | |
2288 | if Unit = Spec_Unit then | |
2289 | Set_Unreferenced_In_Spec (Item); | |
2290 | ||
6bc4e5b9 | 2291 | -- Otherwise simple unreferenced message, but skip this |
2292 | -- if no visible entities, because that is most likely a | |
2293 | -- case where warning would be false positive (e.g. a | |
2294 | -- package with only a linker options pragma and nothing | |
2295 | -- else or a pragma elaborate with a body library task). | |
d6f39728 | 2296 | |
284a54ba | 2297 | elsif Has_Visible_Entities (Entity (Name (Item))) then |
e977c0cf | 2298 | Error_Msg_N -- CODEFIX |
8063f750 | 2299 | ("?unit& is not referenced!", Name (Item)); |
d6f39728 | 2300 | end if; |
2301 | end if; | |
2302 | ||
2303 | -- If main unit is a renaming of this unit, then we consider | |
2304 | -- the with to be OK (obviously it is needed in this case!) | |
c0d40c9a | 2305 | -- This may be transitive: the unit in the with_clause may |
2306 | -- itself be a renaming, in which case both it and the main | |
2307 | -- unit rename the same ultimate package. | |
d6f39728 | 2308 | |
2309 | elsif Present (Renamed_Entity (Munite)) | |
c0d40c9a | 2310 | and then |
2311 | (Renamed_Entity (Munite) = Lunit | |
2312 | or else Renamed_Entity (Munite) = Renamed_Entity (Lunit)) | |
d6f39728 | 2313 | then |
2314 | null; | |
2315 | ||
c5797b4f | 2316 | -- If this unit is referenced, and it is a package, we do |
2317 | -- another test, to see if any of the entities in the package | |
2318 | -- are referenced. If none of the entities are referenced, we | |
2319 | -- still post a warning. This occurs if the only use of the | |
2320 | -- package is in a use clause, or in a package renaming | |
ed683f94 | 2321 | -- declaration. This check is skipped for packages that are |
2322 | -- renamed in a spec, since the entities in such a package are | |
2323 | -- visible to clients via the renaming. | |
d6f39728 | 2324 | |
ed683f94 | 2325 | elsif Ekind (Lunit) = E_Package |
2326 | and then not Renamed_In_Spec (Lunit) | |
2327 | then | |
c5797b4f | 2328 | -- If Is_Instantiated is set, it means that the package is |
2329 | -- implicitly instantiated (this is the case of parent | |
2330 | -- instance or an actual for a generic package formal), and | |
2331 | -- this counts as a reference. | |
d6f39728 | 2332 | |
2333 | if Is_Instantiated (Lunit) then | |
2334 | null; | |
2335 | ||
2336 | -- If no entities in package, and there is a pragma | |
c5797b4f | 2337 | -- Elaborate_Body present, then assume that this with is |
2338 | -- done for purposes of this elaboration. | |
d6f39728 | 2339 | |
2340 | elsif No (First_Entity (Lunit)) | |
2341 | and then Has_Pragma_Elaborate_Body (Lunit) | |
2342 | then | |
2343 | null; | |
2344 | ||
2345 | -- Otherwise see if any entities have been referenced | |
2346 | ||
2347 | else | |
c5797b4f | 2348 | if Limited_Present (Item) then |
2349 | Ent := First_Entity (Limited_View (Lunit)); | |
2350 | else | |
2351 | Ent := First_Entity (Lunit); | |
2352 | end if; | |
2353 | ||
d6f39728 | 2354 | loop |
c5797b4f | 2355 | -- No more entities, and we did not find one that was |
2356 | -- referenced. Means we have a definite case of a with | |
2357 | -- none of whose entities was referenced. | |
d6f39728 | 2358 | |
2359 | if No (Ent) then | |
2360 | ||
2361 | -- If in spec, just set the flag | |
2362 | ||
2363 | if Unit = Spec_Unit then | |
2364 | Set_No_Entities_Ref_In_Spec (Item); | |
2365 | ||
9dfe12ae | 2366 | elsif Check_System_Aux then |
2367 | null; | |
2368 | ||
d6f39728 | 2369 | -- Else give the warning |
2370 | ||
2371 | else | |
059bd36a | 2372 | if not |
2373 | Has_Unreferenced (Entity (Name (Item))) | |
ed683f94 | 2374 | then |
e977c0cf | 2375 | Error_Msg_N -- CODEFIX |
ed683f94 | 2376 | ("?no entities of & are referenced!", |
2377 | Name (Item)); | |
2378 | end if; | |
d6f39728 | 2379 | |
c5797b4f | 2380 | -- Look for renamings of this package, and flag |
2381 | -- them as well. If the original package has | |
2382 | -- warnings off, we suppress the warning on the | |
2383 | -- renaming as well. | |
d6f39728 | 2384 | |
2385 | Pack := Find_Package_Renaming (Munite, Lunit); | |
2386 | ||
2387 | if Present (Pack) | |
059bd36a | 2388 | and then not Has_Warnings_Off (Lunit) |
2389 | and then not Has_Unreferenced (Pack) | |
d6f39728 | 2390 | then |
e977c0cf | 2391 | Error_Msg_NE -- CODEFIX |
8063f750 | 2392 | ("?no entities of & are referenced!", |
d6f39728 | 2393 | Unit_Declaration_Node (Pack), |
ed683f94 | 2394 | Pack); |
d6f39728 | 2395 | end if; |
2396 | end if; | |
2397 | ||
2398 | exit; | |
2399 | ||
8063f750 | 2400 | -- Case of entity being referenced. The reference may |
2401 | -- come from a limited_with_clause, in which case the | |
2402 | -- limited view of the entity carries the flag. | |
2403 | ||
2404 | elsif Referenced_Check_Spec (Ent) | |
2405 | or else Referenced_As_LHS_Check_Spec (Ent) | |
ed683f94 | 2406 | or else Referenced_As_Out_Parameter_Check_Spec (Ent) |
8063f750 | 2407 | or else |
2408 | (From_With_Type (Ent) | |
2409 | and then Is_Incomplete_Type (Ent) | |
2410 | and then Present (Non_Limited_View (Ent)) | |
2411 | and then Referenced (Non_Limited_View (Ent))) | |
9dfe12ae | 2412 | then |
c5797b4f | 2413 | -- This means that the with is indeed fine, in that |
2414 | -- it is definitely needed somewhere, and we can | |
8063f750 | 2415 | -- quit worrying about this one... |
d6f39728 | 2416 | |
8063f750 | 2417 | -- Except for one little detail: if either of the |
c5797b4f | 2418 | -- flags was set during spec processing, this is |
2419 | -- where we complain that the with could be moved | |
2420 | -- from the spec. If the spec contains a visible | |
2421 | -- renaming of the package, inhibit warning to move | |
2422 | -- with_clause to body. | |
d6f39728 | 2423 | |
2424 | if Ekind (Munite) = E_Package_Body then | |
2425 | Pack := | |
2426 | Find_Package_Renaming | |
2427 | (Spec_Entity (Munite), Lunit); | |
2428 | end if; | |
2429 | ||
2430 | if Unreferenced_In_Spec (Item) then | |
e977c0cf | 2431 | Error_Msg_N -- CODEFIX |
8063f750 | 2432 | ("?unit& is not referenced in spec!", |
d6f39728 | 2433 | Name (Item)); |
2434 | ||
2435 | elsif No_Entities_Ref_In_Spec (Item) then | |
e977c0cf | 2436 | Error_Msg_N -- CODEFIX |
8063f750 | 2437 | ("?no entities of & are referenced in spec!", |
d6f39728 | 2438 | Name (Item)); |
2439 | ||
2440 | else | |
9dfe12ae | 2441 | if Ekind (Ent) = E_Package then |
2442 | Check_Inner_Package (Ent); | |
2443 | end if; | |
2444 | ||
d6f39728 | 2445 | exit; |
2446 | end if; | |
2447 | ||
2448 | if not Is_Visible_Renaming then | |
3ba6a78b | 2449 | Error_Msg_N -- CODEFIX |
8063f750 | 2450 | ("\?with clause might be moved to body!", |
d6f39728 | 2451 | Name (Item)); |
2452 | end if; | |
2453 | ||
2454 | exit; | |
2455 | ||
2456 | -- Move to next entity to continue search | |
2457 | ||
2458 | else | |
2459 | Next_Entity (Ent); | |
2460 | end if; | |
2461 | end loop; | |
2462 | end if; | |
2463 | ||
2464 | -- For a generic package, the only interesting kind of | |
c5797b4f | 2465 | -- reference is an instantiation, since entities cannot be |
2466 | -- referenced directly. | |
d6f39728 | 2467 | |
2468 | elsif Is_Generic_Unit (Lunit) then | |
2469 | ||
2470 | -- Unit was never instantiated, set flag for case of spec | |
2471 | -- call, or give warning for normal call. | |
2472 | ||
2473 | if not Is_Instantiated (Lunit) then | |
2474 | if Unit = Spec_Unit then | |
2475 | Set_Unreferenced_In_Spec (Item); | |
2476 | else | |
3ba6a78b | 2477 | Error_Msg_N -- CODEFIX |
8063f750 | 2478 | ("?unit& is never instantiated!", Name (Item)); |
d6f39728 | 2479 | end if; |
2480 | ||
c5797b4f | 2481 | -- If unit was indeed instantiated, make sure that flag is |
2482 | -- not set showing it was uninstantiated in the spec, and if | |
2483 | -- so, give warning. | |
d6f39728 | 2484 | |
2485 | elsif Unreferenced_In_Spec (Item) then | |
2486 | Error_Msg_N | |
8063f750 | 2487 | ("?unit& is not instantiated in spec!", Name (Item)); |
3ba6a78b | 2488 | Error_Msg_N -- CODEFIX |
8063f750 | 2489 | ("\?with clause can be moved to body!", Name (Item)); |
d6f39728 | 2490 | end if; |
2491 | end if; | |
2492 | end if; | |
2493 | ||
2494 | Next (Item); | |
2495 | end loop; | |
d6f39728 | 2496 | end Check_One_Unit; |
2497 | ||
2498 | -- Start of processing for Check_Unused_Withs | |
2499 | ||
2500 | begin | |
2501 | if not Opt.Check_Withs | |
2502 | or else Operating_Mode = Check_Syntax | |
2503 | then | |
2504 | return; | |
2505 | end if; | |
2506 | ||
c5797b4f | 2507 | -- Flag any unused with clauses, but skip this step if we are compiling |
2508 | -- a subunit on its own, since we do not have enough information to | |
2509 | -- determine whether with's are used. We will get the relevant warnings | |
2510 | -- when we compile the parent. This is the normal style of GNAT | |
2511 | -- compilation in any case. | |
d6f39728 | 2512 | |
2513 | if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then | |
2514 | return; | |
2515 | end if; | |
2516 | ||
2517 | -- Process specified units | |
2518 | ||
2519 | if Spec_Unit = No_Unit then | |
2520 | ||
2521 | -- For main call, check all units | |
2522 | ||
2523 | for Unit in Main_Unit .. Last_Unit loop | |
2524 | Check_One_Unit (Unit); | |
2525 | end loop; | |
2526 | ||
2527 | else | |
2528 | -- For call for spec, check only the spec | |
2529 | ||
2530 | Check_One_Unit (Spec_Unit); | |
2531 | end if; | |
2532 | end Check_Unused_Withs; | |
2533 | ||
9dfe12ae | 2534 | --------------------------------- |
2535 | -- Generic_Package_Spec_Entity -- | |
2536 | --------------------------------- | |
2537 | ||
2538 | function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean is | |
2539 | S : Entity_Id; | |
2540 | ||
2541 | begin | |
2542 | if Is_Package_Body_Entity (E) then | |
2543 | return False; | |
2544 | ||
2545 | else | |
2546 | S := Scope (E); | |
9dfe12ae | 2547 | loop |
2548 | if S = Standard_Standard then | |
2549 | return False; | |
2550 | ||
2551 | elsif Ekind (S) = E_Generic_Package then | |
2552 | return True; | |
2553 | ||
2554 | elsif Ekind (S) = E_Package then | |
2555 | S := Scope (S); | |
2556 | ||
2557 | else | |
2558 | return False; | |
2559 | end if; | |
2560 | end loop; | |
2561 | end if; | |
2562 | end Generic_Package_Spec_Entity; | |
2563 | ||
8063f750 | 2564 | ---------------------- |
2565 | -- Goto_Spec_Entity -- | |
2566 | ---------------------- | |
2567 | ||
2568 | function Goto_Spec_Entity (E : Entity_Id) return Entity_Id is | |
2569 | begin | |
2570 | if Is_Formal (E) | |
2571 | and then Present (Spec_Entity (E)) | |
2572 | then | |
2573 | return Spec_Entity (E); | |
2574 | else | |
2575 | return E; | |
2576 | end if; | |
2577 | end Goto_Spec_Entity; | |
2578 | ||
4540a696 | 2579 | -------------------------------------- |
2580 | -- Has_Pragma_Unmodified_Check_Spec -- | |
2581 | -------------------------------------- | |
2582 | ||
2583 | function Has_Pragma_Unmodified_Check_Spec | |
2584 | (E : Entity_Id) return Boolean | |
2585 | is | |
2586 | begin | |
2587 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
059bd36a | 2588 | |
2589 | -- Note: use of OR instead of OR ELSE here is deliberate, we want | |
2590 | -- to mess with Unmodified flags on both body and spec entities. | |
2591 | ||
2592 | return Has_Unmodified (E) | |
2593 | or | |
2594 | Has_Unmodified (Spec_Entity (E)); | |
2595 | ||
4540a696 | 2596 | else |
059bd36a | 2597 | return Has_Unmodified (E); |
4540a696 | 2598 | end if; |
2599 | end Has_Pragma_Unmodified_Check_Spec; | |
2600 | ||
8063f750 | 2601 | ---------------------------------------- |
2602 | -- Has_Pragma_Unreferenced_Check_Spec -- | |
2603 | ---------------------------------------- | |
2604 | ||
2605 | function Has_Pragma_Unreferenced_Check_Spec | |
2606 | (E : Entity_Id) return Boolean | |
2607 | is | |
2608 | begin | |
2609 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
059bd36a | 2610 | |
2611 | -- Note: use of OR here instead of OR ELSE is deliberate, we want | |
2612 | -- to mess with flags on both entities. | |
2613 | ||
2614 | return Has_Unreferenced (E) | |
2615 | or | |
2616 | Has_Unreferenced (Spec_Entity (E)); | |
2617 | ||
8063f750 | 2618 | else |
059bd36a | 2619 | return Has_Unreferenced (E); |
8063f750 | 2620 | end if; |
2621 | end Has_Pragma_Unreferenced_Check_Spec; | |
2622 | ||
059bd36a | 2623 | ---------------- |
2624 | -- Initialize -- | |
2625 | ---------------- | |
2626 | ||
2627 | procedure Initialize is | |
2628 | begin | |
2629 | Warnings_Off_Pragmas.Init; | |
2630 | Unreferenced_Entities.Init; | |
2631 | In_Out_Warnings.Init; | |
2632 | end Initialize; | |
2633 | ||
8063f750 | 2634 | ------------------------------------ |
2635 | -- Never_Set_In_Source_Check_Spec -- | |
2636 | ------------------------------------ | |
2637 | ||
2638 | function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean is | |
2639 | begin | |
2640 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
2641 | return Never_Set_In_Source (E) | |
2642 | and then | |
2643 | Never_Set_In_Source (Spec_Entity (E)); | |
2644 | else | |
2645 | return Never_Set_In_Source (E); | |
2646 | end if; | |
2647 | end Never_Set_In_Source_Check_Spec; | |
2648 | ||
f15731c4 | 2649 | ------------------------------------- |
2650 | -- Operand_Has_Warnings_Suppressed -- | |
2651 | ------------------------------------- | |
2652 | ||
2653 | function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean is | |
2654 | ||
2655 | function Check_For_Warnings (N : Node_Id) return Traverse_Result; | |
2656 | -- Function used to check one node to see if it is or was originally | |
2657 | -- a reference to an entity for which Warnings are off. If so, Abandon | |
2658 | -- is returned, otherwise OK_Orig is returned to continue the traversal | |
2659 | -- of the original expression. | |
2660 | ||
2661 | function Traverse is new Traverse_Func (Check_For_Warnings); | |
2662 | -- Function used to traverse tree looking for warnings | |
2663 | ||
2664 | ------------------------ | |
2665 | -- Check_For_Warnings -- | |
2666 | ------------------------ | |
2667 | ||
2668 | function Check_For_Warnings (N : Node_Id) return Traverse_Result is | |
2669 | R : constant Node_Id := Original_Node (N); | |
2670 | ||
2671 | begin | |
2672 | if Nkind (R) in N_Has_Entity | |
2673 | and then Present (Entity (R)) | |
059bd36a | 2674 | and then Has_Warnings_Off (Entity (R)) |
f15731c4 | 2675 | then |
2676 | return Abandon; | |
2677 | else | |
2678 | return OK_Orig; | |
2679 | end if; | |
2680 | end Check_For_Warnings; | |
2681 | ||
2682 | -- Start of processing for Operand_Has_Warnings_Suppressed | |
2683 | ||
2684 | begin | |
2685 | return Traverse (N) = Abandon; | |
2686 | ||
2687 | -- If any exception occurs, then something has gone wrong, and this is | |
2688 | -- only a minor aesthetic issue anyway, so just say we did not find what | |
2689 | -- we are looking for, rather than blow up. | |
2690 | ||
2691 | exception | |
2692 | when others => | |
2693 | return False; | |
2694 | end Operand_Has_Warnings_Suppressed; | |
2695 | ||
8063f750 | 2696 | ----------------------------------------- |
2697 | -- Output_Non_Modified_In_Out_Warnings -- | |
2698 | ----------------------------------------- | |
2699 | ||
7f2b7c5f | 2700 | procedure Output_Non_Modified_In_Out_Warnings is |
8063f750 | 2701 | |
2702 | function No_Warn_On_In_Out (E : Entity_Id) return Boolean; | |
2703 | -- Given a formal parameter entity E, determines if there is a reason to | |
2704 | -- suppress IN OUT warnings (not modified, could be IN) for formals of | |
2705 | -- the subprogram. We suppress these warnings if Warnings Off is set, or | |
2706 | -- if we have seen the address of the subprogram being taken, or if the | |
2707 | -- subprogram is used as a generic actual (in the latter cases the | |
2708 | -- context may force use of IN OUT, even if the parameter is not | |
2709 | -- modifies for this particular case. | |
2710 | ||
2711 | ----------------------- | |
2712 | -- No_Warn_On_In_Out -- | |
2713 | ----------------------- | |
2714 | ||
2715 | function No_Warn_On_In_Out (E : Entity_Id) return Boolean is | |
059bd36a | 2716 | S : constant Entity_Id := Scope (E); |
2717 | SE : constant Entity_Id := Spec_Entity (E); | |
2718 | ||
8063f750 | 2719 | begin |
059bd36a | 2720 | -- Do not warn if address is taken, since funny business may be going |
2721 | -- on in treating the parameter indirectly as IN OUT. | |
2722 | ||
2723 | if Address_Taken (S) | |
2724 | or else (Present (SE) and then Address_Taken (Scope (SE))) | |
2725 | then | |
8063f750 | 2726 | return True; |
059bd36a | 2727 | |
2728 | -- Do not warn if used as a generic actual, since the generic may be | |
2729 | -- what is forcing the use of an "unnecessary" IN OUT. | |
2730 | ||
2731 | elsif Used_As_Generic_Actual (S) | |
2732 | or else (Present (SE) and then Used_As_Generic_Actual (Scope (SE))) | |
2733 | then | |
8063f750 | 2734 | return True; |
059bd36a | 2735 | |
2736 | -- Else test warnings off | |
2737 | ||
2738 | elsif Warnings_Off_Check_Spec (S) then | |
8063f750 | 2739 | return True; |
059bd36a | 2740 | |
2741 | -- All tests for suppressing warning failed | |
2742 | ||
8063f750 | 2743 | else |
2744 | return False; | |
2745 | end if; | |
2746 | end No_Warn_On_In_Out; | |
2747 | ||
1a34e48c | 2748 | -- Start of processing for Output_Non_Modified_In_Out_Warnings |
8063f750 | 2749 | |
2750 | begin | |
2751 | -- Loop through entities for which a warning may be needed | |
2752 | ||
2753 | for J in In_Out_Warnings.First .. In_Out_Warnings.Last loop | |
2754 | declare | |
2755 | E1 : constant Entity_Id := In_Out_Warnings.Table (J); | |
2756 | ||
2757 | begin | |
2758 | -- Suppress warning in specific cases (see details in comments for | |
4540a696 | 2759 | -- No_Warn_On_In_Out), or if there is a pragma Unmodified. |
8063f750 | 2760 | |
059bd36a | 2761 | if Has_Pragma_Unmodified_Check_Spec (E1) |
2762 | or else No_Warn_On_In_Out (E1) | |
4540a696 | 2763 | then |
8063f750 | 2764 | null; |
2765 | ||
2766 | -- Here we generate the warning | |
2767 | ||
2768 | else | |
4540a696 | 2769 | -- If -gnatwc is set then output message that we could be IN |
2770 | ||
059bd36a | 2771 | if not Is_Trivial_Subprogram (Scope (E1)) then |
2772 | if Warn_On_Constant then | |
2773 | Error_Msg_N | |
2774 | ("?formal parameter & is not modified!", E1); | |
503f7fd3 | 2775 | Error_Msg_N |
059bd36a | 2776 | ("\?mode could be IN instead of `IN OUT`!", E1); |
4540a696 | 2777 | |
059bd36a | 2778 | -- We do not generate warnings for IN OUT parameters |
2779 | -- unless we have at least -gnatwu. This is deliberately | |
2780 | -- inconsistent with the treatment of variables, but | |
2781 | -- otherwise we get too many unexpected warnings in | |
2782 | -- default mode. | |
4540a696 | 2783 | |
059bd36a | 2784 | elsif Check_Unreferenced then |
503f7fd3 | 2785 | Error_Msg_N |
e977c0cf | 2786 | ("?formal parameter& is read but " |
2787 | & "never assigned!", E1); | |
059bd36a | 2788 | end if; |
4540a696 | 2789 | end if; |
8063f750 | 2790 | |
2791 | -- Kill any other warnings on this entity, since this is the | |
2792 | -- one that should dominate any other unreferenced warning. | |
2793 | ||
2794 | Set_Warnings_Off (E1); | |
2795 | end if; | |
2796 | end; | |
2797 | end loop; | |
7f2b7c5f | 2798 | end Output_Non_Modified_In_Out_Warnings; |
8063f750 | 2799 | |
c0d40c9a | 2800 | ---------------------------------------- |
2801 | -- Output_Obsolescent_Entity_Warnings -- | |
2802 | ---------------------------------------- | |
2803 | ||
2804 | procedure Output_Obsolescent_Entity_Warnings (N : Node_Id; E : Entity_Id) is | |
2805 | P : constant Node_Id := Parent (N); | |
2806 | S : Entity_Id; | |
2807 | ||
2808 | begin | |
2809 | S := Current_Scope; | |
2810 | ||
2811 | -- Do not output message if we are the scope of standard. This means | |
2812 | -- we have a reference from a context clause from when it is originally | |
2813 | -- processed, and that's too early to tell whether it is an obsolescent | |
2814 | -- unit doing the with'ing. In Sem_Ch10.Analyze_Compilation_Unit we make | |
2815 | -- sure that we have a later call when the scope is available. This test | |
2816 | -- also eliminates all messages for use clauses, which is fine (we do | |
2817 | -- not want messages for use clauses, since they are always redundant | |
2818 | -- with respect to the associated with clause). | |
2819 | ||
2820 | if S = Standard_Standard then | |
2821 | return; | |
2822 | end if; | |
2823 | ||
2824 | -- Do not output message if we are in scope of an obsolescent package | |
2825 | -- or subprogram. | |
2826 | ||
2827 | loop | |
2828 | if Is_Obsolescent (S) then | |
2829 | return; | |
2830 | end if; | |
2831 | ||
2832 | S := Scope (S); | |
2833 | exit when S = Standard_Standard; | |
2834 | end loop; | |
2835 | ||
2836 | -- Here we will output the message | |
2837 | ||
2838 | Error_Msg_Sloc := Sloc (E); | |
2839 | ||
2840 | -- Case of with clause | |
2841 | ||
2842 | if Nkind (P) = N_With_Clause then | |
2843 | if Ekind (E) = E_Package then | |
2844 | Error_Msg_NE | |
2845 | ("?with of obsolescent package& declared#", N, E); | |
2846 | elsif Ekind (E) = E_Procedure then | |
2847 | Error_Msg_NE | |
2848 | ("?with of obsolescent procedure& declared#", N, E); | |
2849 | else | |
2850 | Error_Msg_NE | |
2851 | ("?with of obsolescent function& declared#", N, E); | |
2852 | end if; | |
2853 | ||
2854 | -- If we do not have a with clause, then ignore any reference to an | |
2855 | -- obsolescent package name. We only want to give the one warning of | |
2856 | -- withing the package, not one each time it is used to qualify. | |
2857 | ||
2858 | elsif Ekind (E) = E_Package then | |
2859 | return; | |
2860 | ||
2861 | -- Procedure call statement | |
2862 | ||
2863 | elsif Nkind (P) = N_Procedure_Call_Statement then | |
2864 | Error_Msg_NE | |
2865 | ("?call to obsolescent procedure& declared#", N, E); | |
2866 | ||
2867 | -- Function call | |
2868 | ||
2869 | elsif Nkind (P) = N_Function_Call then | |
2870 | Error_Msg_NE | |
2871 | ("?call to obsolescent function& declared#", N, E); | |
2872 | ||
2873 | -- Reference to obsolescent type | |
2874 | ||
2875 | elsif Is_Type (E) then | |
2876 | Error_Msg_NE | |
2877 | ("?reference to obsolescent type& declared#", N, E); | |
2878 | ||
2879 | -- Reference to obsolescent component | |
2880 | ||
67278d60 | 2881 | elsif Ekind_In (E, E_Component, E_Discriminant) then |
c0d40c9a | 2882 | Error_Msg_NE |
2883 | ("?reference to obsolescent component& declared#", N, E); | |
2884 | ||
2885 | -- Reference to obsolescent variable | |
2886 | ||
2887 | elsif Ekind (E) = E_Variable then | |
2888 | Error_Msg_NE | |
2889 | ("?reference to obsolescent variable& declared#", N, E); | |
2890 | ||
2891 | -- Reference to obsolescent constant | |
2892 | ||
2893 | elsif Ekind (E) = E_Constant | |
2894 | or else Ekind (E) in Named_Kind | |
2895 | then | |
2896 | Error_Msg_NE | |
2897 | ("?reference to obsolescent constant& declared#", N, E); | |
2898 | ||
2899 | -- Reference to obsolescent enumeration literal | |
2900 | ||
2901 | elsif Ekind (E) = E_Enumeration_Literal then | |
2902 | Error_Msg_NE | |
2903 | ("?reference to obsolescent enumeration literal& declared#", N, E); | |
2904 | ||
2905 | -- Generic message for any other case we missed | |
2906 | ||
2907 | else | |
2908 | Error_Msg_NE | |
2909 | ("?reference to obsolescent entity& declared#", N, E); | |
2910 | end if; | |
2911 | ||
2912 | -- Output additional warning if present | |
2913 | ||
d55c93e0 | 2914 | for J in Obsolescent_Warnings.First .. Obsolescent_Warnings.Last loop |
2915 | if Obsolescent_Warnings.Table (J).Ent = E then | |
2916 | String_To_Name_Buffer (Obsolescent_Warnings.Table (J).Msg); | |
2917 | Error_Msg_Strlen := Name_Len; | |
2918 | Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); | |
2919 | Error_Msg_N ("\\?~", N); | |
2920 | exit; | |
c0d40c9a | 2921 | end if; |
d55c93e0 | 2922 | end loop; |
c0d40c9a | 2923 | end Output_Obsolescent_Entity_Warnings; |
2924 | ||
d6f39728 | 2925 | ---------------------------------- |
2926 | -- Output_Unreferenced_Messages -- | |
2927 | ---------------------------------- | |
2928 | ||
2929 | procedure Output_Unreferenced_Messages is | |
d6f39728 | 2930 | begin |
2931 | for J in Unreferenced_Entities.First .. | |
2932 | Unreferenced_Entities.Last | |
2933 | loop | |
8063f750 | 2934 | Warn_On_Unreferenced_Entity (Unreferenced_Entities.Table (J)); |
2935 | end loop; | |
2936 | end Output_Unreferenced_Messages; | |
9dfe12ae | 2937 | |
059bd36a | 2938 | ----------------------------------------- |
2939 | -- Output_Unused_Warnings_Off_Warnings -- | |
2940 | ----------------------------------------- | |
2941 | ||
2942 | procedure Output_Unused_Warnings_Off_Warnings is | |
2943 | begin | |
2944 | for J in Warnings_Off_Pragmas.First .. Warnings_Off_Pragmas.Last loop | |
2945 | declare | |
2946 | Wentry : Warnings_Off_Entry renames Warnings_Off_Pragmas.Table (J); | |
2947 | N : Node_Id renames Wentry.N; | |
2948 | E : Node_Id renames Wentry.E; | |
2949 | ||
2950 | begin | |
2951 | -- Turn off Warnings_Off, or we won't get the warning! | |
2952 | ||
2953 | Set_Warnings_Off (E, False); | |
2954 | ||
2955 | -- Nothing to do if pragma was used to suppress a general warning | |
2956 | ||
2957 | if Warnings_Off_Used (E) then | |
2958 | null; | |
2959 | ||
2960 | -- If pragma was used both in unmodified and unreferenced contexts | |
2961 | -- then that's as good as the general case, no warning. | |
2962 | ||
2963 | elsif Warnings_Off_Used_Unmodified (E) | |
2964 | and | |
2965 | Warnings_Off_Used_Unreferenced (E) | |
2966 | then | |
2967 | null; | |
2968 | ||
2969 | -- Used only in context where Unmodified would have worked | |
2970 | ||
2971 | elsif Warnings_Off_Used_Unmodified (E) then | |
503f7fd3 | 2972 | Error_Msg_NE |
059bd36a | 2973 | ("?could use Unmodified instead of " |
2974 | & "Warnings Off for &", Pragma_Identifier (N), E); | |
2975 | ||
2976 | -- Used only in context where Unreferenced would have worked | |
2977 | ||
2978 | elsif Warnings_Off_Used_Unreferenced (E) then | |
503f7fd3 | 2979 | Error_Msg_NE |
059bd36a | 2980 | ("?could use Unreferenced instead of " |
2981 | & "Warnings Off for &", Pragma_Identifier (N), E); | |
2982 | ||
2983 | -- Not used at all | |
2984 | ||
2985 | else | |
503f7fd3 | 2986 | Error_Msg_NE |
059bd36a | 2987 | ("?pragma Warnings Off for & unused, " |
2988 | & "could be omitted", N, E); | |
2989 | end if; | |
2990 | end; | |
2991 | end loop; | |
2992 | end Output_Unused_Warnings_Off_Warnings; | |
2993 | ||
8063f750 | 2994 | --------------------------- |
2995 | -- Referenced_Check_Spec -- | |
2996 | --------------------------- | |
9dfe12ae | 2997 | |
8063f750 | 2998 | function Referenced_Check_Spec (E : Entity_Id) return Boolean is |
2999 | begin | |
3000 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
3001 | return Referenced (E) or else Referenced (Spec_Entity (E)); | |
3002 | else | |
3003 | return Referenced (E); | |
3004 | end if; | |
3005 | end Referenced_Check_Spec; | |
d6f39728 | 3006 | |
8063f750 | 3007 | ---------------------------------- |
3008 | -- Referenced_As_LHS_Check_Spec -- | |
3009 | ---------------------------------- | |
d6f39728 | 3010 | |
8063f750 | 3011 | function Referenced_As_LHS_Check_Spec (E : Entity_Id) return Boolean is |
3012 | begin | |
3013 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
3014 | return Referenced_As_LHS (E) | |
3015 | or else Referenced_As_LHS (Spec_Entity (E)); | |
3016 | else | |
3017 | return Referenced_As_LHS (E); | |
3018 | end if; | |
3019 | end Referenced_As_LHS_Check_Spec; | |
d6f39728 | 3020 | |
ed683f94 | 3021 | -------------------------------------------- |
3022 | -- Referenced_As_Out_Parameter_Check_Spec -- | |
3023 | -------------------------------------------- | |
3024 | ||
3025 | function Referenced_As_Out_Parameter_Check_Spec | |
3026 | (E : Entity_Id) return Boolean | |
3027 | is | |
3028 | begin | |
3029 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
3030 | return Referenced_As_Out_Parameter (E) | |
3031 | or else Referenced_As_Out_Parameter (Spec_Entity (E)); | |
3032 | else | |
3033 | return Referenced_As_Out_Parameter (E); | |
3034 | end if; | |
3035 | end Referenced_As_Out_Parameter_Check_Spec; | |
3036 | ||
ef7e1793 | 3037 | ---------------------------- |
3038 | -- Set_Dot_Warning_Switch -- | |
3039 | ---------------------------- | |
3040 | ||
3041 | function Set_Dot_Warning_Switch (C : Character) return Boolean is | |
3042 | begin | |
3043 | case C is | |
ed683f94 | 3044 | when 'a' => |
3045 | Warn_On_Assertion_Failure := True; | |
3046 | ||
3047 | when 'A' => | |
3048 | Warn_On_Assertion_Failure := False; | |
3049 | ||
cc46ff4b | 3050 | when 'b' => |
3051 | Warn_On_Biased_Representation := True; | |
3052 | ||
3053 | when 'B' => | |
3054 | Warn_On_Biased_Representation := False; | |
3055 | ||
8255b799 | 3056 | when 'c' => |
3057 | Warn_On_Unrepped_Components := True; | |
3058 | ||
3059 | when 'C' => | |
3060 | Warn_On_Unrepped_Components := False; | |
3061 | ||
d55c93e0 | 3062 | when 'e' => |
3063 | Address_Clause_Overlay_Warnings := True; | |
3064 | Check_Unreferenced := True; | |
3065 | Check_Unreferenced_Formals := True; | |
3066 | Check_Withs := True; | |
3067 | Constant_Condition_Warnings := True; | |
3068 | Elab_Warnings := True; | |
3069 | Implementation_Unit_Warnings := True; | |
3070 | Ineffective_Inline_Warnings := True; | |
5b5df4a9 | 3071 | List_Inherited_Aspects := True; |
d55c93e0 | 3072 | Warn_On_Ada_2005_Compatibility := True; |
1052d172 | 3073 | Warn_On_Ada_2012_Compatibility := True; |
d55c93e0 | 3074 | Warn_On_All_Unread_Out_Parameters := True; |
3075 | Warn_On_Assertion_Failure := True; | |
3076 | Warn_On_Assumed_Low_Bound := True; | |
3077 | Warn_On_Bad_Fixed_Value := True; | |
cc46ff4b | 3078 | Warn_On_Biased_Representation := True; |
d55c93e0 | 3079 | Warn_On_Constant := True; |
3080 | Warn_On_Deleted_Code := True; | |
3081 | Warn_On_Dereference := True; | |
3082 | Warn_On_Export_Import := True; | |
3083 | Warn_On_Hiding := True; | |
d55c93e0 | 3084 | Warn_On_Modified_Unread := True; |
3085 | Warn_On_No_Value_Assigned := True; | |
3086 | Warn_On_Non_Local_Exception := True; | |
3087 | Warn_On_Object_Renames_Function := True; | |
3088 | Warn_On_Obsolescent_Feature := True; | |
aaf44d5a | 3089 | Warn_On_Overlap := True; |
a0fc8c5b | 3090 | Warn_On_Overridden_Size := True; |
d36a3269 | 3091 | Warn_On_Parameter_Order := True; |
d55c93e0 | 3092 | Warn_On_Questionable_Missing_Parens := True; |
47495553 | 3093 | Warn_On_Record_Holes := True; |
d55c93e0 | 3094 | Warn_On_Redundant_Constructs := True; |
d36a3269 | 3095 | Warn_On_Reverse_Bit_Order := True; |
d55c93e0 | 3096 | Warn_On_Unchecked_Conversion := True; |
a22215d6 | 3097 | Warn_On_Unordered_Enumeration_Type := True; |
d55c93e0 | 3098 | Warn_On_Unrecognized_Pragma := True; |
3099 | Warn_On_Unrepped_Components := True; | |
3100 | Warn_On_Warnings_Off := True; | |
3101 | ||
12308590 | 3102 | when 'g' => |
3103 | Set_GNAT_Mode_Warnings; | |
3104 | ||
47495553 | 3105 | when 'h' => |
3106 | Warn_On_Record_Holes := True; | |
3107 | ||
3108 | when 'H' => | |
3109 | Warn_On_Record_Holes := False; | |
3110 | ||
aaf44d5a | 3111 | when 'i' => |
3112 | Warn_On_Overlap := True; | |
3113 | ||
3114 | when 'I' => | |
3115 | Warn_On_Overlap := False; | |
3116 | ||
39e1f22f | 3117 | when 'l' => |
5b5df4a9 | 3118 | List_Inherited_Aspects := True; |
39e1f22f | 3119 | |
3120 | when 'L' => | |
5b5df4a9 | 3121 | List_Inherited_Aspects := False; |
39e1f22f | 3122 | |
91a6416d | 3123 | when 'm' => |
3124 | Warn_On_Suspicious_Modulus_Value := True; | |
3125 | ||
3126 | when 'M' => | |
3127 | Warn_On_Suspicious_Modulus_Value := False; | |
3128 | ||
96da3284 | 3129 | when 'o' => |
ed683f94 | 3130 | Warn_On_All_Unread_Out_Parameters := True; |
96da3284 | 3131 | |
3132 | when 'O' => | |
ed683f94 | 3133 | Warn_On_All_Unread_Out_Parameters := False; |
96da3284 | 3134 | |
d55c93e0 | 3135 | when 'p' => |
3136 | Warn_On_Parameter_Order := True; | |
3137 | ||
3138 | when 'P' => | |
3139 | Warn_On_Parameter_Order := False; | |
3140 | ||
8255b799 | 3141 | when 'r' => |
3142 | Warn_On_Object_Renames_Function := True; | |
3143 | ||
3144 | when 'R' => | |
3145 | Warn_On_Object_Renames_Function := False; | |
3146 | ||
a0fc8c5b | 3147 | when 's' => |
3148 | Warn_On_Overridden_Size := True; | |
3149 | ||
3150 | when 'S' => | |
3151 | Warn_On_Overridden_Size := False; | |
3152 | ||
a22215d6 | 3153 | when 'u' => |
3154 | Warn_On_Unordered_Enumeration_Type := True; | |
3155 | ||
3156 | when 'U' => | |
3157 | Warn_On_Unordered_Enumeration_Type := False; | |
3158 | ||
d36a3269 | 3159 | when 'v' => |
3160 | Warn_On_Reverse_Bit_Order := True; | |
3161 | ||
3162 | when 'V' => | |
3163 | Warn_On_Reverse_Bit_Order := False; | |
3164 | ||
059bd36a | 3165 | when 'w' => |
3166 | Warn_On_Warnings_Off := True; | |
3167 | ||
3168 | when 'W' => | |
3169 | Warn_On_Warnings_Off := False; | |
3170 | ||
ef7e1793 | 3171 | when 'x' => |
3172 | Warn_On_Non_Local_Exception := True; | |
3173 | ||
3174 | when 'X' => | |
3175 | Warn_On_Non_Local_Exception := False; | |
30e5c8d3 | 3176 | No_Warn_On_Non_Local_Exception := True; |
ef7e1793 | 3177 | |
3178 | when others => | |
3179 | return False; | |
3180 | end case; | |
3181 | ||
3182 | return True; | |
3183 | end Set_Dot_Warning_Switch; | |
3184 | ||
12308590 | 3185 | ---------------------------- |
3186 | -- Set_GNAT_Mode_Warnings -- | |
3187 | ---------------------------- | |
3188 | ||
3189 | procedure Set_GNAT_Mode_Warnings is | |
3190 | begin | |
3191 | Address_Clause_Overlay_Warnings := True; | |
3192 | Check_Unreferenced := True; | |
3193 | Check_Unreferenced_Formals := True; | |
3194 | Check_Withs := True; | |
3195 | Constant_Condition_Warnings := True; | |
3196 | Elab_Warnings := False; | |
3197 | Implementation_Unit_Warnings := False; | |
3198 | Ineffective_Inline_Warnings := True; | |
5b5df4a9 | 3199 | List_Inherited_Aspects := False; |
12308590 | 3200 | Warn_On_Ada_2005_Compatibility := True; |
1052d172 | 3201 | Warn_On_Ada_2012_Compatibility := True; |
12308590 | 3202 | Warn_On_All_Unread_Out_Parameters := False; |
3203 | Warn_On_Assertion_Failure := True; | |
3204 | Warn_On_Assumed_Low_Bound := True; | |
3205 | Warn_On_Bad_Fixed_Value := True; | |
3206 | Warn_On_Biased_Representation := True; | |
3207 | Warn_On_Constant := True; | |
3208 | Warn_On_Deleted_Code := False; | |
3209 | Warn_On_Dereference := False; | |
3210 | Warn_On_Export_Import := True; | |
3211 | Warn_On_Hiding := False; | |
3212 | Warn_On_Modified_Unread := True; | |
3213 | Warn_On_No_Value_Assigned := True; | |
3214 | Warn_On_Non_Local_Exception := False; | |
3215 | Warn_On_Object_Renames_Function := False; | |
3216 | Warn_On_Obsolescent_Feature := True; | |
3217 | Warn_On_Questionable_Missing_Parens := True; | |
3218 | Warn_On_Redundant_Constructs := True; | |
d36a3269 | 3219 | Warn_On_Reverse_Bit_Order := False; |
12308590 | 3220 | Warn_On_Object_Renames_Function := True; |
3221 | Warn_On_Unchecked_Conversion := True; | |
a22215d6 | 3222 | Warn_On_Unordered_Enumeration_Type := False; |
12308590 | 3223 | Warn_On_Unrecognized_Pragma := True; |
3224 | Warn_On_Unrepped_Components := False; | |
3225 | Warn_On_Warnings_Off := False; | |
3226 | end Set_GNAT_Mode_Warnings; | |
3227 | ||
84731ab2 | 3228 | ------------------------ |
3229 | -- Set_Warning_Switch -- | |
3230 | ------------------------ | |
3231 | ||
3232 | function Set_Warning_Switch (C : Character) return Boolean is | |
3233 | begin | |
3234 | case C is | |
3235 | when 'a' => | |
c0d40c9a | 3236 | Check_Unreferenced := True; |
3237 | Check_Unreferenced_Formals := True; | |
3238 | Check_Withs := True; | |
3239 | Constant_Condition_Warnings := True; | |
3240 | Implementation_Unit_Warnings := True; | |
3241 | Ineffective_Inline_Warnings := True; | |
5b5df4a9 | 3242 | List_Inherited_Aspects := True; |
c0d40c9a | 3243 | Warn_On_Ada_2005_Compatibility := True; |
1052d172 | 3244 | Warn_On_Ada_2012_Compatibility := True; |
ed683f94 | 3245 | Warn_On_Assertion_Failure := True; |
c0d40c9a | 3246 | Warn_On_Assumed_Low_Bound := True; |
3247 | Warn_On_Bad_Fixed_Value := True; | |
cc46ff4b | 3248 | Warn_On_Biased_Representation := True; |
c0d40c9a | 3249 | Warn_On_Constant := True; |
3250 | Warn_On_Export_Import := True; | |
3251 | Warn_On_Modified_Unread := True; | |
3252 | Warn_On_No_Value_Assigned := True; | |
ef7e1793 | 3253 | Warn_On_Non_Local_Exception := True; |
d55c93e0 | 3254 | Warn_On_Object_Renames_Function := True; |
c0d40c9a | 3255 | Warn_On_Obsolescent_Feature := True; |
d55c93e0 | 3256 | Warn_On_Parameter_Order := True; |
c0d40c9a | 3257 | Warn_On_Questionable_Missing_Parens := True; |
3258 | Warn_On_Redundant_Constructs := True; | |
d36a3269 | 3259 | Warn_On_Reverse_Bit_Order := True; |
c0d40c9a | 3260 | Warn_On_Unchecked_Conversion := True; |
3261 | Warn_On_Unrecognized_Pragma := True; | |
8255b799 | 3262 | Warn_On_Unrepped_Components := True; |
84731ab2 | 3263 | |
3264 | when 'A' => | |
d36a3269 | 3265 | Address_Clause_Overlay_Warnings := False; |
c0d40c9a | 3266 | Check_Unreferenced := False; |
3267 | Check_Unreferenced_Formals := False; | |
3268 | Check_Withs := False; | |
3269 | Constant_Condition_Warnings := False; | |
3270 | Elab_Warnings := False; | |
3271 | Implementation_Unit_Warnings := False; | |
3272 | Ineffective_Inline_Warnings := False; | |
5b5df4a9 | 3273 | List_Inherited_Aspects := False; |
c0d40c9a | 3274 | Warn_On_Ada_2005_Compatibility := False; |
1052d172 | 3275 | Warn_On_Ada_2012_Compatibility := False; |
d36a3269 | 3276 | Warn_On_All_Unread_Out_Parameters := False; |
ed683f94 | 3277 | Warn_On_Assertion_Failure := False; |
3278 | Warn_On_Assumed_Low_Bound := False; | |
c0d40c9a | 3279 | Warn_On_Bad_Fixed_Value := False; |
cc46ff4b | 3280 | Warn_On_Biased_Representation := False; |
c0d40c9a | 3281 | Warn_On_Constant := False; |
3282 | Warn_On_Deleted_Code := False; | |
3283 | Warn_On_Dereference := False; | |
3284 | Warn_On_Export_Import := False; | |
3285 | Warn_On_Hiding := False; | |
3286 | Warn_On_Modified_Unread := False; | |
3287 | Warn_On_No_Value_Assigned := False; | |
ef7e1793 | 3288 | Warn_On_Non_Local_Exception := False; |
d36a3269 | 3289 | Warn_On_Object_Renames_Function := False; |
c0d40c9a | 3290 | Warn_On_Obsolescent_Feature := False; |
aaf44d5a | 3291 | Warn_On_Overlap := False; |
a0fc8c5b | 3292 | Warn_On_Overridden_Size := False; |
d55c93e0 | 3293 | Warn_On_Parameter_Order := False; |
47495553 | 3294 | Warn_On_Record_Holes := False; |
ef7e1793 | 3295 | Warn_On_Questionable_Missing_Parens := False; |
c0d40c9a | 3296 | Warn_On_Redundant_Constructs := False; |
d36a3269 | 3297 | Warn_On_Reverse_Bit_Order := False; |
c0d40c9a | 3298 | Warn_On_Unchecked_Conversion := False; |
a22215d6 | 3299 | Warn_On_Unordered_Enumeration_Type := False; |
c0d40c9a | 3300 | Warn_On_Unrecognized_Pragma := False; |
8255b799 | 3301 | Warn_On_Unrepped_Components := False; |
059bd36a | 3302 | Warn_On_Warnings_Off := False; |
84731ab2 | 3303 | |
30e5c8d3 | 3304 | No_Warn_On_Non_Local_Exception := True; |
3305 | ||
84731ab2 | 3306 | when 'b' => |
c0d40c9a | 3307 | Warn_On_Bad_Fixed_Value := True; |
84731ab2 | 3308 | |
3309 | when 'B' => | |
c0d40c9a | 3310 | Warn_On_Bad_Fixed_Value := False; |
84731ab2 | 3311 | |
3312 | when 'c' => | |
c0d40c9a | 3313 | Constant_Condition_Warnings := True; |
84731ab2 | 3314 | |
3315 | when 'C' => | |
c0d40c9a | 3316 | Constant_Condition_Warnings := False; |
84731ab2 | 3317 | |
3318 | when 'd' => | |
c0d40c9a | 3319 | Warn_On_Dereference := True; |
84731ab2 | 3320 | |
3321 | when 'D' => | |
c0d40c9a | 3322 | Warn_On_Dereference := False; |
84731ab2 | 3323 | |
3324 | when 'e' => | |
c0d40c9a | 3325 | Warning_Mode := Treat_As_Error; |
84731ab2 | 3326 | |
3327 | when 'f' => | |
c0d40c9a | 3328 | Check_Unreferenced_Formals := True; |
84731ab2 | 3329 | |
3330 | when 'F' => | |
c0d40c9a | 3331 | Check_Unreferenced_Formals := False; |
84731ab2 | 3332 | |
3333 | when 'g' => | |
c0d40c9a | 3334 | Warn_On_Unrecognized_Pragma := True; |
84731ab2 | 3335 | |
3336 | when 'G' => | |
c0d40c9a | 3337 | Warn_On_Unrecognized_Pragma := False; |
84731ab2 | 3338 | |
3339 | when 'h' => | |
c0d40c9a | 3340 | Warn_On_Hiding := True; |
84731ab2 | 3341 | |
3342 | when 'H' => | |
c0d40c9a | 3343 | Warn_On_Hiding := False; |
84731ab2 | 3344 | |
3345 | when 'i' => | |
c0d40c9a | 3346 | Implementation_Unit_Warnings := True; |
84731ab2 | 3347 | |
3348 | when 'I' => | |
c0d40c9a | 3349 | Implementation_Unit_Warnings := False; |
84731ab2 | 3350 | |
3351 | when 'j' => | |
c0d40c9a | 3352 | Warn_On_Obsolescent_Feature := True; |
84731ab2 | 3353 | |
3354 | when 'J' => | |
c0d40c9a | 3355 | Warn_On_Obsolescent_Feature := False; |
84731ab2 | 3356 | |
3357 | when 'k' => | |
c0d40c9a | 3358 | Warn_On_Constant := True; |
84731ab2 | 3359 | |
3360 | when 'K' => | |
c0d40c9a | 3361 | Warn_On_Constant := False; |
84731ab2 | 3362 | |
3363 | when 'l' => | |
c0d40c9a | 3364 | Elab_Warnings := True; |
84731ab2 | 3365 | |
3366 | when 'L' => | |
c0d40c9a | 3367 | Elab_Warnings := False; |
84731ab2 | 3368 | |
3369 | when 'm' => | |
c0d40c9a | 3370 | Warn_On_Modified_Unread := True; |
84731ab2 | 3371 | |
3372 | when 'M' => | |
c0d40c9a | 3373 | Warn_On_Modified_Unread := False; |
84731ab2 | 3374 | |
3375 | when 'n' => | |
c0d40c9a | 3376 | Warning_Mode := Normal; |
84731ab2 | 3377 | |
3378 | when 'o' => | |
c0d40c9a | 3379 | Address_Clause_Overlay_Warnings := True; |
84731ab2 | 3380 | |
3381 | when 'O' => | |
c0d40c9a | 3382 | Address_Clause_Overlay_Warnings := False; |
84731ab2 | 3383 | |
3384 | when 'p' => | |
c0d40c9a | 3385 | Ineffective_Inline_Warnings := True; |
84731ab2 | 3386 | |
3387 | when 'P' => | |
c0d40c9a | 3388 | Ineffective_Inline_Warnings := False; |
3389 | ||
3390 | when 'q' => | |
3391 | Warn_On_Questionable_Missing_Parens := True; | |
3392 | ||
3393 | when 'Q' => | |
3394 | Warn_On_Questionable_Missing_Parens := False; | |
84731ab2 | 3395 | |
3396 | when 'r' => | |
c0d40c9a | 3397 | Warn_On_Redundant_Constructs := True; |
84731ab2 | 3398 | |
3399 | when 'R' => | |
c0d40c9a | 3400 | Warn_On_Redundant_Constructs := False; |
84731ab2 | 3401 | |
3402 | when 's' => | |
c0d40c9a | 3403 | Warning_Mode := Suppress; |
3404 | ||
3405 | when 't' => | |
3406 | Warn_On_Deleted_Code := True; | |
3407 | ||
3408 | when 'T' => | |
3409 | Warn_On_Deleted_Code := False; | |
84731ab2 | 3410 | |
3411 | when 'u' => | |
c0d40c9a | 3412 | Check_Unreferenced := True; |
3413 | Check_Withs := True; | |
3414 | Check_Unreferenced_Formals := True; | |
84731ab2 | 3415 | |
3416 | when 'U' => | |
c0d40c9a | 3417 | Check_Unreferenced := False; |
3418 | Check_Withs := False; | |
3419 | Check_Unreferenced_Formals := False; | |
84731ab2 | 3420 | |
3421 | when 'v' => | |
c0d40c9a | 3422 | Warn_On_No_Value_Assigned := True; |
84731ab2 | 3423 | |
3424 | when 'V' => | |
c0d40c9a | 3425 | Warn_On_No_Value_Assigned := False; |
3426 | ||
3427 | when 'w' => | |
3428 | Warn_On_Assumed_Low_Bound := True; | |
3429 | ||
3430 | when 'W' => | |
3431 | Warn_On_Assumed_Low_Bound := False; | |
84731ab2 | 3432 | |
3433 | when 'x' => | |
c0d40c9a | 3434 | Warn_On_Export_Import := True; |
84731ab2 | 3435 | |
3436 | when 'X' => | |
c0d40c9a | 3437 | Warn_On_Export_Import := False; |
84731ab2 | 3438 | |
3439 | when 'y' => | |
c0d40c9a | 3440 | Warn_On_Ada_2005_Compatibility := True; |
1052d172 | 3441 | Warn_On_Ada_2012_Compatibility := True; |
84731ab2 | 3442 | |
3443 | when 'Y' => | |
c0d40c9a | 3444 | Warn_On_Ada_2005_Compatibility := False; |
1052d172 | 3445 | Warn_On_Ada_2012_Compatibility := False; |
84731ab2 | 3446 | |
3447 | when 'z' => | |
c0d40c9a | 3448 | Warn_On_Unchecked_Conversion := True; |
84731ab2 | 3449 | |
3450 | when 'Z' => | |
c0d40c9a | 3451 | Warn_On_Unchecked_Conversion := False; |
84731ab2 | 3452 | |
3453 | when others => | |
3454 | return False; | |
3455 | end case; | |
3456 | ||
3457 | return True; | |
3458 | end Set_Warning_Switch; | |
3459 | ||
d6f39728 | 3460 | ----------------------------- |
3461 | -- Warn_On_Known_Condition -- | |
3462 | ----------------------------- | |
3463 | ||
3464 | procedure Warn_On_Known_Condition (C : Node_Id) is | |
11b376d2 | 3465 | P : Node_Id; |
3466 | Orig : constant Node_Id := Original_Node (C); | |
3467 | Test_Result : Boolean; | |
3468 | ||
3469 | function Is_Known_Branch return Boolean; | |
3470 | -- If the type of the condition is Boolean, the constant value of the | |
3471 | -- condition is a boolean literal. If the type is a derived boolean | |
3472 | -- type, the constant is wrapped in a type conversion of the derived | |
3473 | -- literal. If the value of the condition is not a literal, no warnings | |
3474 | -- can be produced. This function returns True if the result can be | |
3475 | -- determined, and Test_Result is set True/False accordingly. Otherwise | |
3476 | -- False is returned, and Test_Result is unchanged. | |
d6f39728 | 3477 | |
c0d40c9a | 3478 | procedure Track (N : Node_Id; Loc : Node_Id); |
3479 | -- Adds continuation warning(s) pointing to reason (assignment or test) | |
3480 | -- for the operand of the conditional having a known value (or at least | |
3481 | -- enough is known about the value to issue the warning). N is the node | |
3482 | -- which is judged to have a known value. Loc is the warning location. | |
3483 | ||
11b376d2 | 3484 | --------------------- |
3485 | -- Is_Known_Branch -- | |
3486 | --------------------- | |
3487 | ||
3488 | function Is_Known_Branch return Boolean is | |
3489 | begin | |
3490 | if Etype (C) = Standard_Boolean | |
3491 | and then Is_Entity_Name (C) | |
3492 | and then | |
3493 | (Entity (C) = Standard_False or else Entity (C) = Standard_True) | |
3494 | then | |
3495 | Test_Result := Entity (C) = Standard_True; | |
3496 | return True; | |
3497 | ||
3498 | elsif Is_Boolean_Type (Etype (C)) | |
3499 | and then Nkind (C) = N_Unchecked_Type_Conversion | |
3500 | and then Is_Entity_Name (Expression (C)) | |
3501 | and then Ekind (Entity (Expression (C))) = E_Enumeration_Literal | |
3502 | then | |
3503 | Test_Result := | |
3504 | Chars (Entity (Expression (C))) = Chars (Standard_True); | |
3505 | return True; | |
3506 | ||
3507 | else | |
3508 | return False; | |
3509 | end if; | |
3510 | end Is_Known_Branch; | |
3511 | ||
c0d40c9a | 3512 | ----------- |
3513 | -- Track -- | |
3514 | ----------- | |
3515 | ||
3516 | procedure Track (N : Node_Id; Loc : Node_Id) is | |
3517 | Nod : constant Node_Id := Original_Node (N); | |
3518 | ||
3519 | begin | |
3520 | if Nkind (Nod) in N_Op_Compare then | |
3521 | Track (Left_Opnd (Nod), Loc); | |
3522 | Track (Right_Opnd (Nod), Loc); | |
3523 | ||
3524 | elsif Is_Entity_Name (Nod) | |
3525 | and then Is_Object (Entity (Nod)) | |
3526 | then | |
3527 | declare | |
3528 | CV : constant Node_Id := Current_Value (Entity (Nod)); | |
3529 | ||
3530 | begin | |
3531 | if Present (CV) then | |
3532 | Error_Msg_Sloc := Sloc (CV); | |
3533 | ||
3534 | if Nkind (CV) not in N_Subexpr then | |
3535 | Error_Msg_N ("\\?(see test #)", Loc); | |
3536 | ||
3537 | elsif Nkind (Parent (CV)) = | |
3538 | N_Case_Statement_Alternative | |
3539 | then | |
3540 | Error_Msg_N ("\\?(see case alternative #)", Loc); | |
3541 | ||
3542 | else | |
3543 | Error_Msg_N ("\\?(see assignment #)", Loc); | |
3544 | end if; | |
3545 | end if; | |
3546 | end; | |
3547 | end if; | |
3548 | end Track; | |
3549 | ||
3550 | -- Start of processing for Warn_On_Known_Condition | |
3551 | ||
d6f39728 | 3552 | begin |
902e2182 | 3553 | -- Adjust SCO condition if from source |
3554 | ||
7734e2ae | 3555 | if Generate_SCO |
3556 | and then Comes_From_Source (Orig) | |
11b376d2 | 3557 | and then Is_Known_Branch |
7734e2ae | 3558 | then |
902e2182 | 3559 | declare |
902e2182 | 3560 | Atrue : Boolean; |
3561 | ||
3562 | begin | |
11b376d2 | 3563 | Atrue := Test_Result; |
902e2182 | 3564 | |
006b904a | 3565 | if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then |
902e2182 | 3566 | Atrue := not Atrue; |
3567 | end if; | |
3568 | ||
9a4f36a4 | 3569 | Set_SCO_Condition (Orig, Atrue); |
902e2182 | 3570 | end; |
3571 | end if; | |
3572 | ||
b05b9ac6 | 3573 | -- Argument replacement in an inlined body can make conditions static. |
3574 | -- Do not emit warnings in this case. | |
9dfe12ae | 3575 | |
3576 | if In_Inlined_Body then | |
3577 | return; | |
3578 | end if; | |
3579 | ||
d6f39728 | 3580 | if Constant_Condition_Warnings |
11b376d2 | 3581 | and then Is_Known_Branch |
d6f39728 | 3582 | and then Comes_From_Source (Original_Node (C)) |
3583 | and then not In_Instance | |
3584 | then | |
3585 | -- See if this is in a statement or a declaration | |
3586 | ||
3587 | P := Parent (C); | |
3588 | loop | |
3589 | -- If tree is not attached, do not issue warning (this is very | |
3590 | -- peculiar, and probably arises from some other error condition) | |
3591 | ||
3592 | if No (P) then | |
3593 | return; | |
3594 | ||
3595 | -- If we are in a declaration, then no warning, since in practice | |
3596 | -- conditionals in declarations are used for intended tests which | |
3597 | -- may be known at compile time, e.g. things like | |
3598 | ||
3599 | -- x : constant Integer := 2 + (Word'Size = 32); | |
3600 | ||
3601 | -- And a warning is annoying in such cases | |
3602 | ||
3603 | elsif Nkind (P) in N_Declaration | |
3604 | or else | |
3605 | Nkind (P) in N_Later_Decl_Item | |
3606 | then | |
3607 | return; | |
3608 | ||
d55c93e0 | 3609 | -- Don't warn in assert or check pragma, since presumably tests in |
3610 | -- such a context are very definitely intended, and might well be | |
d6f39728 | 3611 | -- known at compile time. Note that we have to test the original |
3612 | -- node, since assert pragmas get rewritten at analysis time. | |
3613 | ||
3614 | elsif Nkind (Original_Node (P)) = N_Pragma | |
d55c93e0 | 3615 | and then (Pragma_Name (Original_Node (P)) = Name_Assert |
3616 | or else | |
3617 | Pragma_Name (Original_Node (P)) = Name_Check) | |
d6f39728 | 3618 | then |
3619 | return; | |
3620 | end if; | |
3621 | ||
3622 | exit when Is_Statement (P); | |
3623 | P := Parent (P); | |
3624 | end loop; | |
3625 | ||
f15731c4 | 3626 | -- Here we issue the warning unless some sub-operand has warnings |
81afcaba | 3627 | -- set off, in which case we suppress the warning for the node. If |
3628 | -- the original expression is an inequality, it has been expanded | |
3629 | -- into a negation, and the value of the original expression is the | |
3630 | -- negation of the equality. If the expression is an entity that | |
3631 | -- appears within a negation, it is clearer to flag the negation | |
3632 | -- itself, and report on its constant value. | |
f15731c4 | 3633 | |
3634 | if not Operand_Has_Warnings_Suppressed (C) then | |
81afcaba | 3635 | declare |
11b376d2 | 3636 | True_Branch : Boolean := Test_Result; |
81afcaba | 3637 | Cond : Node_Id := C; |
3638 | ||
3639 | begin | |
3640 | if Present (Parent (C)) | |
3641 | and then Nkind (Parent (C)) = N_Op_Not | |
3642 | then | |
3643 | True_Branch := not True_Branch; | |
3644 | Cond := Parent (C); | |
3645 | end if; | |
3646 | ||
3647 | if True_Branch then | |
c227996d | 3648 | if Is_Entity_Name (Original_Node (C)) |
3649 | and then Nkind (Cond) /= N_Op_Not | |
3650 | then | |
503f7fd3 | 3651 | Error_Msg_NE |
c0d40c9a | 3652 | ("object & is always True?", Cond, Original_Node (C)); |
3653 | Track (Original_Node (C), Cond); | |
3654 | ||
c227996d | 3655 | else |
503f7fd3 | 3656 | Error_Msg_N ("condition is always True?", Cond); |
c0d40c9a | 3657 | Track (Cond, Cond); |
c227996d | 3658 | end if; |
c0d40c9a | 3659 | |
81afcaba | 3660 | else |
503f7fd3 | 3661 | Error_Msg_N ("condition is always False?", Cond); |
c0d40c9a | 3662 | Track (Cond, Cond); |
81afcaba | 3663 | end if; |
3664 | end; | |
d6f39728 | 3665 | end if; |
3666 | end if; | |
3667 | end Warn_On_Known_Condition; | |
3668 | ||
ed683f94 | 3669 | --------------------------------------- |
3670 | -- Warn_On_Modified_As_Out_Parameter -- | |
3671 | --------------------------------------- | |
3672 | ||
3673 | function Warn_On_Modified_As_Out_Parameter (E : Entity_Id) return Boolean is | |
3674 | begin | |
3675 | return | |
3676 | (Warn_On_Modified_Unread and then Is_Only_Out_Parameter (E)) | |
3677 | or else Warn_On_All_Unread_Out_Parameters; | |
3678 | end Warn_On_Modified_As_Out_Parameter; | |
3679 | ||
5f8d6158 | 3680 | --------------------------------- |
3681 | -- Warn_On_Overlapping_Actuals -- | |
3682 | --------------------------------- | |
3683 | ||
3684 | procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is | |
3685 | Act1, Act2 : Node_Id; | |
3686 | Form1, Form2 : Entity_Id; | |
3687 | ||
3688 | begin | |
aaf44d5a | 3689 | if not Warn_On_Overlap then |
5f8d6158 | 3690 | return; |
3691 | end if; | |
3692 | ||
3693 | -- Exclude calls rewritten as enumeration literals | |
3694 | ||
7d296b15 | 3695 | if not Nkind_In (N, N_Function_Call, N_Procedure_Call_Statement) then |
5f8d6158 | 3696 | return; |
3697 | end if; | |
3698 | ||
7d296b15 | 3699 | -- Exclude calls to library subprograms. Container operations specify |
3700 | -- safe behavior when source and target coincide. | |
5f8d6158 | 3701 | |
7d296b15 | 3702 | if Is_Predefined_File_Name |
3703 | (Unit_File_Name (Get_Source_Unit (Sloc (Subp)))) | |
5f8d6158 | 3704 | then |
3705 | return; | |
3706 | end if; | |
3707 | ||
3708 | Form1 := First_Formal (Subp); | |
3709 | Act1 := First_Actual (N); | |
5f8d6158 | 3710 | while Present (Form1) and then Present (Act1) loop |
d97beb2f | 3711 | if Ekind (Form1) /= E_In_Parameter then |
5f8d6158 | 3712 | Form2 := First_Formal (Subp); |
3713 | Act2 := First_Actual (N); | |
5f8d6158 | 3714 | while Present (Form2) and then Present (Act2) loop |
3715 | if Form1 /= Form2 | |
3716 | and then Ekind (Form2) /= E_Out_Parameter | |
3717 | and then | |
3718 | (Denotes_Same_Object (Act1, Act2) | |
2c29c116 | 3719 | or else |
3720 | Denotes_Same_Prefix (Act1, Act2)) | |
5f8d6158 | 3721 | then |
5f8d6158 | 3722 | -- Exclude generic types and guard against previous errors. |
5f8d6158 | 3723 | |
3724 | if Error_Posted (N) | |
3725 | or else No (Etype (Act1)) | |
3726 | or else No (Etype (Act2)) | |
3727 | then | |
3728 | null; | |
3729 | ||
3730 | elsif Is_Generic_Type (Etype (Act1)) | |
7d296b15 | 3731 | or else |
3732 | Is_Generic_Type (Etype (Act2)) | |
5f8d6158 | 3733 | then |
3734 | null; | |
3735 | ||
3736 | -- If the actual is a function call in prefix notation, | |
3737 | -- there is no real overlap. | |
3738 | ||
3739 | elsif Nkind (Act2) = N_Function_Call then | |
3740 | null; | |
3741 | ||
13fc4f7a | 3742 | -- If type is not by-copy we can assume that the aliasing is |
3743 | -- intended. | |
aaf44d5a | 3744 | |
d97beb2f | 3745 | elsif |
3746 | Is_By_Reference_Type (Underlying_Type (Etype (Form1))) | |
5f8d6158 | 3747 | then |
3748 | null; | |
2c29c116 | 3749 | |
5f8d6158 | 3750 | else |
3751 | declare | |
3752 | Act : Node_Id; | |
3753 | Form : Entity_Id; | |
2c29c116 | 3754 | |
5f8d6158 | 3755 | begin |
2c29c116 | 3756 | -- Find matching actual |
3757 | ||
5f8d6158 | 3758 | Act := First_Actual (N); |
3759 | Form := First_Formal (Subp); | |
3760 | while Act /= Act2 loop | |
3761 | Next_Formal (Form); | |
3762 | Next_Actual (Act); | |
3763 | end loop; | |
3764 | ||
d97beb2f | 3765 | if Is_Elementary_Type (Etype (Act1)) |
3766 | and then Ekind (Form2) = E_In_Parameter | |
3767 | then | |
3768 | null; -- no real aliasing. | |
3769 | ||
3770 | elsif Is_Elementary_Type (Etype (Act2)) | |
3771 | and then Ekind (Form2) = E_In_Parameter | |
3772 | then | |
3773 | null; -- ditto | |
3774 | ||
aaf44d5a | 3775 | -- If the call was written in prefix notation, and |
3776 | -- thus its prefix before rewriting was a selected | |
3777 | -- component, count only visible actuals in the call. | |
2c29c116 | 3778 | |
d97beb2f | 3779 | elsif Is_Entity_Name (First_Actual (N)) |
5f8d6158 | 3780 | and then Nkind (Original_Node (N)) = Nkind (N) |
7d296b15 | 3781 | and then Nkind (Name (Original_Node (N))) = |
3782 | N_Selected_Component | |
5f8d6158 | 3783 | and then |
3784 | Is_Entity_Name (Prefix (Name (Original_Node (N)))) | |
3785 | and then | |
3786 | Entity (Prefix (Name (Original_Node (N)))) = | |
3787 | Entity (First_Actual (N)) | |
3788 | then | |
3789 | if Act1 = First_Actual (N) then | |
3790 | Error_Msg_FE | |
7d296b15 | 3791 | ("`IN OUT` prefix overlaps with actual for&?", |
5f8d6158 | 3792 | Act1, Form); |
3793 | else | |
3794 | Error_Msg_FE | |
2c29c116 | 3795 | ("writable actual overlaps with actual for&?", |
3796 | Act1, Form); | |
5f8d6158 | 3797 | end if; |
3798 | ||
3799 | else | |
490beba6 | 3800 | Error_Msg_Node_2 := Form; |
5f8d6158 | 3801 | Error_Msg_FE |
490beba6 | 3802 | ("writable actual for & overlaps with" |
3803 | & " actual for&?", Act1, Form1); | |
5f8d6158 | 3804 | end if; |
3805 | end; | |
3806 | end if; | |
2c29c116 | 3807 | |
5f8d6158 | 3808 | return; |
3809 | end if; | |
3810 | ||
3811 | Next_Formal (Form2); | |
3812 | Next_Actual (Act2); | |
3813 | end loop; | |
3814 | end if; | |
3815 | ||
3816 | Next_Formal (Form1); | |
3817 | Next_Actual (Act1); | |
3818 | end loop; | |
3819 | end Warn_On_Overlapping_Actuals; | |
3820 | ||
c0d40c9a | 3821 | ------------------------------ |
3822 | -- Warn_On_Suspicious_Index -- | |
3823 | ------------------------------ | |
3824 | ||
3825 | procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id) is | |
3826 | ||
3827 | Low_Bound : Uint; | |
3828 | -- Set to lower bound for a suspicious type | |
3829 | ||
3830 | Ent : Entity_Id; | |
3831 | -- Entity for array reference | |
3832 | ||
3833 | Typ : Entity_Id; | |
3834 | -- Array type | |
3835 | ||
3836 | function Is_Suspicious_Type (Typ : Entity_Id) return Boolean; | |
3837 | -- Tests to see if Typ is a type for which we may have a suspicious | |
3838 | -- index, namely an unconstrained array type, whose lower bound is | |
3839 | -- either zero or one. If so, True is returned, and Low_Bound is set | |
3840 | -- to this lower bound. If not, False is returned, and Low_Bound is | |
3841 | -- undefined on return. | |
3842 | -- | |
1a34e48c | 3843 | -- For now, we limit this to standard string types, so any other |
c0d40c9a | 3844 | -- unconstrained types return False. We may change our minds on this |
3845 | -- later on, but strings seem the most important case. | |
3846 | ||
3847 | procedure Test_Suspicious_Index; | |
3848 | -- Test if index is of suspicious type and if so, generate warning | |
3849 | ||
3850 | ------------------------ | |
3851 | -- Is_Suspicious_Type -- | |
3852 | ------------------------ | |
3853 | ||
3854 | function Is_Suspicious_Type (Typ : Entity_Id) return Boolean is | |
3855 | LB : Node_Id; | |
3856 | ||
3857 | begin | |
3858 | if Is_Array_Type (Typ) | |
3859 | and then not Is_Constrained (Typ) | |
3860 | and then Number_Dimensions (Typ) = 1 | |
c0d40c9a | 3861 | and then (Root_Type (Typ) = Standard_String |
3862 | or else | |
3863 | Root_Type (Typ) = Standard_Wide_String | |
3864 | or else | |
3865 | Root_Type (Typ) = Standard_Wide_Wide_String) | |
059bd36a | 3866 | and then not Has_Warnings_Off (Typ) |
c0d40c9a | 3867 | then |
3868 | LB := Type_Low_Bound (Etype (First_Index (Typ))); | |
3869 | ||
3870 | if Compile_Time_Known_Value (LB) then | |
3871 | Low_Bound := Expr_Value (LB); | |
3872 | return Low_Bound = Uint_0 or else Low_Bound = Uint_1; | |
3873 | end if; | |
3874 | end if; | |
3875 | ||
3876 | return False; | |
3877 | end Is_Suspicious_Type; | |
3878 | ||
3879 | --------------------------- | |
3880 | -- Test_Suspicious_Index -- | |
3881 | --------------------------- | |
3882 | ||
3883 | procedure Test_Suspicious_Index is | |
3884 | ||
3885 | function Length_Reference (N : Node_Id) return Boolean; | |
3886 | -- Check if node N is of the form Name'Length | |
3887 | ||
3888 | procedure Warn1; | |
3889 | -- Generate first warning line | |
3890 | ||
3891 | ---------------------- | |
3892 | -- Length_Reference -- | |
3893 | ---------------------- | |
3894 | ||
3895 | function Length_Reference (N : Node_Id) return Boolean is | |
3896 | R : constant Node_Id := Original_Node (N); | |
3897 | begin | |
3898 | return | |
3899 | Nkind (R) = N_Attribute_Reference | |
3900 | and then Attribute_Name (R) = Name_Length | |
3901 | and then Is_Entity_Name (Prefix (R)) | |
3902 | and then Entity (Prefix (R)) = Ent; | |
3903 | end Length_Reference; | |
3904 | ||
3905 | ----------- | |
3906 | -- Warn1 -- | |
3907 | ----------- | |
3908 | ||
3909 | procedure Warn1 is | |
3910 | begin | |
3911 | Error_Msg_Uint_1 := Low_Bound; | |
e977c0cf | 3912 | Error_Msg_FE -- CODEFIX |
3913 | ("?index for& may assume lower bound of^", X, Ent); | |
c0d40c9a | 3914 | end Warn1; |
3915 | ||
3916 | -- Start of processing for Test_Suspicious_Index | |
3917 | ||
3918 | begin | |
3919 | -- Nothing to do if subscript does not come from source (we don't | |
3920 | -- want to give garbage warnings on compiler expanded code, e.g. the | |
1a34e48c | 3921 | -- loops generated for slice assignments. Such junk warnings would |
c0d40c9a | 3922 | -- be placed on source constructs with no subscript in sight!) |
3923 | ||
3924 | if not Comes_From_Source (Original_Node (X)) then | |
3925 | return; | |
3926 | end if; | |
3927 | ||
3928 | -- Case where subscript is a constant integer | |
3929 | ||
3930 | if Nkind (X) = N_Integer_Literal then | |
3931 | Warn1; | |
3932 | ||
3933 | -- Case where original form of subscript is an integer literal | |
3934 | ||
3935 | if Nkind (Original_Node (X)) = N_Integer_Literal then | |
3936 | if Intval (X) = Low_Bound then | |
e977c0cf | 3937 | Error_Msg_FE -- CODEFIX |
c0d40c9a | 3938 | ("\suggested replacement: `&''First`", X, Ent); |
3939 | else | |
3940 | Error_Msg_Uint_1 := Intval (X) - Low_Bound; | |
e977c0cf | 3941 | Error_Msg_FE -- CODEFIX |
c0d40c9a | 3942 | ("\suggested replacement: `&''First + ^`", X, Ent); |
3943 | ||
3944 | end if; | |
3945 | ||
3946 | -- Case where original form of subscript is more complex | |
3947 | ||
3948 | else | |
3949 | -- Build string X'First - 1 + expression where the expression | |
3950 | -- is the original subscript. If the expression starts with "1 | |
3951 | -- + ", then the "- 1 + 1" is elided. | |
3952 | ||
3953 | Error_Msg_String (1 .. 13) := "'First - 1 + "; | |
3954 | Error_Msg_Strlen := 13; | |
3955 | ||
3956 | declare | |
3957 | Sref : Source_Ptr := Sloc (First_Node (Original_Node (X))); | |
3958 | Tref : constant Source_Buffer_Ptr := | |
3959 | Source_Text (Get_Source_File_Index (Sref)); | |
3960 | -- Tref (Sref) is used to scan the subscript | |
3961 | ||
3962 | Pctr : Natural; | |
1a34e48c | 3963 | -- Parentheses counter when scanning subscript |
c0d40c9a | 3964 | |
3965 | begin | |
3966 | -- Tref (Sref) points to start of subscript | |
3967 | ||
3968 | -- Elide - 1 if subscript starts with 1 + | |
3969 | ||
3970 | if Tref (Sref .. Sref + 2) = "1 +" then | |
3971 | Error_Msg_Strlen := Error_Msg_Strlen - 6; | |
3972 | Sref := Sref + 2; | |
3973 | ||
3974 | elsif Tref (Sref .. Sref + 1) = "1+" then | |
3975 | Error_Msg_Strlen := Error_Msg_Strlen - 6; | |
3976 | Sref := Sref + 1; | |
3977 | end if; | |
3978 | ||
3979 | -- Now we will copy the subscript to the string buffer | |
3980 | ||
3981 | Pctr := 0; | |
3982 | loop | |
3983 | -- Count parens, exit if terminating right paren. Note | |
3984 | -- check to ignore paren appearing as character literal. | |
3985 | ||
3986 | if Tref (Sref + 1) = ''' | |
3987 | and then | |
3988 | Tref (Sref - 1) = ''' | |
3989 | then | |
3990 | null; | |
3991 | else | |
3992 | if Tref (Sref) = '(' then | |
3993 | Pctr := Pctr + 1; | |
3994 | elsif Tref (Sref) = ')' then | |
3995 | exit when Pctr = 0; | |
3996 | Pctr := Pctr - 1; | |
3997 | end if; | |
3998 | end if; | |
3999 | ||
4000 | -- Done if terminating double dot (slice case) | |
4001 | ||
4002 | exit when Pctr = 0 | |
4003 | and then (Tref (Sref .. Sref + 1) = ".." | |
4004 | or else | |
4005 | Tref (Sref .. Sref + 2) = " .."); | |
4006 | ||
4007 | -- Quit if we have hit EOF character, something wrong | |
4008 | ||
4009 | if Tref (Sref) = EOF then | |
4010 | return; | |
4011 | end if; | |
4012 | ||
4013 | -- String literals are too much of a pain to handle | |
4014 | ||
4015 | if Tref (Sref) = '"' or else Tref (Sref) = '%' then | |
4016 | return; | |
4017 | end if; | |
4018 | ||
4019 | -- If we have a 'Range reference, then this is a case | |
4020 | -- where we cannot easily give a replacement. Don't try! | |
4021 | ||
4022 | if Tref (Sref .. Sref + 4) = "range" | |
4023 | and then Tref (Sref - 1) < 'A' | |
4024 | and then Tref (Sref + 5) < 'A' | |
4025 | then | |
4026 | return; | |
4027 | end if; | |
4028 | ||
4029 | -- Else store next character | |
4030 | ||
4031 | Error_Msg_Strlen := Error_Msg_Strlen + 1; | |
4032 | Error_Msg_String (Error_Msg_Strlen) := Tref (Sref); | |
4033 | Sref := Sref + 1; | |
4034 | ||
4035 | -- If we get more than 40 characters then the expression | |
4036 | -- is too long to copy, or something has gone wrong. In | |
4037 | -- either case, just skip the attempt at a suggested fix. | |
4038 | ||
4039 | if Error_Msg_Strlen > 40 then | |
4040 | return; | |
4041 | end if; | |
4042 | end loop; | |
4043 | end; | |
4044 | ||
4045 | -- Replacement subscript is now in string buffer | |
4046 | ||
e977c0cf | 4047 | Error_Msg_FE -- CODEFIX |
c0d40c9a | 4048 | ("\suggested replacement: `&~`", Original_Node (X), Ent); |
4049 | end if; | |
4050 | ||
4051 | -- Case where subscript is of the form X'Length | |
4052 | ||
4053 | elsif Length_Reference (X) then | |
4054 | Warn1; | |
4055 | Error_Msg_Node_2 := Ent; | |
503f7fd3 | 4056 | Error_Msg_FE |
c0d40c9a | 4057 | ("\suggest replacement of `&''Length` by `&''Last`", |
4058 | X, Ent); | |
4059 | ||
4060 | -- Case where subscript is of the form X'Length - expression | |
4061 | ||
4062 | elsif Nkind (X) = N_Op_Subtract | |
4063 | and then Length_Reference (Left_Opnd (X)) | |
4064 | then | |
4065 | Warn1; | |
4066 | Error_Msg_Node_2 := Ent; | |
503f7fd3 | 4067 | Error_Msg_FE |
c0d40c9a | 4068 | ("\suggest replacement of `&''Length` by `&''Last`", |
4069 | Left_Opnd (X), Ent); | |
4070 | end if; | |
4071 | end Test_Suspicious_Index; | |
4072 | ||
4073 | -- Start of processing for Warn_On_Suspicious_Index | |
4074 | ||
4075 | begin | |
4076 | -- Only process if warnings activated | |
4077 | ||
4078 | if Warn_On_Assumed_Low_Bound then | |
4079 | ||
4080 | -- Test if array is simple entity name | |
4081 | ||
4082 | if Is_Entity_Name (Name) then | |
4083 | ||
4084 | -- Test if array is parameter of unconstrained string type | |
4085 | ||
4086 | Ent := Entity (Name); | |
4087 | Typ := Etype (Ent); | |
4088 | ||
4089 | if Is_Formal (Ent) | |
4090 | and then Is_Suspicious_Type (Typ) | |
19b4517d | 4091 | and then not Low_Bound_Tested (Ent) |
c0d40c9a | 4092 | then |
4093 | Test_Suspicious_Index; | |
4094 | end if; | |
4095 | end if; | |
4096 | end if; | |
4097 | end Warn_On_Suspicious_Index; | |
4098 | ||
8063f750 | 4099 | -------------------------------------- |
4100 | -- Warn_On_Unassigned_Out_Parameter -- | |
4101 | -------------------------------------- | |
4102 | ||
4103 | procedure Warn_On_Unassigned_Out_Parameter | |
4104 | (Return_Node : Node_Id; | |
4105 | Scope_Id : Entity_Id) | |
4106 | is | |
4107 | Form : Entity_Id; | |
4108 | Form2 : Entity_Id; | |
4109 | ||
4110 | begin | |
4111 | -- Ignore if procedure or return statement does not come from source | |
4112 | ||
4113 | if not Comes_From_Source (Scope_Id) | |
4114 | or else not Comes_From_Source (Return_Node) | |
4115 | then | |
4116 | return; | |
4117 | end if; | |
4118 | ||
4119 | -- Loop through formals | |
4120 | ||
4121 | Form := First_Formal (Scope_Id); | |
4122 | while Present (Form) loop | |
4123 | ||
4124 | -- We are only interested in OUT parameters that come from source | |
4125 | -- and are never set in the source, and furthermore only in scalars | |
4126 | -- since non-scalars generate too many false positives. | |
4127 | ||
4128 | if Ekind (Form) = E_Out_Parameter | |
4129 | and then Never_Set_In_Source_Check_Spec (Form) | |
4130 | and then Is_Scalar_Type (Etype (Form)) | |
4131 | and then not Present (Unset_Reference (Form)) | |
4132 | then | |
4133 | -- Before we issue the warning, an add ad hoc defence against the | |
4134 | -- most common case of false positives with this warning which is | |
4135 | -- the case where there is a Boolean OUT parameter that has been | |
4136 | -- set, and whose meaning is "ignore the values of the other | |
4137 | -- parameters". We can't of course reliably tell this case at | |
4138 | -- compile time, but the following test kills a lot of false | |
4139 | -- positives, without generating a significant number of false | |
4140 | -- negatives (missed real warnings). | |
4141 | ||
4142 | Form2 := First_Formal (Scope_Id); | |
4143 | while Present (Form2) loop | |
4144 | if Ekind (Form2) = E_Out_Parameter | |
4145 | and then Root_Type (Etype (Form2)) = Standard_Boolean | |
4146 | and then not Never_Set_In_Source_Check_Spec (Form2) | |
4147 | then | |
4148 | return; | |
4149 | end if; | |
4150 | ||
4151 | Next_Formal (Form2); | |
4152 | end loop; | |
4153 | ||
1a34e48c | 4154 | -- Here all conditions are met, record possible unset reference |
8063f750 | 4155 | |
4156 | Set_Unset_Reference (Form, Return_Node); | |
4157 | end if; | |
4158 | ||
4159 | Next_Formal (Form); | |
4160 | end loop; | |
4161 | end Warn_On_Unassigned_Out_Parameter; | |
4162 | ||
4163 | --------------------------------- | |
4164 | -- Warn_On_Unreferenced_Entity -- | |
4165 | --------------------------------- | |
4166 | ||
4167 | procedure Warn_On_Unreferenced_Entity | |
4168 | (Spec_E : Entity_Id; | |
4169 | Body_E : Entity_Id := Empty) | |
4170 | is | |
4171 | E : Entity_Id := Spec_E; | |
96da3284 | 4172 | |
8063f750 | 4173 | begin |
059bd36a | 4174 | if not Referenced_Check_Spec (E) |
4175 | and then not Has_Pragma_Unreferenced_Check_Spec (E) | |
4176 | and then not Warnings_Off_Check_Spec (E) | |
4177 | then | |
8063f750 | 4178 | case Ekind (E) is |
4179 | when E_Variable => | |
4180 | ||
ed683f94 | 4181 | -- Case of variable that is assigned but not read. We suppress |
4182 | -- the message if the variable is volatile, has an address | |
1a34e48c | 4183 | -- clause, is aliased, or is a renaming, or is imported. |
8063f750 | 4184 | |
4185 | if Referenced_As_LHS_Check_Spec (E) | |
4186 | and then No (Address_Clause (E)) | |
4187 | and then not Is_Volatile (E) | |
4188 | then | |
ed683f94 | 4189 | if Warn_On_Modified_Unread |
8063f750 | 4190 | and then not Is_Imported (E) |
8063f750 | 4191 | and then not Is_Aliased (E) |
4192 | and then No (Renamed_Object (E)) | |
8063f750 | 4193 | then |
4540a696 | 4194 | if not Has_Pragma_Unmodified_Check_Spec (E) then |
3ba6a78b | 4195 | Error_Msg_N -- CODEFIX |
4540a696 | 4196 | ("?variable & is assigned but never read!", E); |
4197 | end if; | |
4198 | ||
8063f750 | 4199 | Set_Last_Assignment (E, Empty); |
4200 | end if; | |
4201 | ||
ed683f94 | 4202 | -- Normal case of neither assigned nor read (exclude variables |
4203 | -- referenced as out parameters, since we already generated | |
4204 | -- appropriate warnings at the call point in this case). | |
4205 | ||
4206 | elsif not Referenced_As_Out_Parameter (E) then | |
8063f750 | 4207 | |
8063f750 | 4208 | -- We suppress the message for types for which a valid |
4209 | -- pragma Unreferenced_Objects has been given, otherwise | |
4210 | -- we go ahead and give the message. | |
4211 | ||
4212 | if not Has_Pragma_Unreferenced_Objects (Etype (E)) then | |
4213 | ||
4214 | -- Distinguish renamed case in message | |
4215 | ||
4216 | if Present (Renamed_Object (E)) | |
4217 | and then Comes_From_Source (Renamed_Object (E)) | |
4218 | then | |
e977c0cf | 4219 | Error_Msg_N -- CODEFIX |
8063f750 | 4220 | ("?renamed variable & is not referenced!", E); |
4221 | else | |
e977c0cf | 4222 | Error_Msg_N -- CODEFIX |
8063f750 | 4223 | ("?variable & is not referenced!", E); |
4224 | end if; | |
4225 | end if; | |
4226 | end if; | |
4227 | ||
4228 | when E_Constant => | |
4229 | if Present (Renamed_Object (E)) | |
4230 | and then Comes_From_Source (Renamed_Object (E)) | |
4231 | then | |
e977c0cf | 4232 | Error_Msg_N -- CODEFIX |
8063f750 | 4233 | ("?renamed constant & is not referenced!", E); |
4234 | else | |
e977c0cf | 4235 | Error_Msg_N -- CODEFIX |
4236 | ("?constant & is not referenced!", E); | |
8063f750 | 4237 | end if; |
4238 | ||
4239 | when E_In_Parameter | | |
4240 | E_In_Out_Parameter => | |
4241 | ||
4242 | -- Do not emit message for formals of a renaming, because | |
4243 | -- they are never referenced explicitly. | |
4244 | ||
4245 | if Nkind (Original_Node (Unit_Declaration_Node (Scope (E)))) | |
4246 | /= N_Subprogram_Renaming_Declaration | |
4247 | then | |
4248 | -- Suppress this message for an IN OUT parameter of a | |
4249 | -- non-scalar type, since it is normal to have only an | |
4250 | -- assignment in such a case. | |
4251 | ||
4252 | if Ekind (E) = E_In_Parameter | |
4253 | or else not Referenced_As_LHS_Check_Spec (E) | |
7ba19623 | 4254 | or else Is_Scalar_Type (Etype (E)) |
8063f750 | 4255 | then |
4256 | if Present (Body_E) then | |
4257 | E := Body_E; | |
4258 | end if; | |
059bd36a | 4259 | |
4260 | if not Is_Trivial_Subprogram (Scope (E)) then | |
e977c0cf | 4261 | Error_Msg_NE -- CODEFIX |
059bd36a | 4262 | ("?formal parameter & is not referenced!", |
4263 | E, Spec_E); | |
4264 | end if; | |
8063f750 | 4265 | end if; |
4266 | end if; | |
4267 | ||
62bfeeb0 | 4268 | when E_Out_Parameter => |
8063f750 | 4269 | null; |
4270 | ||
62bfeeb0 | 4271 | when E_Discriminant => |
503f7fd3 | 4272 | Error_Msg_N ("?discriminant & is not referenced!", E); |
62bfeeb0 | 4273 | |
4274 | when E_Named_Integer | | |
4275 | E_Named_Real => | |
e977c0cf | 4276 | Error_Msg_N -- CODEFIX |
4277 | ("?named number & is not referenced!", E); | |
8063f750 | 4278 | |
62bfeeb0 | 4279 | when Formal_Object_Kind => |
e977c0cf | 4280 | Error_Msg_N -- CODEFIX |
4281 | ("?formal object & is not referenced!", E); | |
62bfeeb0 | 4282 | |
8063f750 | 4283 | when E_Enumeration_Literal => |
e977c0cf | 4284 | Error_Msg_N -- CODEFIX |
4285 | ("?literal & is not referenced!", E); | |
8063f750 | 4286 | |
62bfeeb0 | 4287 | when E_Function => |
e977c0cf | 4288 | Error_Msg_N -- CODEFIX |
4289 | ("?function & is not referenced!", E); | |
8063f750 | 4290 | |
62bfeeb0 | 4291 | when E_Procedure => |
e977c0cf | 4292 | Error_Msg_N -- CODEFIX |
4293 | ("?procedure & is not referenced!", E); | |
8063f750 | 4294 | |
62bfeeb0 | 4295 | when E_Package => |
e977c0cf | 4296 | Error_Msg_N -- CODEFIX |
4297 | ("?package & is not referenced!", E); | |
62bfeeb0 | 4298 | |
4299 | when E_Exception => | |
e977c0cf | 4300 | Error_Msg_N -- CODEFIX |
4301 | ("?exception & is not referenced!", E); | |
62bfeeb0 | 4302 | |
4303 | when E_Label => | |
e977c0cf | 4304 | Error_Msg_N -- CODEFIX |
4305 | ("?label & is not referenced!", E); | |
62bfeeb0 | 4306 | |
8063f750 | 4307 | when E_Generic_Procedure => |
3ba6a78b | 4308 | Error_Msg_N -- CODEFIX |
8063f750 | 4309 | ("?generic procedure & is never instantiated!", E); |
4310 | ||
62bfeeb0 | 4311 | when E_Generic_Function => |
3ba6a78b | 4312 | Error_Msg_N -- CODEFIX |
8063f750 | 4313 | ("?generic function & is never instantiated!", E); |
4314 | ||
62bfeeb0 | 4315 | when Type_Kind => |
e977c0cf | 4316 | Error_Msg_N -- CODEFIX |
4317 | ("?type & is not referenced!", E); | |
8063f750 | 4318 | |
4319 | when others => | |
e977c0cf | 4320 | Error_Msg_N -- CODEFIX |
4321 | ("?& is not referenced!", E); | |
8063f750 | 4322 | end case; |
4323 | ||
4324 | -- Kill warnings on the entity on which the message has been posted | |
4325 | ||
4326 | Set_Warnings_Off (E); | |
4327 | end if; | |
4328 | end Warn_On_Unreferenced_Entity; | |
4329 | ||
c0d40c9a | 4330 | -------------------------------- |
4331 | -- Warn_On_Useless_Assignment -- | |
4332 | -------------------------------- | |
4333 | ||
4334 | procedure Warn_On_Useless_Assignment | |
4335 | (Ent : Entity_Id; | |
ed683f94 | 4336 | N : Node_Id := Empty) |
c0d40c9a | 4337 | is |
ed683f94 | 4338 | P : Node_Id; |
4339 | X : Node_Id; | |
c0d40c9a | 4340 | |
4341 | function Check_Ref (N : Node_Id) return Traverse_Result; | |
a6252fe0 | 4342 | -- Used to instantiate Traverse_Func. Returns Abandon if a reference to |
4343 | -- the entity in question is found. | |
c0d40c9a | 4344 | |
4345 | function Test_No_Refs is new Traverse_Func (Check_Ref); | |
4346 | ||
4347 | --------------- | |
4348 | -- Check_Ref -- | |
4349 | --------------- | |
4350 | ||
4351 | function Check_Ref (N : Node_Id) return Traverse_Result is | |
4352 | begin | |
4353 | -- Check reference to our identifier. We use name equality here | |
4354 | -- because the exception handlers have not yet been analyzed. This | |
4355 | -- is not quite right, but it really does not matter that we fail | |
4356 | -- to output the warning in some obscure cases of name clashes. | |
4357 | ||
4358 | if Nkind (N) = N_Identifier | |
4359 | and then Chars (N) = Chars (Ent) | |
4360 | then | |
4361 | return Abandon; | |
4362 | else | |
4363 | return OK; | |
4364 | end if; | |
4365 | end Check_Ref; | |
4366 | ||
4367 | -- Start of processing for Warn_On_Useless_Assignment | |
4368 | ||
4369 | begin | |
ed683f94 | 4370 | -- Check if this is a case we want to warn on, a scalar or access |
4371 | -- variable with the last assignment field set, with warnings enabled, | |
4372 | -- and which is not imported or exported. We also check that it is OK | |
4373 | -- to capture the value. We are not going to capture any value, but | |
a6252fe0 | 4374 | -- the warning message depends on the same kind of conditions. |
c0d40c9a | 4375 | |
96da3284 | 4376 | if Is_Assignable (Ent) |
ef7e1793 | 4377 | and then not Is_Return_Object (Ent) |
c0d40c9a | 4378 | and then Present (Last_Assignment (Ent)) |
c0d40c9a | 4379 | and then not Is_Imported (Ent) |
4380 | and then not Is_Exported (Ent) | |
ed683f94 | 4381 | and then Safe_To_Capture_Value (N, Ent) |
059bd36a | 4382 | and then not Has_Pragma_Unreferenced_Check_Spec (Ent) |
c0d40c9a | 4383 | then |
4384 | -- Before we issue the message, check covering exception handlers. | |
059bd36a | 4385 | -- Search up tree for enclosing statement sequences and handlers. |
c0d40c9a | 4386 | |
4387 | P := Parent (Last_Assignment (Ent)); | |
4388 | while Present (P) loop | |
4389 | ||
059bd36a | 4390 | -- Something is really wrong if we don't find a handled statement |
4391 | -- sequence, so just suppress the warning. | |
c0d40c9a | 4392 | |
4393 | if No (P) then | |
4394 | Set_Last_Assignment (Ent, Empty); | |
4395 | return; | |
4396 | ||
4397 | -- When we hit a package/subprogram body, issue warning and exit | |
4398 | ||
4399 | elsif Nkind (P) = N_Subprogram_Body | |
4400 | or else Nkind (P) = N_Package_Body | |
4401 | then | |
96da3284 | 4402 | -- Case of assigned value never referenced |
4403 | ||
ed683f94 | 4404 | if No (N) then |
96da3284 | 4405 | |
4406 | -- Don't give this for OUT and IN OUT formals, since | |
4540a696 | 4407 | -- clearly caller may reference the assigned value. Also |
4408 | -- never give such warnings for internal variables. | |
96da3284 | 4409 | |
4540a696 | 4410 | if Ekind (Ent) = E_Variable |
4411 | and then not Is_Internal_Name (Chars (Ent)) | |
4412 | then | |
ed683f94 | 4413 | if Referenced_As_Out_Parameter (Ent) then |
4414 | Error_Msg_NE | |
4415 | ("?& modified by call, but value never referenced", | |
4416 | Last_Assignment (Ent), Ent); | |
4417 | else | |
e977c0cf | 4418 | Error_Msg_NE -- CODEFIX |
ed683f94 | 4419 | ("?useless assignment to&, value never referenced!", |
4420 | Last_Assignment (Ent), Ent); | |
4421 | end if; | |
96da3284 | 4422 | end if; |
4423 | ||
4424 | -- Case of assigned value overwritten | |
4425 | ||
c0d40c9a | 4426 | else |
ed683f94 | 4427 | Error_Msg_Sloc := Sloc (N); |
4428 | ||
4429 | if Referenced_As_Out_Parameter (Ent) then | |
4430 | Error_Msg_NE | |
4431 | ("?& modified by call, but value overwritten #!", | |
4432 | Last_Assignment (Ent), Ent); | |
4433 | else | |
e977c0cf | 4434 | Error_Msg_NE -- CODEFIX |
ed683f94 | 4435 | ("?useless assignment to&, value overwritten #!", |
4436 | Last_Assignment (Ent), Ent); | |
4437 | end if; | |
c0d40c9a | 4438 | end if; |
4439 | ||
96da3284 | 4440 | -- Clear last assignment indication and we are done |
4441 | ||
c0d40c9a | 4442 | Set_Last_Assignment (Ent, Empty); |
4443 | return; | |
4444 | ||
4445 | -- Enclosing handled sequence of statements | |
4446 | ||
4447 | elsif Nkind (P) = N_Handled_Sequence_Of_Statements then | |
4448 | ||
4449 | -- Check exception handlers present | |
4450 | ||
4451 | if Present (Exception_Handlers (P)) then | |
4452 | ||
4453 | -- If we are not at the top level, we regard an inner | |
4454 | -- exception handler as a decisive indicator that we should | |
4455 | -- not generate the warning, since the variable in question | |
1a34e48c | 4456 | -- may be accessed after an exception in the outer block. |
c0d40c9a | 4457 | |
4458 | if Nkind (Parent (P)) /= N_Subprogram_Body | |
4459 | and then Nkind (Parent (P)) /= N_Package_Body | |
4460 | then | |
4461 | Set_Last_Assignment (Ent, Empty); | |
4462 | return; | |
4463 | ||
4464 | -- Otherwise we are at the outer level. An exception | |
4465 | -- handler is significant only if it references the | |
a6252fe0 | 4466 | -- variable in question, or if the entity in question |
4467 | -- is an OUT or IN OUT parameter, which which case | |
4468 | -- the caller can reference it after the exception | |
4469 | -- hanlder completes | |
c0d40c9a | 4470 | |
4471 | else | |
a6252fe0 | 4472 | if Is_Formal (Ent) then |
4473 | Set_Last_Assignment (Ent, Empty); | |
4474 | return; | |
c0d40c9a | 4475 | |
a6252fe0 | 4476 | else |
4477 | X := First (Exception_Handlers (P)); | |
4478 | while Present (X) loop | |
4479 | if Test_No_Refs (X) = Abandon then | |
4480 | Set_Last_Assignment (Ent, Empty); | |
4481 | return; | |
4482 | end if; | |
4483 | ||
4484 | X := Next (X); | |
4485 | end loop; | |
4486 | end if; | |
c0d40c9a | 4487 | end if; |
4488 | end if; | |
4489 | end if; | |
4490 | ||
4491 | P := Parent (P); | |
4492 | end loop; | |
4493 | end if; | |
4494 | end Warn_On_Useless_Assignment; | |
4495 | ||
4496 | --------------------------------- | |
4497 | -- Warn_On_Useless_Assignments -- | |
4498 | --------------------------------- | |
4499 | ||
4500 | procedure Warn_On_Useless_Assignments (E : Entity_Id) is | |
4501 | Ent : Entity_Id; | |
4502 | begin | |
4503 | if Warn_On_Modified_Unread | |
4504 | and then In_Extended_Main_Source_Unit (E) | |
4505 | then | |
4506 | Ent := First_Entity (E); | |
4507 | while Present (Ent) loop | |
4508 | Warn_On_Useless_Assignment (Ent); | |
4509 | Next_Entity (Ent); | |
4510 | end loop; | |
4511 | end if; | |
4512 | end Warn_On_Useless_Assignments; | |
4513 | ||
059bd36a | 4514 | ----------------------------- |
4515 | -- Warnings_Off_Check_Spec -- | |
4516 | ----------------------------- | |
4517 | ||
4518 | function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean is | |
4519 | begin | |
4520 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
4521 | ||
4522 | -- Note: use of OR here instead of OR ELSE is deliberate, we want | |
4523 | -- to mess with flags on both entities. | |
4524 | ||
4525 | return Has_Warnings_Off (E) | |
4526 | or | |
4527 | Has_Warnings_Off (Spec_Entity (E)); | |
4528 | ||
4529 | else | |
4530 | return Has_Warnings_Off (E); | |
4531 | end if; | |
4532 | end Warnings_Off_Check_Spec; | |
4533 | ||
d6f39728 | 4534 | end Sem_Warn; |