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