]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ W A R N -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
634a926b | 9 | -- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- |
996ae0b0 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
996ae0b0 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
996ae0b0 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
996ae0b0 | 26 | with Atree; use Atree; |
fbe627af | 27 | with Debug; use Debug; |
996ae0b0 RK |
28 | with Einfo; use Einfo; |
29 | with Errout; use Errout; | |
3f1ede06 | 30 | with Exp_Code; use Exp_Code; |
996ae0b0 | 31 | with Lib; use Lib; |
a54ffd6c | 32 | with Lib.Xref; use Lib.Xref; |
3f1ede06 | 33 | with Namet; use Namet; |
996ae0b0 RK |
34 | with Nlists; use Nlists; |
35 | with Opt; use Opt; | |
6f12117a | 36 | with Par_SCO; use Par_SCO; |
434632ce | 37 | with Rtsfind; use Rtsfind; |
996ae0b0 | 38 | with Sem; use Sem; |
fbf5a39b | 39 | with Sem_Ch8; use Sem_Ch8; |
21d27997 | 40 | with Sem_Aux; use Sem_Aux; |
3f1ede06 | 41 | with Sem_Eval; use Sem_Eval; |
c9d70ab1 | 42 | with Sem_Prag; use Sem_Prag; |
996ae0b0 RK |
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; | |
3f1ede06 | 48 | with Stringt; use Stringt; |
6877306f | 49 | with Tbuild; use Tbuild; |
3f1ede06 | 50 | with Uintp; use Uintp; |
996ae0b0 RK |
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. | |
434632ce | 56 | -- ??? Check_Unset_Reference has zero information about this table. |
996ae0b0 RK |
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 | ||
9d77af56 RD |
66 | -- The following table collects potential warnings for IN OUT parameters |
67 | -- that are referenced but not modified. These warnings are processed when | |
f3d57416 | 68 | -- the front end calls the procedure Output_Non_Modified_In_Out_Warnings. |
9d77af56 RD |
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 | |
f3d57416 | 71 | -- in an instantiation, since we suppress the warnings in this case. The |
9a18e785 RD |
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. | |
9d77af56 | 75 | |
434632ce AC |
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 | ||
9a18e785 RD |
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 | ||
f3d57416 | 104 | -- if some-other-predicate-on-E |
9a18e785 RD |
105 | -- and then Has_Warnings_Off (E) |
106 | ||
107 | -- This way if some-other-predicate is false, we avoid a false indication | |
0ea55619 | 108 | -- that a Warnings (Off, E) pragma was useful in preventing a warning. |
9a18e785 RD |
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 | ||
fbf5a39b AC |
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 | |
434632ce AC |
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 | ||
9d77af56 RD |
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 | ||
434632ce AC |
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 | ||
634a926b AC |
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 | ||
434632ce AC |
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). | |
fbf5a39b | 155 | |
07fc65c4 | 156 | function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean; |
04568369 ES |
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. | |
996ae0b0 | 161 | |
434632ce AC |
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 | ||
561b5849 RD |
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 | ||
434632ce AC |
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 | ||
9a18e785 RD |
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 | ||
3f1ede06 RD |
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 | |
ed2233dc | 210 | Error_Msg_F |
324ac540 | 211 | ("??code statement with no inputs should usually be Volatile!", N); |
3f1ede06 RD |
212 | return; |
213 | end if; | |
214 | ||
215 | Setup_Asm_Outputs (N); | |
216 | ||
217 | if No (Asm_Output_Variable) then | |
ed2233dc | 218 | Error_Msg_F |
324ac540 | 219 | ("??code statement with no outputs should usually be Volatile!", N); |
3f1ede06 RD |
220 | return; |
221 | end if; | |
3f1ede06 RD |
222 | end Check_Code_Statement; |
223 | ||
fbe627af RD |
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 | |
51bf9bdf AC |
233 | Expression : Node_Id := Empty; |
234 | -- Set to WHILE or EXIT WHEN condition to be tested | |
fbe627af | 235 | |
434632ce | 236 | Ref : Node_Id := Empty; |
51bf9bdf | 237 | -- Reference in Expression to variable that might not be modified |
8a912a6e | 238 | -- in loop, indicating a possible infinite loop. |
fbe627af RD |
239 | |
240 | Var : Entity_Id := Empty; | |
241 | -- Corresponding entity (entity of Ref) | |
242 | ||
8a912a6e AC |
243 | Function_Call_Found : Boolean := False; |
244 | -- True if Find_Var found a function call in the condition | |
245 | ||
fbe627af | 246 | procedure Find_Var (N : Node_Id); |
434632ce AC |
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. | |
fbe627af | 250 | |
90e491a7 PMR |
251 | function Has_Condition_Actions (Iter : Node_Id) return Boolean; |
252 | -- Determine whether iteration scheme Iter has meaningful condition | |
253 | -- actions. | |
254 | ||
fbe627af RD |
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 | |
e80f0cb0 RD |
266 | -- likely have some strange side effect dependencies. A rather strange |
267 | -- test, but warning messages are in the heuristics business. | |
fbe627af RD |
268 | |
269 | function Test_Ref (N : Node_Id) return Traverse_Result; | |
270 | -- Test for reference to variable in question. Returns Abandon if | |
51bf9bdf | 271 | -- matching reference found. Used in instantiation of No_Ref_Found. |
fbe627af | 272 | |
51bf9bdf | 273 | function No_Ref_Found is new Traverse_Func (Test_Ref); |
fbe627af RD |
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 | ||
561b5849 | 289 | -- Case of condition is a comparison with compile time known value |
fbe627af RD |
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 | ||
561b5849 | 304 | -- If condition is a negation, check its operand |
fbe627af RD |
305 | |
306 | elsif Nkind (N) = N_Op_Not then | |
307 | Find_Var (Right_Opnd (N)); | |
308 | ||
561b5849 | 309 | -- Case of condition is function call |
fbe627af RD |
310 | |
311 | elsif Nkind (N) = N_Function_Call then | |
312 | ||
8a912a6e AC |
313 | Function_Call_Found := True; |
314 | ||
fbe627af RD |
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 | ||
9a18e785 | 321 | -- Forget it if function name is suspicious. A strange test |
a90bd866 | 322 | -- but warning generation is in the heuristics business. |
fbe627af | 323 | |
9a18e785 | 324 | elsif Is_Suspicious_Function_Name (Entity (Name (N))) then |
fbe627af RD |
325 | return; |
326 | ||
d030f3a4 AC |
327 | -- Forget it if function is marked Volatile_Function |
328 | ||
329 | elsif Is_Volatile_Function (Entity (Name (N))) then | |
330 | return; | |
331 | ||
9a18e785 | 332 | -- Forget it if warnings are suppressed on function entity |
fbe627af | 333 | |
9a18e785 | 334 | elsif Has_Warnings_Off (Entity (Name (N))) then |
fbe627af RD |
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 | ||
c230ed0b | 346 | if Present (PA) and then List_Length (PA) = 1 then |
fbe627af RD |
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 | ||
561b5849 | 353 | -- Not one argument |
fbe627af RD |
354 | |
355 | else | |
356 | return; | |
357 | end if; | |
358 | end; | |
359 | ||
561b5849 | 360 | -- Any other kind of node is not something we warn for |
fbe627af RD |
361 | |
362 | else | |
363 | return; | |
364 | end if; | |
365 | end Find_Var; | |
366 | ||
90e491a7 PMR |
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 | ||
fbe627af RD |
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)) | |
d9d25d04 | 423 | or else Is_Descendant_Of_Address (Etype (Comp)) |
fbe627af RD |
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 | |
c230ed0b | 455 | and then (J = 1 or else Name_Buffer (J - 1) not in 'a' .. 'z') |
fbe627af RD |
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 | ||
561b5849 | 467 | -- Start of processing for Is_Suspicious_Function_Name |
fbe627af RD |
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 | |
51bf9bdf | 493 | -- Waste of time to look at the expression we are testing |
fbe627af | 494 | |
51bf9bdf | 495 | if N = Expression then |
fbe627af RD |
496 | return Skip; |
497 | ||
561b5849 | 498 | -- Direct reference to variable in question |
fbe627af RD |
499 | |
500 | elsif Is_Entity_Name (N) | |
501 | and then Present (Entity (N)) | |
502 | and then Entity (N) = Var | |
503 | then | |
b0159fbe | 504 | -- If this is an lvalue, then definitely abandon, since |
fbe627af RD |
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 | ||
8e983d80 | 511 | -- If the condition contains a function call, we consider it may |
92b751fd | 512 | -- be modified by side effects from a procedure call. Otherwise, |
8e983d80 AC |
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 | |
a90bd866 | 534 | -- business of complaining about the tree structure here. |
8e983d80 AC |
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; | |
fbe627af | 544 | |
8e983d80 | 545 | -- Reference to variable renaming variable in question |
fbe627af RD |
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 | ||
8e983d80 | 557 | -- Call to subprogram |
fbe627af | 558 | |
d3b00ce3 AC |
559 | elsif Nkind (N) in N_Subprogram_Call then |
560 | ||
434632ce AC |
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. | |
fbe627af RD |
566 | |
567 | if not Is_Entity_Name (Name (N)) | |
434632ce | 568 | or else No (Entity (Name (N))) |
fbe627af RD |
569 | or else Scope_Within (Entity (Name (N)), Scope (Var)) |
570 | then | |
571 | return Abandon; | |
572 | end if; | |
3f165ff2 | 573 | |
547c5954 AC |
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 | ||
3f165ff2 AC |
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; | |
fbe627af RD |
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 | |
51bf9bdf | 606 | -- Skip processing if debug flag gnatd.w is set |
fbe627af | 607 | |
51bf9bdf AC |
608 | if Debug_Flag_Dot_W then |
609 | return; | |
610 | end if; | |
611 | ||
3f165ff2 | 612 | -- Deal with Iteration scheme present |
51bf9bdf AC |
613 | |
614 | declare | |
615 | Iter : constant Node_Id := Iteration_Scheme (Loop_Statement); | |
616 | ||
617 | begin | |
3f165ff2 | 618 | if Present (Iter) then |
51bf9bdf | 619 | |
3f165ff2 | 620 | -- While iteration |
51bf9bdf | 621 | |
3f165ff2 AC |
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. | |
51bf9bdf | 626 | |
90e491a7 | 627 | if Has_Condition_Actions (Iter) then |
3f165ff2 AC |
628 | return; |
629 | end if; | |
51bf9bdf | 630 | |
3f165ff2 AC |
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; | |
51bf9bdf AC |
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 | |
ee2ba856 | 658 | Check_Error_Detected; |
51bf9bdf AC |
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; | |
7a1f094d AC |
682 | |
683 | -- If an unconditional exit statement is the last statement in the | |
9686dbc7 | 684 | -- loop, assume that no warning is needed, without any attempt at |
7a1f094d AC |
685 | -- checking whether the exit is reachable. |
686 | ||
687 | elsif Exit_Stmt = Last (Statements (Loop_Statement)) then | |
688 | return; | |
51bf9bdf AC |
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 | |
fbe627af RD |
698 | return; |
699 | end if; | |
700 | ||
701 | -- Initial conditions met, see if condition is of right form | |
702 | ||
51bf9bdf | 703 | Find_Var (Expression); |
fbe627af | 704 | |
4a13695c AC |
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. | |
fbe627af RD |
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) | |
4a13695c | 713 | or else Nkind (Parent (Var)) = N_Object_Renaming_Declaration |
fbe627af RD |
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). | |
8a912a6e AC |
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. | |
fbe627af | 722 | |
8a912a6e | 723 | elsif Function_Call_Found and then Has_Indirection (Etype (Var)) then |
fbe627af RD |
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 | ||
51bf9bdf | 751 | if No_Ref_Found (Loop_Statement) = OK then |
fbe627af | 752 | Error_Msg_NE |
324ac540 | 753 | ("??variable& is not modified in loop body!", Ref, Var); |
fbe627af | 754 | Error_Msg_N |
324ac540 | 755 | ("\??possible infinite loop!", Ref); |
fbe627af RD |
756 | end if; |
757 | end Check_Infinite_Loop_Warning; | |
758 | ||
fad0600d AC |
759 | ---------------------------- |
760 | -- Check_Low_Bound_Tested -- | |
761 | ---------------------------- | |
762 | ||
763 | procedure Check_Low_Bound_Tested (Expr : Node_Id) is | |
b6a56408 AC |
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 | ||
fad0600d AC |
787 | begin |
788 | if Comes_From_Source (Expr) then | |
b6a56408 AC |
789 | Check_Low_Bound_Tested_For (Left_Opnd (Expr)); |
790 | Check_Low_Bound_Tested_For (Right_Opnd (Expr)); | |
fad0600d AC |
791 | end if; |
792 | end Check_Low_Bound_Tested; | |
793 | ||
996ae0b0 RK |
794 | ---------------------- |
795 | -- Check_References -- | |
796 | ---------------------- | |
797 | ||
798 | procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is | |
9d77af56 RD |
799 | E1 : Entity_Id; |
800 | E1T : Entity_Id; | |
801 | UR : Node_Id; | |
fbf5a39b | 802 | |
434632ce AC |
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 | |
f3d57416 | 807 | -- corresponding body formal from the given accept statement. |
434632ce | 808 | |
2c8d828a | 809 | procedure May_Need_Initialized_Actual (Ent : Entity_Id); |
c8a3028c AC |
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 | |
2c8d828a AC |
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. | |
c8a3028c | 817 | |
fbf5a39b AC |
818 | function Missing_Subunits return Boolean; |
819 | -- We suppress warnings when there are missing subunits, because this | |
04568369 ES |
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. | |
996ae0b0 RK |
823 | |
824 | procedure Output_Reference_Error (M : String); | |
04568369 ES |
825 | -- Used to output an error message. Deals with posting the error on the |
826 | -- body formal in the accept case. | |
996ae0b0 RK |
827 | |
828 | function Publicly_Referenceable (Ent : Entity_Id) return Boolean; | |
829 | -- This is true if the entity in question is potentially referenceable | |
04568369 ES |
830 | -- from another unit. This is true for entities in packages that are at |
831 | -- the library level. | |
996ae0b0 | 832 | |
9a18e785 RD |
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 | ||
bf0b0e5e AC |
867 | --------------------------------- |
868 | -- May_Need_Initialized_Actual -- | |
869 | --------------------------------- | |
c8a3028c | 870 | |
2c8d828a | 871 | procedure May_Need_Initialized_Actual (Ent : Entity_Id) is |
c8a3028c AC |
872 | T : constant Entity_Id := Etype (Ent); |
873 | Par : constant Node_Id := Parent (T); | |
c8a3028c AC |
874 | |
875 | begin | |
876 | if not Is_Generic_Type (T) then | |
2c8d828a | 877 | null; |
c8a3028c AC |
878 | |
879 | elsif (Nkind (Par)) = N_Private_Extension_Declaration then | |
2c8d828a AC |
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; | |
c8a3028c AC |
886 | |
887 | elsif (Nkind (Par)) = N_Formal_Type_Declaration | |
c230ed0b AC |
888 | and then Nkind (Formal_Type_Definition (Par)) = |
889 | N_Formal_Private_Type_Definition | |
c8a3028c | 890 | then |
2c8d828a AC |
891 | if No (Uninitialized_Variable (Formal_Type_Definition (Par))) then |
892 | Set_Uninitialized_Variable (Formal_Type_Definition (Par), Ent); | |
893 | end if; | |
c8a3028c | 894 | end if; |
c8a3028c AC |
895 | end May_Need_Initialized_Actual; |
896 | ||
15ce9ca2 AC |
897 | ---------------------- |
898 | -- Missing_Subunits -- | |
899 | ---------------------- | |
fbf5a39b AC |
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))); | |
fbf5a39b AC |
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 | |
04568369 | 933 | -- Missing stubs elsewhere |
fbf5a39b AC |
934 | |
935 | return True; | |
936 | end if; | |
937 | end Missing_Subunits; | |
938 | ||
996ae0b0 RK |
939 | ---------------------------- |
940 | -- Output_Reference_Error -- | |
941 | ---------------------------- | |
942 | ||
943 | procedure Output_Reference_Error (M : String) is | |
944 | begin | |
91669e7e | 945 | -- Never issue messages for internal names or renamings |
9d77af56 | 946 | |
4fb0b3f0 AC |
947 | if Is_Internal_Name (Chars (E1)) |
948 | or else Nkind (Parent (E1)) = N_Object_Renaming_Declaration | |
949 | then | |
9d77af56 RD |
950 | return; |
951 | end if; | |
952 | ||
434632ce AC |
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 | ||
996ae0b0 RK |
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 | |
434632ce | 972 | Error_Msg_NE (M, Body_Formal (E1, Accept_Statement => Anod), E1); |
996ae0b0 | 973 | |
996ae0b0 RK |
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 | |
fbf5a39b AC |
982 | P : Node_Id; |
983 | Prev : Node_Id; | |
996ae0b0 RK |
984 | |
985 | begin | |
434632ce AC |
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 | ||
04568369 ES |
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. | |
996ae0b0 | 996 | |
fbf5a39b AC |
997 | Prev := Ent; |
998 | P := Parent (Ent); | |
07fc65c4 GB |
999 | loop |
1000 | case Nkind (P) is | |
996ae0b0 | 1001 | |
fbf5a39b | 1002 | -- If we get to top of tree, then publicly referenceable |
996ae0b0 | 1003 | |
07fc65c4 GB |
1004 | when N_Empty => |
1005 | return True; | |
996ae0b0 | 1006 | |
07fc65c4 GB |
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 | |
04568369 ES |
1011 | -- we will get a warning for the package entity. |
1012 | ||
fbf5a39b | 1013 | -- Note that generic formal parameters are themselves not |
434632ce AC |
1014 | -- publicly referenceable in an instance, and warnings on them |
1015 | -- are useful. | |
996ae0b0 | 1016 | |
07fc65c4 | 1017 | when N_Generic_Package_Declaration => |
fbf5a39b AC |
1018 | return |
1019 | not Is_List_Member (Prev) | |
c230ed0b AC |
1020 | or else List_Containing (Prev) /= |
1021 | Generic_Formal_Declarations (P); | |
fbf5a39b | 1022 | |
434632ce AC |
1023 | -- Similarly, the generic formals of a generic subprogram are |
1024 | -- not accessible. | |
b47efa93 | 1025 | |
d8f43ee6 | 1026 | when N_Generic_Subprogram_Declaration => |
b47efa93 ES |
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 | |
fbf5a39b AC |
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; | |
07fc65c4 | 1047 | |
fbf5a39b | 1048 | -- If we reach any other body, definitely not referenceable |
07fc65c4 | 1049 | |
d8f43ee6 HK |
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 | => | |
07fc65c4 GB |
1057 | return False; |
1058 | ||
1059 | -- For all other cases, keep looking up tree | |
1060 | ||
1061 | when others => | |
fbf5a39b AC |
1062 | Prev := P; |
1063 | P := Parent (P); | |
07fc65c4 | 1064 | end case; |
996ae0b0 RK |
1065 | end loop; |
1066 | end Publicly_Referenceable; | |
1067 | ||
9a18e785 RD |
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 | ||
996ae0b0 RK |
1079 | -- Start of processing for Check_References |
1080 | ||
1081 | begin | |
a54ffd6c AC |
1082 | Process_Deferred_References; |
1083 | ||
04568369 ES |
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). | |
996ae0b0 | 1087 | |
c230ed0b | 1088 | if Warning_Mode = Suppress or else Serious_Errors_Detected /= 0 then |
fbf5a39b AC |
1089 | return; |
1090 | end if; | |
1091 | ||
996ae0b0 RK |
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 | ||
fbf5a39b | 1096 | if Missing_Subunits then |
996ae0b0 RK |
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 | |
9d77af56 | 1104 | E1T := Etype (E1); |
996ae0b0 | 1105 | |
9a18e785 RD |
1106 | -- We are only interested in source entities. We also don't issue |
1107 | -- warnings within instances, since the proper place for such | |
4bd4bb7f AC |
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. | |
996ae0b0 | 1110 | |
fbe627af | 1111 | if Comes_From_Source (E1) |
9d77af56 | 1112 | and then Instantiation_Location (Sloc (E1)) = No_Location |
fbe627af | 1113 | then |
434632ce AC |
1114 | -- We are interested in variables and out/in-out parameters, but |
1115 | -- we exclude protected types, too complicated to worry about. | |
996ae0b0 RK |
1116 | |
1117 | if Ekind (E1) = E_Variable | |
8a95f4e8 RD |
1118 | or else |
1119 | (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter) | |
996ae0b0 RK |
1120 | and then not Is_Protected_Type (Current_Scope)) |
1121 | then | |
26f36fc9 AC |
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 | ||
434632ce AC |
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. | |
fbf5a39b | 1133 | |
30c20106 AC |
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 | ||
9d77af56 RD |
1142 | -- Special processing for access types |
1143 | ||
c230ed0b AC |
1144 | if Present (UR) and then Is_Access_Type (E1T) then |
1145 | ||
04568369 ES |
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 | |
0c020dde AC |
1151 | -- assignment of a pointer involving discriminant check on |
1152 | -- the designated object). | |
30c20106 | 1153 | |
9a18e785 | 1154 | if not Warnings_Off_E1 then |
324ac540 | 1155 | Error_Msg_NE ("??& may be null!", UR, E1); |
9a18e785 RD |
1156 | end if; |
1157 | ||
996ae0b0 | 1158 | goto Continue; |
fbf5a39b AC |
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 | ||
74014283 RD |
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 | ||
fbf5a39b | 1170 | elsif Warn_On_Constant |
9d77af56 | 1171 | and then (Ekind (E1) = E_Variable |
c230ed0b | 1172 | and then Has_Initial_Value (E1)) |
434632ce | 1173 | and then Never_Set_In_Source_Check_Spec (E1) |
fbf5a39b AC |
1174 | and then not Generic_Package_Spec_Entity (E1) |
1175 | then | |
b47efa93 ES |
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 | |
ec3c7387 AC |
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). | |
b47efa93 ES |
1182 | |
1183 | if (Is_Volatile (E1) or else Has_Volatile_Components (E1)) | |
1184 | and then not Is_Imported (E1) | |
1185 | then | |
ed2233dc | 1186 | Error_Msg_N |
bd717ec9 AC |
1187 | ("?k?& is not modified, consider pragma Export for " |
1188 | & "volatile variable!", E1); | |
434632ce AC |
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 | ||
9d77af56 | 1194 | elsif Is_RTE (E1T, RE_Exception_Occurrence) then |
434632ce AC |
1195 | null; |
1196 | ||
1197 | -- Here we give the warning if referenced and no pragma | |
9d77af56 | 1198 | -- Unreferenced or Unmodified is present. |
434632ce | 1199 | |
b47efa93 | 1200 | else |
9d77af56 RD |
1201 | -- Variable case |
1202 | ||
434632ce AC |
1203 | if Ekind (E1) = E_Variable then |
1204 | if Referenced_Check_Spec (E1) | |
1205 | and then not Has_Pragma_Unreferenced_Check_Spec (E1) | |
9d77af56 | 1206 | and then not Has_Pragma_Unmodified_Check_Spec (E1) |
434632ce | 1207 | then |
4bd4bb7f AC |
1208 | if not Warnings_Off_E1 |
1209 | and then not Has_Junk_Name (E1) | |
1210 | then | |
483c78cb | 1211 | Error_Msg_N -- CODEFIX |
685bc70f | 1212 | ("?k?& is not modified, " |
9a18e785 RD |
1213 | & "could be declared constant!", |
1214 | E1); | |
1215 | end if; | |
434632ce | 1216 | end if; |
434632ce AC |
1217 | end if; |
1218 | end if; | |
1219 | ||
9d77af56 | 1220 | -- Other cases of a variable or parameter never set in source |
434632ce AC |
1221 | |
1222 | elsif Never_Set_In_Source_Check_Spec (E1) | |
1223 | ||
c230ed0b | 1224 | -- No warning if warning for this case turned off |
434632ce | 1225 | |
c230ed0b | 1226 | and then Warn_On_No_Value_Assigned |
434632ce | 1227 | |
c230ed0b | 1228 | -- No warning if address taken somewhere |
434632ce | 1229 | |
c230ed0b | 1230 | and then not Address_Taken (E1) |
434632ce | 1231 | |
c230ed0b | 1232 | -- No warning if explicit initial value |
434632ce | 1233 | |
c230ed0b | 1234 | and then not Has_Initial_Value (E1) |
434632ce | 1235 | |
c230ed0b AC |
1236 | -- No warning for generic package spec entities, since we |
1237 | -- might set them in a child unit or something like that | |
434632ce | 1238 | |
c230ed0b | 1239 | and then not Generic_Package_Spec_Entity (E1) |
434632ce | 1240 | |
c230ed0b AC |
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). | |
434632ce | 1245 | |
c230ed0b AC |
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. | |
434632ce | 1249 | |
c230ed0b AC |
1250 | and then (Is_Access_Type (E1T) |
1251 | or else Ekind (E1) = E_Out_Parameter | |
1252 | or else not Is_Fully_Initialized_Type (E1T)) | |
434632ce AC |
1253 | then |
1254 | -- Do not output complaint about never being assigned a | |
9a18e785 | 1255 | -- value if a pragma Unmodified applies to the variable |
434632ce | 1256 | -- we are examining, or if it is a parameter, if there is |
f16d05d9 | 1257 | -- a pragma Unreferenced for the corresponding spec, or |
9a18e785 RD |
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. | |
434632ce | 1261 | |
9a18e785 RD |
1262 | if Has_Pragma_Unreferenced_Objects (E1T) |
1263 | or else Has_Pragma_Unmodified_Check_Spec (E1) | |
434632ce AC |
1264 | then |
1265 | null; | |
1266 | ||
9d77af56 RD |
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 | |
16b05213 | 1278 | -- the private type, and it may be quite reasonable |
f16d05d9 | 1279 | -- for the logical view to be IN OUT, even if the |
9d77af56 RD |
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 | |
9a18e785 | 1284 | -- there we have less excuse for a junk IN OUT parameter. |
9d77af56 RD |
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 | |
9a18e785 RD |
1295 | -- needs the formal to be IN OUT and for others happens |
1296 | -- not to assign it. | |
9d77af56 RD |
1297 | |
1298 | elsif Is_Dispatching_Operation | |
1299 | (Scope (Goto_Spec_Entity (E1))) | |
1300 | then | |
1301 | null; | |
1302 | ||
f16d05d9 AC |
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. | |
9d77af56 RD |
1307 | |
1308 | elsif Is_Composite_Type (E1T) | |
1309 | and then Has_Access_Values (E1T) | |
1310 | then | |
1311 | null; | |
1312 | ||
c2369146 AC |
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 | ||
9d77af56 RD |
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 | |
f3d57416 | 1329 | -- the formal is not modified. |
9d77af56 RD |
1330 | |
1331 | else | |
4bd4bb7f AC |
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; | |
9d77af56 RD |
1337 | end if; |
1338 | ||
1339 | -- Other cases of formals | |
434632ce AC |
1340 | |
1341 | elsif Is_Formal (E1) then | |
9a18e785 RD |
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 | |
4bd4bb7f | 1346 | and then not Has_Junk_Name (E1) |
9a18e785 RD |
1347 | then |
1348 | Output_Reference_Error | |
685bc70f | 1349 | ("?f?formal parameter& is read but " |
9a18e785 RD |
1350 | & "never assigned!"); |
1351 | end if; | |
1352 | ||
1353 | elsif not Has_Pragma_Unreferenced_Check_Spec (E1) | |
1354 | and then not Warnings_Off_E1 | |
4bd4bb7f | 1355 | and then not Has_Junk_Name (E1) |
9a18e785 | 1356 | then |
9d77af56 | 1357 | Output_Reference_Error |
685bc70f | 1358 | ("?f?formal parameter& is not referenced!"); |
9d77af56 | 1359 | end if; |
434632ce AC |
1360 | end if; |
1361 | ||
1362 | -- Case of variable | |
1363 | ||
1364 | else | |
1365 | if Referenced (E1) then | |
9a18e785 RD |
1366 | if not Has_Unmodified (E1) |
1367 | and then not Warnings_Off_E1 | |
4bd4bb7f | 1368 | and then not Has_Junk_Name (E1) |
9a18e785 RD |
1369 | then |
1370 | Output_Reference_Error | |
324ac540 | 1371 | ("?v?variable& is read but never assigned!"); |
2c8d828a | 1372 | May_Need_Initialized_Actual (E1); |
9a18e785 RD |
1373 | end if; |
1374 | ||
1375 | elsif not Has_Unreferenced (E1) | |
1376 | and then not Warnings_Off_E1 | |
4bd4bb7f | 1377 | and then not Has_Junk_Name (E1) |
9a18e785 | 1378 | then |
483c78cb | 1379 | Output_Reference_Error -- CODEFIX |
324ac540 | 1380 | ("?v?variable& is never read and never assigned!"); |
434632ce AC |
1381 | end if; |
1382 | ||
561b5849 RD |
1383 | -- Deal with special case where this variable is hidden |
1384 | -- by a loop variable. | |
434632ce AC |
1385 | |
1386 | if Ekind (E1) = E_Variable | |
1387 | and then Present (Hiding_Loop_Variable (E1)) | |
9a18e785 | 1388 | and then not Warnings_Off_E1 |
434632ce | 1389 | then |
ed2233dc | 1390 | Error_Msg_N |
324ac540 | 1391 | ("?v?for loop implicitly declares loop variable!", |
434632ce AC |
1392 | Hiding_Loop_Variable (E1)); |
1393 | ||
1394 | Error_Msg_Sloc := Sloc (E1); | |
1395 | Error_Msg_N | |
324ac540 | 1396 | ("\?v?declaration hides & declared#!", |
434632ce AC |
1397 | Hiding_Loop_Variable (E1)); |
1398 | end if; | |
b47efa93 | 1399 | end if; |
434632ce AC |
1400 | |
1401 | goto Continue; | |
996ae0b0 RK |
1402 | end if; |
1403 | ||
434632ce | 1404 | -- Check for unset reference |
996ae0b0 | 1405 | |
fbf5a39b | 1406 | if Warn_On_No_Value_Assigned and then Present (UR) then |
996ae0b0 | 1407 | |
434632ce AC |
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. | |
996ae0b0 | 1411 | |
7ec25b2b AC |
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. | |
30c20106 | 1416 | |
434632ce | 1417 | UR := Original_Node (UR); |
5efb89d0 AC |
1418 | loop |
1419 | if Nkind_In (UR, N_Expression_With_Actions, | |
643827e9 SB |
1420 | N_Qualified_Expression, |
1421 | N_Type_Conversion) | |
5efb89d0 AC |
1422 | then |
1423 | UR := Expression (UR); | |
1424 | ||
1425 | elsif Nkind (UR) = N_Attribute_Reference then | |
7ec25b2b | 1426 | UR := Prefix (UR); |
5efb89d0 | 1427 | |
7ec25b2b | 1428 | else |
5efb89d0 | 1429 | exit; |
7ec25b2b | 1430 | end if; |
30c20106 AC |
1431 | end loop; |
1432 | ||
87e9b935 RD |
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 | ||
434632ce AC |
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 | ||
9a18e785 RD |
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 | |
4bd4bb7f AC |
1453 | if not Warnings_Off_E1 |
1454 | and then not Has_Junk_Name (E1) | |
1455 | then | |
9a18e785 | 1456 | Error_Msg_NE |
324ac540 AC |
1457 | ("?v?OUT parameter& not set before return", |
1458 | UR, E1); | |
9a18e785 | 1459 | end if; |
434632ce | 1460 | |
9a18e785 RD |
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 | |
f3d57416 | 1466 | -- uninitialized component to get a better message. |
30c20106 | 1467 | |
9a18e785 RD |
1468 | elsif Nkind (Parent (UR)) = N_Selected_Component then |
1469 | Error_Msg_Node_2 := Selector_Name (Parent (UR)); | |
30c20106 | 1470 | |
9a18e785 RD |
1471 | if not Comes_From_Source (Parent (UR)) then |
1472 | declare | |
1473 | Comp : Entity_Id; | |
30c20106 | 1474 | |
9a18e785 RD |
1475 | begin |
1476 | Comp := First_Entity (E1T); | |
1477 | while Present (Comp) loop | |
1478 | if Ekind (Comp) = E_Component | |
1479 | and then Nkind (Parent (Comp)) = | |
8a95f4e8 | 1480 | N_Component_Declaration |
9a18e785 RD |
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; | |
30c20106 | 1491 | |
9a18e785 RD |
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 | |
b785e0b8 | 1500 | Error_Msg_N ("??`&.&` may be null!", UR); |
9a18e785 RD |
1501 | else |
1502 | Error_Msg_N | |
b785e0b8 | 1503 | ("??`&.&` may be referenced before " |
9a18e785 RD |
1504 | & "it has a value!", UR); |
1505 | end if; | |
1506 | end if; | |
1507 | end if; | |
b785e0b8 AC |
1508 | |
1509 | -- All other cases of unset reference active | |
434632ce | 1510 | |
9a18e785 | 1511 | elsif not Warnings_Off_E1 then |
434632ce | 1512 | Error_Msg_N |
b785e0b8 | 1513 | ("??& may be referenced before it has a value!", UR); |
434632ce | 1514 | end if; |
996ae0b0 | 1515 | end if; |
30c20106 AC |
1516 | |
1517 | goto Continue; | |
c8a3028c | 1518 | |
996ae0b0 RK |
1519 | end if; |
1520 | end if; | |
1521 | ||
fbf5a39b | 1522 | -- Then check for unreferenced entities. Note that we are only |
9a18e785 | 1523 | -- interested in entities whose Referenced flag is not set. |
996ae0b0 | 1524 | |
434632ce | 1525 | if not Referenced_Check_Spec (E1) |
996ae0b0 | 1526 | |
c230ed0b AC |
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. | |
9a18e785 RD |
1530 | |
1531 | and then (not Referenced_As_LHS_Check_Spec (E1) | |
c230ed0b | 1532 | or else not Has_Unreferenced (E1)) |
9a18e785 | 1533 | |
c230ed0b | 1534 | -- Check that warnings on unreferenced entities are enabled |
996ae0b0 | 1535 | |
561b5849 RD |
1536 | and then |
1537 | ((Check_Unreferenced and then not Is_Formal (E1)) | |
1538 | ||
c230ed0b AC |
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) | |
996ae0b0 | 1566 | |
c230ed0b AC |
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. | |
996ae0b0 | 1572 | |
c230ed0b AC |
1573 | or else |
1574 | (Ekind (E1) = E_Package | |
1575 | and then | |
1576 | not Is_Package_Or_Generic_Package | |
1577 | (Cunit_Entity (Current_Sem_Unit)))) | |
996ae0b0 | 1578 | |
c230ed0b AC |
1579 | -- Exclude instantiations, since there is no reason why every |
1580 | -- entity in an instantiation should be referenced. | |
996ae0b0 | 1581 | |
c230ed0b | 1582 | and then Instantiation_Location (Sloc (E1)) = No_Location |
996ae0b0 | 1583 | |
c230ed0b AC |
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. | |
996ae0b0 | 1587 | |
c230ed0b AC |
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))) | |
996ae0b0 | 1592 | |
c230ed0b AC |
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. | |
996ae0b0 | 1596 | |
c230ed0b AC |
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 | |
996ae0b0 | 1603 | |
c230ed0b | 1604 | and then not Has_Private_Declaration (E1) |
996ae0b0 | 1605 | |
c230ed0b AC |
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). | |
996ae0b0 | 1609 | |
c230ed0b | 1610 | and then not Is_Dispatching_Operation (E1) |
996ae0b0 | 1611 | |
c230ed0b AC |
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) | |
996ae0b0 | 1618 | |
c230ed0b AC |
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. | |
996ae0b0 | 1622 | |
c230ed0b | 1623 | and then Ekind (E1) /= E_Class_Wide_Type |
996ae0b0 | 1624 | |
c230ed0b AC |
1625 | -- Objects other than parameters of task types are allowed to |
1626 | -- be non-referenced, since they start up tasks. | |
996ae0b0 | 1627 | |
c230ed0b AC |
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)) | |
07fc65c4 | 1632 | |
c230ed0b AC |
1633 | -- For subunits, only place warnings on the main unit itself, |
1634 | -- since parent units are not completely compiled. | |
07fc65c4 | 1635 | |
c230ed0b AC |
1636 | and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit |
1637 | or else Get_Source_Unit (E1) = Main_Unit) | |
fbe627af | 1638 | |
c230ed0b AC |
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. | |
fbe627af | 1643 | |
c230ed0b AC |
1644 | and then not |
1645 | (Ekind (E1) = E_Constant and then Is_Return_Object (E1)) | |
996ae0b0 | 1646 | then |
04568369 ES |
1647 | -- Suppress warnings in internal units if not in -gnatg mode |
1648 | -- (these would be junk warnings for an applications program, | |
f16d05d9 | 1649 | -- since they refer to problems in internal units). |
996ae0b0 | 1650 | |
8ab31c0c | 1651 | if GNAT_Mode or else not In_Internal_Unit (E1) then |
04568369 ES |
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 | |
434632ce AC |
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. | |
996ae0b0 RK |
1660 | |
1661 | if Present (Anod) then | |
434632ce AC |
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 | ||
9a18e785 RD |
1667 | if not Warnings_Off_E1 then |
1668 | Warn_On_Unreferenced_Entity | |
1669 | (E1, Body_Formal (E1, Accept_Statement => Anod)); | |
1670 | end if; | |
996ae0b0 | 1671 | |
4bd4bb7f AC |
1672 | elsif not Warnings_Off_E1 |
1673 | and then not Has_Junk_Name (E1) | |
1674 | then | |
434632ce | 1675 | Unreferenced_Entities.Append (E1); |
996ae0b0 RK |
1676 | end if; |
1677 | end if; | |
fbf5a39b | 1678 | |
04568369 ES |
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. | |
fbf5a39b AC |
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 | |
4bd4bb7f | 1690 | if not Warnings_Off_E1 and then not Has_Junk_Name (E1) then |
9a18e785 | 1691 | Unreferenced_Entities.Append (E1); |
fbf5a39b | 1692 | |
3a89c57d | 1693 | -- Force warning on entity |
fbf5a39b | 1694 | |
9a18e785 RD |
1695 | Set_Referenced (E1, False); |
1696 | end if; | |
996ae0b0 RK |
1697 | end if; |
1698 | end if; | |
1699 | ||
5e9cb404 AC |
1700 | -- Recurse into nested package or block. Do not recurse into a formal |
1701 | -- package, because the corresponding body is not analyzed. | |
996ae0b0 RK |
1702 | |
1703 | <<Continue>> | |
b9b2405f | 1704 | if (Is_Package_Or_Generic_Package (E1) |
c230ed0b AC |
1705 | and then Nkind (Parent (E1)) = N_Package_Specification |
1706 | and then | |
1707 | Nkind (Original_Node (Unit_Declaration_Node (E1))) /= | |
5e9cb404 AC |
1708 | N_Formal_Package_Declaration) |
1709 | ||
1710 | or else Ekind (E1) = E_Block | |
996ae0b0 RK |
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 | |
434632ce AC |
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 | begin | |
1746 | if Is_Access_Type (Typ) and then Is_Dereferenced (N) then | |
1747 | return False; | |
319c6161 | 1748 | |
b3801819 PMR |
1749 | -- A type subject to pragma Default_Initial_Condition may be fully |
1750 | -- default initialized depending on inheritance and the argument of | |
1751 | -- the pragma (SPARK RM 3.1 and SPARK RM 7.3.3). | |
f63d601b | 1752 | |
b3801819 PMR |
1753 | elsif Has_Fully_Default_Initializing_DIC_Pragma (Typ) then |
1754 | return True; | |
319c6161 | 1755 | |
434632ce AC |
1756 | else |
1757 | return Is_Fully_Initialized_Type (Typ); | |
1758 | end if; | |
1759 | end Is_OK_Fully_Initialized; | |
1760 | ||
1761 | ---------------------------- | |
1762 | -- Prefix_Has_Dereference -- | |
1763 | ---------------------------- | |
1764 | ||
1765 | function Prefix_Has_Dereference (Pref : Node_Id) return Boolean is | |
1766 | begin | |
f16d05d9 | 1767 | -- If prefix is of an access type, it certainly needs a dereference |
434632ce AC |
1768 | |
1769 | if Is_Access_Type (Etype (Pref)) then | |
1770 | return True; | |
1771 | ||
1772 | -- If prefix is explicit dereference, that's a dereference for sure | |
1773 | ||
1774 | elsif Nkind (Pref) = N_Explicit_Dereference then | |
1775 | return True; | |
1776 | ||
1777 | -- If prefix is itself a component reference or slice check prefix | |
1778 | ||
1779 | elsif Nkind (Pref) = N_Slice | |
1780 | or else Nkind (Pref) = N_Indexed_Component | |
1781 | or else Nkind (Pref) = N_Selected_Component | |
1782 | then | |
1783 | return Prefix_Has_Dereference (Prefix (Pref)); | |
1784 | ||
1785 | -- All other cases do not involve a dereference | |
1786 | ||
1787 | else | |
1788 | return False; | |
1789 | end if; | |
1790 | end Prefix_Has_Dereference; | |
1791 | ||
1792 | -- Start of processing for Check_Unset_Reference | |
1793 | ||
996ae0b0 RK |
1794 | begin |
1795 | -- Nothing to do if warnings suppressed | |
1796 | ||
1797 | if Warning_Mode = Suppress then | |
1798 | return; | |
1799 | end if; | |
1800 | ||
11d59a86 AC |
1801 | -- Nothing to do for numeric or string literal. Do this test early to |
1802 | -- save time in a common case (it does not matter that we do not include | |
1803 | -- character literal here, since that will be caught later on in the | |
1804 | -- when others branch of the case statement). | |
1805 | ||
1806 | if Nkind (N) in N_Numeric_Or_String_Literal then | |
1807 | return; | |
1808 | end if; | |
1809 | ||
434632ce AC |
1810 | -- Ignore reference unless it comes from source. Almost always if we |
1811 | -- have a reference from generated code, it is bogus (e.g. calls to init | |
1812 | -- procs to set default discriminant values). | |
fbf5a39b | 1813 | |
434632ce | 1814 | if not Comes_From_Source (N) then |
fbf5a39b AC |
1815 | return; |
1816 | end if; | |
1817 | ||
f16d05d9 AC |
1818 | -- Otherwise see what kind of node we have. If the entity already has an |
1819 | -- unset reference, it is not necessarily the earliest in the text, | |
1820 | -- because resolution of the prefix of selected components is completed | |
1821 | -- before the resolution of the selected component itself. As a result, | |
1822 | -- given (R /= null and then R.X > 0), the occurrences of R are examined | |
1823 | -- in right-to-left order. If there is already an unset reference, we | |
1824 | -- check whether N is earlier before proceeding. | |
996ae0b0 RK |
1825 | |
1826 | case Nkind (N) is | |
434632ce | 1827 | |
f3d57416 | 1828 | -- For identifier or expanded name, examine the entity involved |
434632ce | 1829 | |
d8f43ee6 HK |
1830 | when N_Expanded_Name |
1831 | | N_Identifier | |
1832 | => | |
996ae0b0 | 1833 | declare |
fbf5a39b | 1834 | E : constant Entity_Id := Entity (N); |
996ae0b0 RK |
1835 | |
1836 | begin | |
c230ed0b | 1837 | if Ekind_In (E, E_Variable, E_Out_Parameter) |
434632ce AC |
1838 | and then Never_Set_In_Source_Check_Spec (E) |
1839 | and then not Has_Initial_Value (E) | |
996ae0b0 | 1840 | and then (No (Unset_Reference (E)) |
434632ce AC |
1841 | or else |
1842 | Earlier_In_Extended_Unit | |
11d59a86 | 1843 | (Sloc (N), Sloc (Unset_Reference (E)))) |
9a18e785 RD |
1844 | and then not Has_Pragma_Unmodified_Check_Spec (E) |
1845 | and then not Warnings_Off_Check_Spec (E) | |
4bd4bb7f | 1846 | and then not Has_Junk_Name (E) |
996ae0b0 | 1847 | then |
04568369 | 1848 | -- We may have an unset reference. The first test is whether |
434632ce | 1849 | -- this is an access to a discriminant of a record or a |
04568369 ES |
1850 | -- component with default initialization. Both of these |
1851 | -- cases can be ignored, since the actual object that is | |
1852 | -- referenced is definitely initialized. Note that this | |
f16d05d9 | 1853 | -- covers the case of reading discriminants of an OUT |
04568369 ES |
1854 | -- parameter, which is OK even in Ada 83. |
1855 | ||
1856 | -- Note that we are only interested in a direct reference to | |
f16d05d9 | 1857 | -- a record component here. If the reference is through an |
fbf5a39b AC |
1858 | -- access type, then the access object is being referenced, |
1859 | -- not the record, and still deserves an unset reference. | |
1860 | ||
1861 | if Nkind (Parent (N)) = N_Selected_Component | |
434632ce | 1862 | and not Is_Access_Type (Typ) |
fbf5a39b AC |
1863 | then |
1864 | declare | |
1865 | ES : constant Entity_Id := | |
1866 | Entity (Selector_Name (Parent (N))); | |
fbf5a39b AC |
1867 | begin |
1868 | if Ekind (ES) = E_Discriminant | |
434632ce AC |
1869 | or else |
1870 | (Present (Declaration_Node (ES)) | |
1871 | and then | |
1872 | Present (Expression (Declaration_Node (ES)))) | |
fbf5a39b AC |
1873 | then |
1874 | return; | |
1875 | end if; | |
1876 | end; | |
1877 | end if; | |
1878 | ||
434632ce AC |
1879 | -- Exclude fully initialized types |
1880 | ||
1881 | if Is_OK_Fully_Initialized then | |
1882 | return; | |
1883 | end if; | |
1884 | ||
996ae0b0 RK |
1885 | -- Here we have a potential unset reference. But before we |
1886 | -- get worried about it, we have to make sure that the | |
1887 | -- entity declaration is in the same procedure as the | |
04568369 ES |
1888 | -- reference, since if they are in separate procedures, then |
1889 | -- we have no idea about sequential execution. | |
996ae0b0 | 1890 | |
04568369 ES |
1891 | -- The tests in the loop below catch all such cases, but do |
1892 | -- allow the reference to appear in a loop, block, or | |
996ae0b0 RK |
1893 | -- package spec that is nested within the declaring scope. |
1894 | -- As always, it is possible to construct cases where the | |
a90bd866 | 1895 | -- warning is wrong, that is why it is a warning. |
996ae0b0 | 1896 | |
b3b9865d | 1897 | Potential_Unset_Reference : declare |
996ae0b0 RK |
1898 | SR : Entity_Id; |
1899 | SE : constant Entity_Id := Scope (E); | |
1900 | ||
b3b9865d | 1901 | function Within_Postcondition return Boolean; |
5af638c8 | 1902 | -- Returns True if N is within a Postcondition, a |
7f2c8954 AC |
1903 | -- Refined_Post, an Ensures component in a Test_Case, |
1904 | -- or a Contract_Cases. | |
b3b9865d AC |
1905 | |
1906 | -------------------------- | |
1907 | -- Within_Postcondition -- | |
1908 | -------------------------- | |
1909 | ||
1910 | function Within_Postcondition return Boolean is | |
59e6b23c | 1911 | Nod, P : Node_Id; |
b3b9865d AC |
1912 | |
1913 | begin | |
1914 | Nod := Parent (N); | |
1915 | while Present (Nod) loop | |
1916 | if Nkind (Nod) = N_Pragma | |
6e759c2a | 1917 | and then Nam_In (Pragma_Name_Unmapped (Nod), |
ddb8a2c7 | 1918 | Name_Postcondition, |
7f2c8954 | 1919 | Name_Refined_Post, |
ddb8a2c7 | 1920 | Name_Contract_Cases) |
b3b9865d AC |
1921 | then |
1922 | return True; | |
59e6b23c AC |
1923 | |
1924 | elsif Present (Parent (Nod)) then | |
1925 | P := Parent (Nod); | |
1926 | ||
1927 | if Nkind (P) = N_Pragma | |
6e759c2a | 1928 | and then Pragma_Name (P) = |
533e3abc | 1929 | Name_Test_Case |
c9d70ab1 | 1930 | and then Nod = Test_Case_Arg (P, Name_Ensures) |
59e6b23c AC |
1931 | then |
1932 | return True; | |
1933 | end if; | |
b3b9865d AC |
1934 | end if; |
1935 | ||
1936 | Nod := Parent (Nod); | |
1937 | end loop; | |
1938 | ||
1939 | return False; | |
1940 | end Within_Postcondition; | |
1941 | ||
1942 | -- Start of processing for Potential_Unset_Reference | |
1943 | ||
996ae0b0 RK |
1944 | begin |
1945 | SR := Current_Scope; | |
1946 | while SR /= SE loop | |
1947 | if SR = Standard_Standard | |
1948 | or else Is_Subprogram (SR) | |
1949 | or else Is_Concurrent_Body (SR) | |
1950 | or else Is_Concurrent_Type (SR) | |
1951 | then | |
1952 | return; | |
1953 | end if; | |
1954 | ||
1955 | SR := Scope (SR); | |
1956 | end loop; | |
1957 | ||
f16d05d9 AC |
1958 | -- Case of reference has an access type. This is a |
1959 | -- special case since access types are always set to null | |
1960 | -- so cannot be truly uninitialized, but we still want to | |
04568369 | 1961 | -- warn about cases of obvious null dereference. |
fbf5a39b | 1962 | |
434632ce | 1963 | if Is_Access_Type (Typ) then |
04568369 | 1964 | Access_Type_Case : declare |
fbf5a39b AC |
1965 | P : Node_Id; |
1966 | ||
1967 | function Process | |
434632ce | 1968 | (N : Node_Id) return Traverse_Result; |
f3d57416 | 1969 | -- Process function for instantiation of Traverse |
f16d05d9 | 1970 | -- below. Checks if N contains reference to E other |
04568369 | 1971 | -- than a dereference. |
fbf5a39b AC |
1972 | |
1973 | function Ref_In (Nod : Node_Id) return Boolean; | |
04568369 ES |
1974 | -- Determines whether Nod contains a reference to |
1975 | -- the entity E that is not a dereference. | |
1976 | ||
1977 | ------------- | |
1978 | -- Process -- | |
1979 | ------------- | |
fbf5a39b AC |
1980 | |
1981 | function Process | |
434632ce | 1982 | (N : Node_Id) return Traverse_Result |
fbf5a39b AC |
1983 | is |
1984 | begin | |
1985 | if Is_Entity_Name (N) | |
1986 | and then Entity (N) = E | |
1987 | and then not Is_Dereferenced (N) | |
1988 | then | |
1989 | return Abandon; | |
1990 | else | |
1991 | return OK; | |
1992 | end if; | |
1993 | end Process; | |
1994 | ||
04568369 ES |
1995 | ------------ |
1996 | -- Ref_In -- | |
1997 | ------------ | |
1998 | ||
fbf5a39b AC |
1999 | function Ref_In (Nod : Node_Id) return Boolean is |
2000 | function Traverse is new Traverse_Func (Process); | |
fbf5a39b AC |
2001 | begin |
2002 | return Traverse (Nod) = Abandon; | |
2003 | end Ref_In; | |
2004 | ||
04568369 ES |
2005 | -- Start of processing for Access_Type_Case |
2006 | ||
fbf5a39b | 2007 | begin |
434632ce AC |
2008 | -- Don't bother if we are inside an instance, since |
2009 | -- the compilation of the generic template is where | |
2010 | -- the warning should be issued. | |
fbf5a39b AC |
2011 | |
2012 | if In_Instance then | |
2013 | return; | |
2014 | end if; | |
2015 | ||
434632ce AC |
2016 | -- Don't bother if this is not the main unit. If we |
2017 | -- try to give this warning for with'ed units, we | |
2018 | -- get some false positives, since we do not record | |
2019 | -- references in other units. | |
fbf5a39b AC |
2020 | |
2021 | if not In_Extended_Main_Source_Unit (E) | |
2022 | or else | |
2023 | not In_Extended_Main_Source_Unit (N) | |
2024 | then | |
2025 | return; | |
2026 | end if; | |
2027 | ||
fbe627af | 2028 | -- We are only interested in dereferences |
fbf5a39b AC |
2029 | |
2030 | if not Is_Dereferenced (N) then | |
2031 | return; | |
2032 | end if; | |
2033 | ||
2034 | -- One more check, don't bother with references | |
f16d05d9 | 2035 | -- that are inside conditional statements or WHILE |
fbf5a39b AC |
2036 | -- loops if the condition references the entity in |
2037 | -- question. This avoids most false positives. | |
2038 | ||
2039 | P := Parent (N); | |
2040 | loop | |
2041 | P := Parent (P); | |
2042 | exit when No (P); | |
2043 | ||
c230ed0b AC |
2044 | if Nkind_In (P, N_If_Statement, N_Elsif_Part) |
2045 | and then Ref_In (Condition (P)) | |
fbf5a39b AC |
2046 | then |
2047 | return; | |
2048 | ||
2049 | elsif Nkind (P) = N_Loop_Statement | |
2050 | and then Present (Iteration_Scheme (P)) | |
2051 | and then | |
2052 | Ref_In (Condition (Iteration_Scheme (P))) | |
2053 | then | |
2054 | return; | |
2055 | end if; | |
2056 | end loop; | |
04568369 | 2057 | end Access_Type_Case; |
fbf5a39b AC |
2058 | end if; |
2059 | ||
b3b9865d | 2060 | -- One more check, don't bother if we are within a |
59e6b23c AC |
2061 | -- postcondition, since the expression occurs in a |
2062 | -- place unrelated to the actual test. | |
fbf5a39b | 2063 | |
b3b9865d | 2064 | if not Within_Postcondition then |
fbf5a39b | 2065 | |
b3b9865d AC |
2066 | -- Here we definitely have a case for giving a warning |
2067 | -- for a reference to an unset value. But we don't | |
2068 | -- give the warning now. Instead set Unset_Reference | |
2069 | -- in the identifier involved. The reason for this is | |
2070 | -- that if we find the variable is never ever assigned | |
2071 | -- a value then that warning is more important and | |
2072 | -- there is no point in giving the reference warning. | |
fbf5a39b | 2073 | |
b3b9865d | 2074 | -- If this is an identifier, set the field directly |
fbf5a39b | 2075 | |
b3b9865d AC |
2076 | if Nkind (N) = N_Identifier then |
2077 | Set_Unset_Reference (E, N); | |
2078 | ||
2079 | -- Otherwise it is an expanded name, so set the field | |
2080 | -- of the actual identifier for the reference. | |
2081 | ||
2082 | else | |
2083 | Set_Unset_Reference (E, Selector_Name (N)); | |
2084 | end if; | |
996ae0b0 | 2085 | end if; |
b3b9865d | 2086 | end Potential_Unset_Reference; |
996ae0b0 RK |
2087 | end if; |
2088 | end; | |
2089 | ||
434632ce AC |
2090 | -- Indexed component or slice |
2091 | ||
d8f43ee6 HK |
2092 | when N_Indexed_Component |
2093 | | N_Slice | |
2094 | => | |
434632ce AC |
2095 | -- If prefix does not involve dereferencing an access type, then |
2096 | -- we know we are OK if the component type is fully initialized, | |
2097 | -- since the component will have been set as part of the default | |
2098 | -- initialization. | |
fbf5a39b | 2099 | |
434632ce AC |
2100 | if not Prefix_Has_Dereference (Prefix (N)) |
2101 | and then Is_OK_Fully_Initialized | |
fbf5a39b | 2102 | then |
434632ce | 2103 | return; |
fbf5a39b | 2104 | |
434632ce AC |
2105 | -- Look at prefix in access type case, or if the component is not |
2106 | -- fully initialized. | |
fbf5a39b AC |
2107 | |
2108 | else | |
2109 | Check_Unset_Reference (Prefix (N)); | |
2110 | end if; | |
996ae0b0 | 2111 | |
434632ce AC |
2112 | -- Record component |
2113 | ||
2114 | when N_Selected_Component => | |
2115 | declare | |
2116 | Pref : constant Node_Id := Prefix (N); | |
2117 | Ent : constant Entity_Id := Entity (Selector_Name (N)); | |
2118 | ||
2119 | begin | |
2120 | -- If prefix involves dereferencing an access type, always | |
2121 | -- check the prefix, since the issue then is whether this | |
2122 | -- access value is null. | |
2123 | ||
2124 | if Prefix_Has_Dereference (Pref) then | |
2125 | null; | |
2126 | ||
2127 | -- Always go to prefix if no selector entity is set. Can this | |
2128 | -- happen in the normal case? Not clear, but it definitely can | |
2129 | -- happen in error cases. | |
2130 | ||
2131 | elsif No (Ent) then | |
2132 | null; | |
2133 | ||
2134 | -- For a record component, check some cases where we have | |
2135 | -- reasonable cause to consider that the component is known to | |
2136 | -- be or probably is initialized. In this case, we don't care | |
2137 | -- if the prefix itself was explicitly initialized. | |
2138 | ||
2139 | -- Discriminants are always considered initialized | |
2140 | ||
2141 | elsif Ekind (Ent) = E_Discriminant then | |
2142 | return; | |
2143 | ||
2144 | -- An explicitly initialized component is certainly initialized | |
2145 | ||
2146 | elsif Nkind (Parent (Ent)) = N_Component_Declaration | |
2147 | and then Present (Expression (Parent (Ent))) | |
2148 | then | |
2149 | return; | |
2150 | ||
2151 | -- A fully initialized component is initialized | |
2152 | ||
2153 | elsif Is_OK_Fully_Initialized then | |
2154 | return; | |
2155 | end if; | |
2156 | ||
2157 | -- If none of those cases apply, check the record type prefix | |
2158 | ||
2159 | Check_Unset_Reference (Pref); | |
2160 | end; | |
2161 | ||
064f4527 TQ |
2162 | -- For type conversions, qualifications, or expressions with actions, |
2163 | -- examine the expression. | |
434632ce | 2164 | |
d8f43ee6 HK |
2165 | when N_Expression_With_Actions |
2166 | | N_Qualified_Expression | |
2167 | | N_Type_Conversion | |
2168 | => | |
996ae0b0 RK |
2169 | Check_Unset_Reference (Expression (N)); |
2170 | ||
434632ce AC |
2171 | -- For explicit dereference, always check prefix, which will generate |
2172 | -- an unset reference (since this is a case of dereferencing null). | |
2173 | ||
2174 | when N_Explicit_Dereference => | |
2175 | Check_Unset_Reference (Prefix (N)); | |
2176 | ||
2177 | -- All other cases are not cases of an unset reference | |
2178 | ||
996ae0b0 RK |
2179 | when others => |
2180 | null; | |
996ae0b0 RK |
2181 | end case; |
2182 | end Check_Unset_Reference; | |
2183 | ||
2184 | ------------------------ | |
2185 | -- Check_Unused_Withs -- | |
2186 | ------------------------ | |
2187 | ||
2188 | procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit) is | |
2189 | Cnode : Node_Id; | |
2190 | Item : Node_Id; | |
2191 | Lunit : Node_Id; | |
2192 | Ent : Entity_Id; | |
2193 | ||
2194 | Munite : constant Entity_Id := Cunit_Entity (Main_Unit); | |
2195 | -- This is needed for checking the special renaming case | |
2196 | ||
2197 | procedure Check_One_Unit (Unit : Unit_Number_Type); | |
2198 | -- Subsidiary procedure, performs checks for specified unit | |
2199 | ||
2200 | -------------------- | |
2201 | -- Check_One_Unit -- | |
2202 | -------------------- | |
2203 | ||
2204 | procedure Check_One_Unit (Unit : Unit_Number_Type) is | |
2205 | Is_Visible_Renaming : Boolean := False; | |
2206 | Pack : Entity_Id; | |
2207 | ||
fbf5a39b | 2208 | procedure Check_Inner_Package (Pack : Entity_Id); |
f16d05d9 AC |
2209 | -- Pack is a package local to a unit in a with_clause. Both the unit |
2210 | -- and Pack are referenced. If none of the entities in Pack are | |
2211 | -- referenced, then the only occurrence of Pack is in a USE clause | |
2212 | -- or a pragma, and a warning is worthwhile as well. | |
fbf5a39b AC |
2213 | |
2214 | function Check_System_Aux return Boolean; | |
308e6f3a | 2215 | -- Before giving a warning on a with_clause for System, check whether |
f16d05d9 | 2216 | -- a system extension is present. |
fbf5a39b | 2217 | |
996ae0b0 RK |
2218 | function Find_Package_Renaming |
2219 | (P : Entity_Id; | |
2220 | L : Entity_Id) return Entity_Id; | |
2221 | -- The only reference to a context unit may be in a renaming | |
f16d05d9 AC |
2222 | -- declaration. If this renaming declares a visible entity, do not |
2223 | -- warn that the context clause could be moved to the body, because | |
2224 | -- the renaming may be intended to re-export the unit. | |
996ae0b0 | 2225 | |
2844b330 | 2226 | function Has_Visible_Entities (P : Entity_Id) return Boolean; |
c5288c90 AC |
2227 | -- This function determines if a package has any visible entities. |
2228 | -- True is returned if there is at least one declared visible entity, | |
2229 | -- otherwise False is returned (e.g. case of only pragmas present). | |
2844b330 | 2230 | |
fbf5a39b AC |
2231 | ------------------------- |
2232 | -- Check_Inner_Package -- | |
2233 | ------------------------- | |
2234 | ||
2235 | procedure Check_Inner_Package (Pack : Entity_Id) is | |
2236 | E : Entity_Id; | |
2237 | Un : constant Node_Id := Sinfo.Unit (Cnode); | |
2238 | ||
2239 | function Check_Use_Clause (N : Node_Id) return Traverse_Result; | |
2717634d | 2240 | -- If N is a use_clause for Pack, emit warning |
fbf5a39b AC |
2241 | |
2242 | procedure Check_Use_Clauses is new | |
2243 | Traverse_Proc (Check_Use_Clause); | |
2244 | ||
2245 | ---------------------- | |
2246 | -- Check_Use_Clause -- | |
2247 | ---------------------- | |
2248 | ||
2249 | function Check_Use_Clause (N : Node_Id) return Traverse_Result is | |
fbf5a39b | 2250 | begin |
851e9f19 PMR |
2251 | if Nkind (N) = N_Use_Package_Clause |
2252 | and then Entity (Name (N)) = Pack | |
2253 | then | |
2254 | -- Suppress message if any serious errors detected that turn | |
2255 | -- off expansion, and thus result in false positives for | |
2256 | -- this warning. | |
2257 | ||
2258 | if Serious_Errors_Detected = 0 then | |
2259 | Error_Msg_Qual_Level := 1; | |
2260 | Error_Msg_NE -- CODEFIX | |
2261 | ("?u?no entities of package& are referenced!", | |
2262 | Name (N), Pack); | |
2263 | Error_Msg_Qual_Level := 0; | |
2264 | end if; | |
fbf5a39b AC |
2265 | end if; |
2266 | ||
2267 | return OK; | |
2268 | end Check_Use_Clause; | |
2269 | ||
2270 | -- Start of processing for Check_Inner_Package | |
2271 | ||
2272 | begin | |
2273 | E := First_Entity (Pack); | |
fbf5a39b | 2274 | while Present (E) loop |
434632ce | 2275 | if Referenced_Check_Spec (E) then |
fbf5a39b AC |
2276 | return; |
2277 | end if; | |
2278 | ||
2279 | Next_Entity (E); | |
2280 | end loop; | |
2281 | ||
04568369 ES |
2282 | -- No entities of the package are referenced. Check whether the |
2283 | -- reference to the package itself is a use clause, and if so | |
2284 | -- place a warning on it. | |
fbf5a39b AC |
2285 | |
2286 | Check_Use_Clauses (Un); | |
2287 | end Check_Inner_Package; | |
2288 | ||
2289 | ---------------------- | |
2290 | -- Check_System_Aux -- | |
2291 | ---------------------- | |
2292 | ||
2293 | function Check_System_Aux return Boolean is | |
2294 | Ent : Entity_Id; | |
2295 | ||
2296 | begin | |
2297 | if Chars (Lunit) = Name_System | |
2298 | and then Scope (Lunit) = Standard_Standard | |
2299 | and then Present_System_Aux | |
2300 | then | |
2301 | Ent := First_Entity (System_Aux_Id); | |
fbf5a39b | 2302 | while Present (Ent) loop |
434632ce | 2303 | if Referenced_Check_Spec (Ent) then |
fbf5a39b AC |
2304 | return True; |
2305 | end if; | |
2306 | ||
2307 | Next_Entity (Ent); | |
2308 | end loop; | |
2309 | end if; | |
2310 | ||
2311 | return False; | |
2312 | end Check_System_Aux; | |
2313 | ||
996ae0b0 RK |
2314 | --------------------------- |
2315 | -- Find_Package_Renaming -- | |
2316 | --------------------------- | |
2317 | ||
2318 | function Find_Package_Renaming | |
2319 | (P : Entity_Id; | |
2320 | L : Entity_Id) return Entity_Id | |
2321 | is | |
2322 | E1 : Entity_Id; | |
2323 | R : Entity_Id; | |
2324 | ||
2325 | begin | |
2326 | Is_Visible_Renaming := False; | |
996ae0b0 | 2327 | |
04568369 | 2328 | E1 := First_Entity (P); |
996ae0b0 | 2329 | while Present (E1) loop |
c230ed0b | 2330 | if Ekind (E1) = E_Package and then Renamed_Object (E1) = L then |
996ae0b0 RK |
2331 | Is_Visible_Renaming := not Is_Hidden (E1); |
2332 | return E1; | |
2333 | ||
2334 | elsif Ekind (E1) = E_Package | |
2335 | and then No (Renamed_Object (E1)) | |
2336 | and then not Is_Generic_Instance (E1) | |
2337 | then | |
2338 | R := Find_Package_Renaming (E1, L); | |
2339 | ||
2340 | if Present (R) then | |
2341 | Is_Visible_Renaming := not Is_Hidden (R); | |
2342 | return R; | |
2343 | end if; | |
2344 | end if; | |
2345 | ||
2346 | Next_Entity (E1); | |
2347 | end loop; | |
2348 | ||
2349 | return Empty; | |
2350 | end Find_Package_Renaming; | |
2351 | ||
2844b330 AC |
2352 | -------------------------- |
2353 | -- Has_Visible_Entities -- | |
2354 | -------------------------- | |
2355 | ||
2356 | function Has_Visible_Entities (P : Entity_Id) return Boolean is | |
2357 | E : Entity_Id; | |
2358 | ||
2359 | begin | |
2844b330 AC |
2360 | -- If unit in context is not a package, it is a subprogram that |
2361 | -- is not called or a generic unit that is not instantiated | |
2362 | -- in the current unit, and warning is appropriate. | |
2363 | ||
2364 | if Ekind (P) /= E_Package then | |
2365 | return True; | |
2366 | end if; | |
2367 | ||
2368 | -- If unit comes from a limited_with clause, look for declaration | |
2369 | -- of shadow entities. | |
2370 | ||
2371 | if Present (Limited_View (P)) then | |
2372 | E := First_Entity (Limited_View (P)); | |
2373 | else | |
2374 | E := First_Entity (P); | |
2375 | end if; | |
2376 | ||
c230ed0b AC |
2377 | while Present (E) and then E /= First_Private_Entity (P) loop |
2378 | if Comes_From_Source (E) or else Present (Limited_View (P)) then | |
2844b330 AC |
2379 | return True; |
2380 | end if; | |
2381 | ||
2382 | Next_Entity (E); | |
2383 | end loop; | |
2384 | ||
2385 | return False; | |
2386 | end Has_Visible_Entities; | |
2387 | ||
996ae0b0 RK |
2388 | -- Start of processing for Check_One_Unit |
2389 | ||
2390 | begin | |
2391 | Cnode := Cunit (Unit); | |
2392 | ||
04568369 ES |
2393 | -- Only do check in units that are part of the extended main unit. |
2394 | -- This is actually a necessary restriction, because in the case of | |
2395 | -- subprogram acting as its own specification, there can be with's in | |
2396 | -- subunits that we will not see. | |
996ae0b0 RK |
2397 | |
2398 | if not In_Extended_Main_Source_Unit (Cnode) then | |
2399 | return; | |
2400 | end if; | |
2401 | ||
2402 | -- Loop through context items in this unit | |
2403 | ||
2404 | Item := First (Context_Items (Cnode)); | |
2405 | while Present (Item) loop | |
996ae0b0 | 2406 | if Nkind (Item) = N_With_Clause |
c230ed0b AC |
2407 | and then not Implicit_With (Item) |
2408 | and then In_Extended_Main_Source_Unit (Item) | |
1c85591c AC |
2409 | |
2410 | -- Guard for no entity present. Not clear under what conditions | |
2411 | -- this happens, but it does occur, and since this is only a | |
2412 | -- warning, we just suppress the warning in this case. | |
2413 | ||
2414 | and then Nkind (Name (Item)) in N_Has_Entity | |
2415 | and then Present (Entity (Name (Item))) | |
996ae0b0 RK |
2416 | then |
2417 | Lunit := Entity (Name (Item)); | |
2418 | ||
3f1ede06 RD |
2419 | -- Check if this unit is referenced (skip the check if this |
2420 | -- is explicitly marked by a pragma Unreferenced). | |
996ae0b0 | 2421 | |
c230ed0b | 2422 | if not Referenced (Lunit) and then not Has_Unreferenced (Lunit) |
3f1ede06 | 2423 | then |
04568369 ES |
2424 | -- Suppress warnings in internal units if not in -gnatg mode |
2425 | -- (these would be junk warnings for an application program, | |
3f1ede06 | 2426 | -- since they refer to problems in internal units). |
996ae0b0 | 2427 | |
8ab31c0c | 2428 | if GNAT_Mode or else not Is_Internal_Unit (Unit) then |
04568369 ES |
2429 | -- Here we definitely have a non-referenced unit. If it |
2430 | -- is the special call for a spec unit, then just set the | |
2431 | -- flag to be read later. | |
996ae0b0 RK |
2432 | |
2433 | if Unit = Spec_Unit then | |
2434 | Set_Unreferenced_In_Spec (Item); | |
2435 | ||
c5288c90 AC |
2436 | -- Otherwise simple unreferenced message, but skip this |
2437 | -- if no visible entities, because that is most likely a | |
2438 | -- case where warning would be false positive (e.g. a | |
2439 | -- package with only a linker options pragma and nothing | |
2440 | -- else or a pragma elaborate with a body library task). | |
996ae0b0 | 2441 | |
2844b330 | 2442 | elsif Has_Visible_Entities (Entity (Name (Item))) then |
19d846a0 | 2443 | Error_Msg_N -- CODEFIX |
685bc70f | 2444 | ("?u?unit& is not referenced!", Name (Item)); |
996ae0b0 RK |
2445 | end if; |
2446 | end if; | |
2447 | ||
2448 | -- If main unit is a renaming of this unit, then we consider | |
a90bd866 | 2449 | -- the with to be OK (obviously it is needed in this case). |
3f1ede06 RD |
2450 | -- This may be transitive: the unit in the with_clause may |
2451 | -- itself be a renaming, in which case both it and the main | |
2452 | -- unit rename the same ultimate package. | |
996ae0b0 RK |
2453 | |
2454 | elsif Present (Renamed_Entity (Munite)) | |
3f1ede06 RD |
2455 | and then |
2456 | (Renamed_Entity (Munite) = Lunit | |
2457 | or else Renamed_Entity (Munite) = Renamed_Entity (Lunit)) | |
996ae0b0 RK |
2458 | then |
2459 | null; | |
2460 | ||
04568369 ES |
2461 | -- If this unit is referenced, and it is a package, we do |
2462 | -- another test, to see if any of the entities in the package | |
2463 | -- are referenced. If none of the entities are referenced, we | |
2464 | -- still post a warning. This occurs if the only use of the | |
2465 | -- package is in a use clause, or in a package renaming | |
561b5849 RD |
2466 | -- declaration. This check is skipped for packages that are |
2467 | -- renamed in a spec, since the entities in such a package are | |
2468 | -- visible to clients via the renaming. | |
996ae0b0 | 2469 | |
561b5849 RD |
2470 | elsif Ekind (Lunit) = E_Package |
2471 | and then not Renamed_In_Spec (Lunit) | |
2472 | then | |
04568369 ES |
2473 | -- If Is_Instantiated is set, it means that the package is |
2474 | -- implicitly instantiated (this is the case of parent | |
2475 | -- instance or an actual for a generic package formal), and | |
2476 | -- this counts as a reference. | |
996ae0b0 RK |
2477 | |
2478 | if Is_Instantiated (Lunit) then | |
2479 | null; | |
2480 | ||
2481 | -- If no entities in package, and there is a pragma | |
04568369 ES |
2482 | -- Elaborate_Body present, then assume that this with is |
2483 | -- done for purposes of this elaboration. | |
996ae0b0 RK |
2484 | |
2485 | elsif No (First_Entity (Lunit)) | |
2486 | and then Has_Pragma_Elaborate_Body (Lunit) | |
2487 | then | |
2488 | null; | |
2489 | ||
2490 | -- Otherwise see if any entities have been referenced | |
2491 | ||
2492 | else | |
04568369 ES |
2493 | if Limited_Present (Item) then |
2494 | Ent := First_Entity (Limited_View (Lunit)); | |
2495 | else | |
2496 | Ent := First_Entity (Lunit); | |
2497 | end if; | |
2498 | ||
996ae0b0 | 2499 | loop |
04568369 ES |
2500 | -- No more entities, and we did not find one that was |
2501 | -- referenced. Means we have a definite case of a with | |
2502 | -- none of whose entities was referenced. | |
996ae0b0 RK |
2503 | |
2504 | if No (Ent) then | |
2505 | ||
2506 | -- If in spec, just set the flag | |
2507 | ||
2508 | if Unit = Spec_Unit then | |
2509 | Set_No_Entities_Ref_In_Spec (Item); | |
2510 | ||
fbf5a39b AC |
2511 | elsif Check_System_Aux then |
2512 | null; | |
2513 | ||
4ffafd86 | 2514 | -- Else the warning may be needed |
996ae0b0 RK |
2515 | |
2516 | else | |
4ffafd86 AC |
2517 | declare |
2518 | Eitem : constant Entity_Id := | |
2519 | Entity (Name (Item)); | |
2520 | ||
2521 | begin | |
2522 | -- Warn if we unreferenced flag set and we | |
2523 | -- have not had serious errors. The reason we | |
2524 | -- inhibit the message if there are errors is | |
2525 | -- to prevent false positives from disabling | |
2526 | -- expansion. | |
2527 | ||
2528 | if not Has_Unreferenced (Eitem) | |
2529 | and then Serious_Errors_Detected = 0 | |
2530 | then | |
2531 | -- Get possible package renaming | |
2532 | ||
2533 | Pack := | |
2534 | Find_Package_Renaming (Munite, Lunit); | |
2535 | ||
2536 | -- No warning if either the package or its | |
2537 | -- renaming is used as a generic actual. | |
2538 | ||
2539 | if Used_As_Generic_Actual (Eitem) | |
2540 | or else | |
2541 | (Present (Pack) | |
2542 | and then | |
2543 | Used_As_Generic_Actual (Pack)) | |
2544 | then | |
2545 | exit; | |
2546 | end if; | |
2547 | ||
2548 | -- Here we give the warning | |
2549 | ||
2550 | Error_Msg_N -- CODEFIX | |
2551 | ("?u?no entities of & are referenced!", | |
2552 | Name (Item)); | |
2553 | ||
2554 | -- Flag renaming of package as well. If | |
2555 | -- the original package has warnings off, | |
2556 | -- we suppress the warning on the renaming | |
2557 | -- as well. | |
2558 | ||
2559 | if Present (Pack) | |
2560 | and then not Has_Warnings_Off (Lunit) | |
2561 | and then not Has_Unreferenced (Pack) | |
2562 | then | |
2563 | Error_Msg_NE -- CODEFIX | |
2564 | ("?u?no entities of& are referenced!", | |
2565 | Unit_Declaration_Node (Pack), Pack); | |
2566 | end if; | |
2567 | end if; | |
2568 | end; | |
996ae0b0 RK |
2569 | end if; |
2570 | ||
2571 | exit; | |
2572 | ||
434632ce AC |
2573 | -- Case of entity being referenced. The reference may |
2574 | -- come from a limited_with_clause, in which case the | |
2575 | -- limited view of the entity carries the flag. | |
2576 | ||
2577 | elsif Referenced_Check_Spec (Ent) | |
2578 | or else Referenced_As_LHS_Check_Spec (Ent) | |
561b5849 | 2579 | or else Referenced_As_Out_Parameter_Check_Spec (Ent) |
434632ce | 2580 | or else |
7b56a91b | 2581 | (From_Limited_With (Ent) |
434632ce AC |
2582 | and then Is_Incomplete_Type (Ent) |
2583 | and then Present (Non_Limited_View (Ent)) | |
2584 | and then Referenced (Non_Limited_View (Ent))) | |
fbf5a39b | 2585 | then |
04568369 ES |
2586 | -- This means that the with is indeed fine, in that |
2587 | -- it is definitely needed somewhere, and we can | |
434632ce | 2588 | -- quit worrying about this one... |
996ae0b0 | 2589 | |
434632ce | 2590 | -- Except for one little detail: if either of the |
04568369 ES |
2591 | -- flags was set during spec processing, this is |
2592 | -- where we complain that the with could be moved | |
2593 | -- from the spec. If the spec contains a visible | |
2594 | -- renaming of the package, inhibit warning to move | |
2595 | -- with_clause to body. | |
996ae0b0 RK |
2596 | |
2597 | if Ekind (Munite) = E_Package_Body then | |
2598 | Pack := | |
2599 | Find_Package_Renaming | |
2600 | (Spec_Entity (Munite), Lunit); | |
e4982b64 AC |
2601 | else |
2602 | Pack := Empty; | |
996ae0b0 RK |
2603 | end if; |
2604 | ||
e4982b64 AC |
2605 | -- If a renaming is present in the spec do not warn |
2606 | -- because the body or child unit may depend on it. | |
2607 | ||
2608 | if Present (Pack) | |
2609 | and then Renamed_Entity (Pack) = Lunit | |
2610 | then | |
2611 | exit; | |
2612 | ||
2613 | elsif Unreferenced_In_Spec (Item) then | |
19d846a0 | 2614 | Error_Msg_N -- CODEFIX |
685bc70f | 2615 | ("?u?unit& is not referenced in spec!", |
996ae0b0 RK |
2616 | Name (Item)); |
2617 | ||
2618 | elsif No_Entities_Ref_In_Spec (Item) then | |
19d846a0 | 2619 | Error_Msg_N -- CODEFIX |
685bc70f | 2620 | ("?u?no entities of & are referenced in spec!", |
996ae0b0 RK |
2621 | Name (Item)); |
2622 | ||
2623 | else | |
fbf5a39b AC |
2624 | if Ekind (Ent) = E_Package then |
2625 | Check_Inner_Package (Ent); | |
2626 | end if; | |
2627 | ||
996ae0b0 RK |
2628 | exit; |
2629 | end if; | |
2630 | ||
2631 | if not Is_Visible_Renaming then | |
483c78cb | 2632 | Error_Msg_N -- CODEFIX |
685bc70f | 2633 | ("\?u?with clause might be moved to body!", |
996ae0b0 RK |
2634 | Name (Item)); |
2635 | end if; | |
2636 | ||
2637 | exit; | |
2638 | ||
2639 | -- Move to next entity to continue search | |
2640 | ||
2641 | else | |
2642 | Next_Entity (Ent); | |
2643 | end if; | |
2644 | end loop; | |
2645 | end if; | |
2646 | ||
2647 | -- For a generic package, the only interesting kind of | |
04568369 ES |
2648 | -- reference is an instantiation, since entities cannot be |
2649 | -- referenced directly. | |
996ae0b0 RK |
2650 | |
2651 | elsif Is_Generic_Unit (Lunit) then | |
2652 | ||
2653 | -- Unit was never instantiated, set flag for case of spec | |
2654 | -- call, or give warning for normal call. | |
2655 | ||
2656 | if not Is_Instantiated (Lunit) then | |
2657 | if Unit = Spec_Unit then | |
2658 | Set_Unreferenced_In_Spec (Item); | |
2659 | else | |
483c78cb | 2660 | Error_Msg_N -- CODEFIX |
685bc70f | 2661 | ("?u?unit& is never instantiated!", Name (Item)); |
996ae0b0 RK |
2662 | end if; |
2663 | ||
04568369 ES |
2664 | -- If unit was indeed instantiated, make sure that flag is |
2665 | -- not set showing it was uninstantiated in the spec, and if | |
2666 | -- so, give warning. | |
996ae0b0 RK |
2667 | |
2668 | elsif Unreferenced_In_Spec (Item) then | |
2669 | Error_Msg_N | |
685bc70f | 2670 | ("?u?unit& is not instantiated in spec!", Name (Item)); |
483c78cb | 2671 | Error_Msg_N -- CODEFIX |
685bc70f | 2672 | ("\?u?with clause can be moved to body!", Name (Item)); |
996ae0b0 RK |
2673 | end if; |
2674 | end if; | |
2675 | end if; | |
2676 | ||
2677 | Next (Item); | |
2678 | end loop; | |
996ae0b0 RK |
2679 | end Check_One_Unit; |
2680 | ||
2681 | -- Start of processing for Check_Unused_Withs | |
2682 | ||
2683 | begin | |
1250f802 RD |
2684 | -- Immediate return if no semantics or warning flag not set |
2685 | ||
685bc70f | 2686 | if not Opt.Check_Withs or else Operating_Mode = Check_Syntax then |
996ae0b0 RK |
2687 | return; |
2688 | end if; | |
2689 | ||
a54ffd6c AC |
2690 | Process_Deferred_References; |
2691 | ||
a9895094 AC |
2692 | -- Flag any unused with clauses. For a subunit, check only the units |
2693 | -- in its context, not those of the parent, which may be needed by other | |
2694 | -- subunits. We will get the full warnings when we compile the parent, | |
2695 | -- but the following is helpful when compiling a subunit by itself. | |
996ae0b0 RK |
2696 | |
2697 | if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then | |
a9895094 AC |
2698 | if Current_Sem_Unit = Main_Unit then |
2699 | Check_One_Unit (Main_Unit); | |
2700 | end if; | |
2701 | ||
996ae0b0 RK |
2702 | return; |
2703 | end if; | |
2704 | ||
2705 | -- Process specified units | |
2706 | ||
2707 | if Spec_Unit = No_Unit then | |
2708 | ||
2709 | -- For main call, check all units | |
2710 | ||
2711 | for Unit in Main_Unit .. Last_Unit loop | |
2712 | Check_One_Unit (Unit); | |
2713 | end loop; | |
2714 | ||
2715 | else | |
2716 | -- For call for spec, check only the spec | |
2717 | ||
2718 | Check_One_Unit (Spec_Unit); | |
2719 | end if; | |
2720 | end Check_Unused_Withs; | |
2721 | ||
fbf5a39b AC |
2722 | --------------------------------- |
2723 | -- Generic_Package_Spec_Entity -- | |
2724 | --------------------------------- | |
2725 | ||
2726 | function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean is | |
2727 | S : Entity_Id; | |
2728 | ||
2729 | begin | |
2730 | if Is_Package_Body_Entity (E) then | |
2731 | return False; | |
2732 | ||
2733 | else | |
2734 | S := Scope (E); | |
fbf5a39b AC |
2735 | loop |
2736 | if S = Standard_Standard then | |
2737 | return False; | |
2738 | ||
2739 | elsif Ekind (S) = E_Generic_Package then | |
2740 | return True; | |
2741 | ||
2742 | elsif Ekind (S) = E_Package then | |
2743 | S := Scope (S); | |
2744 | ||
2745 | else | |
2746 | return False; | |
2747 | end if; | |
2748 | end loop; | |
2749 | end if; | |
2750 | end Generic_Package_Spec_Entity; | |
2751 | ||
434632ce AC |
2752 | ---------------------- |
2753 | -- Goto_Spec_Entity -- | |
2754 | ---------------------- | |
2755 | ||
2756 | function Goto_Spec_Entity (E : Entity_Id) return Entity_Id is | |
2757 | begin | |
c230ed0b | 2758 | if Is_Formal (E) and then Present (Spec_Entity (E)) then |
434632ce AC |
2759 | return Spec_Entity (E); |
2760 | else | |
2761 | return E; | |
2762 | end if; | |
2763 | end Goto_Spec_Entity; | |
2764 | ||
4bd4bb7f AC |
2765 | ------------------- |
2766 | -- Has_Junk_Name -- | |
2767 | ------------------- | |
2768 | ||
2769 | function Has_Junk_Name (E : Entity_Id) return Boolean is | |
2770 | function Match (S : String) return Boolean; | |
2771 | -- Return true if substring S is found in Name_Buffer (1 .. Name_Len) | |
2772 | ||
2773 | ----------- | |
2774 | -- Match -- | |
2775 | ----------- | |
2776 | ||
2777 | function Match (S : String) return Boolean is | |
2778 | Slen1 : constant Integer := S'Length - 1; | |
2779 | ||
2780 | begin | |
2781 | for J in 1 .. Name_Len - S'Length + 1 loop | |
2782 | if Name_Buffer (J .. J + Slen1) = S then | |
2783 | return True; | |
2784 | end if; | |
2785 | end loop; | |
2786 | ||
2787 | return False; | |
2788 | end Match; | |
2789 | ||
2790 | -- Start of processing for Has_Junk_Name | |
2791 | ||
2792 | begin | |
2793 | Get_Unqualified_Decoded_Name_String (Chars (E)); | |
2794 | ||
2795 | return | |
2796 | Match ("discard") or else | |
2797 | Match ("dummy") or else | |
2798 | Match ("ignore") or else | |
2799 | Match ("junk") or else | |
2800 | Match ("unused"); | |
2801 | end Has_Junk_Name; | |
2802 | ||
9d77af56 RD |
2803 | -------------------------------------- |
2804 | -- Has_Pragma_Unmodified_Check_Spec -- | |
2805 | -------------------------------------- | |
2806 | ||
2807 | function Has_Pragma_Unmodified_Check_Spec | |
2808 | (E : Entity_Id) return Boolean | |
2809 | is | |
2810 | begin | |
2811 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
9a18e785 RD |
2812 | |
2813 | -- Note: use of OR instead of OR ELSE here is deliberate, we want | |
2814 | -- to mess with Unmodified flags on both body and spec entities. | |
b7051481 | 2815 | -- Has_Unmodified has side effects! |
9a18e785 RD |
2816 | |
2817 | return Has_Unmodified (E) | |
2818 | or | |
2819 | Has_Unmodified (Spec_Entity (E)); | |
2820 | ||
9d77af56 | 2821 | else |
9a18e785 | 2822 | return Has_Unmodified (E); |
9d77af56 RD |
2823 | end if; |
2824 | end Has_Pragma_Unmodified_Check_Spec; | |
2825 | ||
434632ce AC |
2826 | ---------------------------------------- |
2827 | -- Has_Pragma_Unreferenced_Check_Spec -- | |
2828 | ---------------------------------------- | |
2829 | ||
2830 | function Has_Pragma_Unreferenced_Check_Spec | |
2831 | (E : Entity_Id) return Boolean | |
2832 | is | |
2833 | begin | |
2834 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
9a18e785 RD |
2835 | |
2836 | -- Note: use of OR here instead of OR ELSE is deliberate, we want | |
2837 | -- to mess with flags on both entities. | |
2838 | ||
2839 | return Has_Unreferenced (E) | |
2840 | or | |
2841 | Has_Unreferenced (Spec_Entity (E)); | |
2842 | ||
434632ce | 2843 | else |
9a18e785 | 2844 | return Has_Unreferenced (E); |
434632ce AC |
2845 | end if; |
2846 | end Has_Pragma_Unreferenced_Check_Spec; | |
2847 | ||
9a18e785 RD |
2848 | ---------------- |
2849 | -- Initialize -- | |
2850 | ---------------- | |
2851 | ||
2852 | procedure Initialize is | |
2853 | begin | |
2854 | Warnings_Off_Pragmas.Init; | |
2855 | Unreferenced_Entities.Init; | |
2856 | In_Out_Warnings.Init; | |
2857 | end Initialize; | |
2858 | ||
634a926b AC |
2859 | --------------------------------------------- |
2860 | -- Is_Attribute_And_Known_Value_Comparison -- | |
2861 | --------------------------------------------- | |
2862 | ||
2863 | function Is_Attribute_And_Known_Value_Comparison | |
2864 | (Op : Node_Id) return Boolean | |
2865 | is | |
2866 | Orig_Op : constant Node_Id := Original_Node (Op); | |
2867 | ||
2868 | begin | |
2869 | return | |
2870 | Nkind (Orig_Op) in N_Op_Compare | |
2871 | and then Nkind (Original_Node (Left_Opnd (Orig_Op))) = | |
2872 | N_Attribute_Reference | |
2873 | and then Compile_Time_Known_Value (Right_Opnd (Orig_Op)); | |
2874 | end Is_Attribute_And_Known_Value_Comparison; | |
2875 | ||
434632ce AC |
2876 | ------------------------------------ |
2877 | -- Never_Set_In_Source_Check_Spec -- | |
2878 | ------------------------------------ | |
2879 | ||
2880 | function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean is | |
2881 | begin | |
2882 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
2883 | return Never_Set_In_Source (E) | |
2884 | and then | |
2885 | Never_Set_In_Source (Spec_Entity (E)); | |
2886 | else | |
2887 | return Never_Set_In_Source (E); | |
2888 | end if; | |
2889 | end Never_Set_In_Source_Check_Spec; | |
2890 | ||
07fc65c4 GB |
2891 | ------------------------------------- |
2892 | -- Operand_Has_Warnings_Suppressed -- | |
2893 | ------------------------------------- | |
2894 | ||
2895 | function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean is | |
2896 | ||
2897 | function Check_For_Warnings (N : Node_Id) return Traverse_Result; | |
2898 | -- Function used to check one node to see if it is or was originally | |
2899 | -- a reference to an entity for which Warnings are off. If so, Abandon | |
2900 | -- is returned, otherwise OK_Orig is returned to continue the traversal | |
2901 | -- of the original expression. | |
2902 | ||
2903 | function Traverse is new Traverse_Func (Check_For_Warnings); | |
2904 | -- Function used to traverse tree looking for warnings | |
2905 | ||
2906 | ------------------------ | |
2907 | -- Check_For_Warnings -- | |
2908 | ------------------------ | |
2909 | ||
2910 | function Check_For_Warnings (N : Node_Id) return Traverse_Result is | |
2911 | R : constant Node_Id := Original_Node (N); | |
2912 | ||
2913 | begin | |
2914 | if Nkind (R) in N_Has_Entity | |
2915 | and then Present (Entity (R)) | |
9a18e785 | 2916 | and then Has_Warnings_Off (Entity (R)) |
07fc65c4 GB |
2917 | then |
2918 | return Abandon; | |
2919 | else | |
2920 | return OK_Orig; | |
2921 | end if; | |
2922 | end Check_For_Warnings; | |
2923 | ||
2924 | -- Start of processing for Operand_Has_Warnings_Suppressed | |
2925 | ||
2926 | begin | |
2927 | return Traverse (N) = Abandon; | |
2928 | ||
2929 | -- If any exception occurs, then something has gone wrong, and this is | |
2930 | -- only a minor aesthetic issue anyway, so just say we did not find what | |
2931 | -- we are looking for, rather than blow up. | |
2932 | ||
2933 | exception | |
2934 | when others => | |
2935 | return False; | |
2936 | end Operand_Has_Warnings_Suppressed; | |
2937 | ||
434632ce AC |
2938 | ----------------------------------------- |
2939 | -- Output_Non_Modified_In_Out_Warnings -- | |
2940 | ----------------------------------------- | |
2941 | ||
fb25a60d | 2942 | procedure Output_Non_Modified_In_Out_Warnings is |
434632ce AC |
2943 | |
2944 | function No_Warn_On_In_Out (E : Entity_Id) return Boolean; | |
2945 | -- Given a formal parameter entity E, determines if there is a reason to | |
2946 | -- suppress IN OUT warnings (not modified, could be IN) for formals of | |
2947 | -- the subprogram. We suppress these warnings if Warnings Off is set, or | |
2948 | -- if we have seen the address of the subprogram being taken, or if the | |
2949 | -- subprogram is used as a generic actual (in the latter cases the | |
2950 | -- context may force use of IN OUT, even if the parameter is not | |
2951 | -- modifies for this particular case. | |
2952 | ||
2953 | ----------------------- | |
2954 | -- No_Warn_On_In_Out -- | |
2955 | ----------------------- | |
2956 | ||
2957 | function No_Warn_On_In_Out (E : Entity_Id) return Boolean is | |
9a18e785 RD |
2958 | S : constant Entity_Id := Scope (E); |
2959 | SE : constant Entity_Id := Spec_Entity (E); | |
2960 | ||
434632ce | 2961 | begin |
9a18e785 RD |
2962 | -- Do not warn if address is taken, since funny business may be going |
2963 | -- on in treating the parameter indirectly as IN OUT. | |
2964 | ||
2965 | if Address_Taken (S) | |
2966 | or else (Present (SE) and then Address_Taken (Scope (SE))) | |
2967 | then | |
434632ce | 2968 | return True; |
9a18e785 RD |
2969 | |
2970 | -- Do not warn if used as a generic actual, since the generic may be | |
2971 | -- what is forcing the use of an "unnecessary" IN OUT. | |
2972 | ||
2973 | elsif Used_As_Generic_Actual (S) | |
2974 | or else (Present (SE) and then Used_As_Generic_Actual (Scope (SE))) | |
2975 | then | |
434632ce | 2976 | return True; |
9a18e785 RD |
2977 | |
2978 | -- Else test warnings off | |
2979 | ||
2980 | elsif Warnings_Off_Check_Spec (S) then | |
434632ce | 2981 | return True; |
9a18e785 RD |
2982 | |
2983 | -- All tests for suppressing warning failed | |
2984 | ||
434632ce AC |
2985 | else |
2986 | return False; | |
2987 | end if; | |
2988 | end No_Warn_On_In_Out; | |
2989 | ||
f3d57416 | 2990 | -- Start of processing for Output_Non_Modified_In_Out_Warnings |
434632ce AC |
2991 | |
2992 | begin | |
2993 | -- Loop through entities for which a warning may be needed | |
2994 | ||
2995 | for J in In_Out_Warnings.First .. In_Out_Warnings.Last loop | |
2996 | declare | |
2997 | E1 : constant Entity_Id := In_Out_Warnings.Table (J); | |
2998 | ||
2999 | begin | |
3000 | -- Suppress warning in specific cases (see details in comments for | |
9d77af56 | 3001 | -- No_Warn_On_In_Out), or if there is a pragma Unmodified. |
434632ce | 3002 | |
9a18e785 RD |
3003 | if Has_Pragma_Unmodified_Check_Spec (E1) |
3004 | or else No_Warn_On_In_Out (E1) | |
9d77af56 | 3005 | then |
434632ce AC |
3006 | null; |
3007 | ||
3008 | -- Here we generate the warning | |
3009 | ||
3010 | else | |
9d77af56 RD |
3011 | -- If -gnatwc is set then output message that we could be IN |
3012 | ||
9a18e785 RD |
3013 | if not Is_Trivial_Subprogram (Scope (E1)) then |
3014 | if Warn_On_Constant then | |
3015 | Error_Msg_N | |
685bc70f | 3016 | ("?u?formal parameter & is not modified!", E1); |
ed2233dc | 3017 | Error_Msg_N |
685bc70f | 3018 | ("\?u?mode could be IN instead of `IN OUT`!", E1); |
9d77af56 | 3019 | |
9a18e785 RD |
3020 | -- We do not generate warnings for IN OUT parameters |
3021 | -- unless we have at least -gnatwu. This is deliberately | |
3022 | -- inconsistent with the treatment of variables, but | |
3023 | -- otherwise we get too many unexpected warnings in | |
3024 | -- default mode. | |
9d77af56 | 3025 | |
9a18e785 | 3026 | elsif Check_Unreferenced then |
ed2233dc | 3027 | Error_Msg_N |
685bc70f | 3028 | ("?u?formal parameter& is read but " |
19d846a0 | 3029 | & "never assigned!", E1); |
9a18e785 | 3030 | end if; |
9d77af56 | 3031 | end if; |
434632ce AC |
3032 | |
3033 | -- Kill any other warnings on this entity, since this is the | |
3034 | -- one that should dominate any other unreferenced warning. | |
3035 | ||
3036 | Set_Warnings_Off (E1); | |
3037 | end if; | |
3038 | end; | |
3039 | end loop; | |
fb25a60d | 3040 | end Output_Non_Modified_In_Out_Warnings; |
434632ce | 3041 | |
3f1ede06 RD |
3042 | ---------------------------------------- |
3043 | -- Output_Obsolescent_Entity_Warnings -- | |
3044 | ---------------------------------------- | |
3045 | ||
3046 | procedure Output_Obsolescent_Entity_Warnings (N : Node_Id; E : Entity_Id) is | |
3047 | P : constant Node_Id := Parent (N); | |
3048 | S : Entity_Id; | |
3049 | ||
3050 | begin | |
3051 | S := Current_Scope; | |
3052 | ||
3053 | -- Do not output message if we are the scope of standard. This means | |
3054 | -- we have a reference from a context clause from when it is originally | |
3055 | -- processed, and that's too early to tell whether it is an obsolescent | |
3056 | -- unit doing the with'ing. In Sem_Ch10.Analyze_Compilation_Unit we make | |
3057 | -- sure that we have a later call when the scope is available. This test | |
3058 | -- also eliminates all messages for use clauses, which is fine (we do | |
3059 | -- not want messages for use clauses, since they are always redundant | |
3060 | -- with respect to the associated with clause). | |
3061 | ||
3062 | if S = Standard_Standard then | |
3063 | return; | |
3064 | end if; | |
3065 | ||
3066 | -- Do not output message if we are in scope of an obsolescent package | |
3067 | -- or subprogram. | |
3068 | ||
3069 | loop | |
3070 | if Is_Obsolescent (S) then | |
3071 | return; | |
3072 | end if; | |
3073 | ||
3074 | S := Scope (S); | |
3075 | exit when S = Standard_Standard; | |
3076 | end loop; | |
3077 | ||
3078 | -- Here we will output the message | |
3079 | ||
3080 | Error_Msg_Sloc := Sloc (E); | |
3081 | ||
3082 | -- Case of with clause | |
3083 | ||
3084 | if Nkind (P) = N_With_Clause then | |
3085 | if Ekind (E) = E_Package then | |
3086 | Error_Msg_NE | |
f8c59c05 | 3087 | ("?j?with of obsolescent package& declared#", N, E); |
3f1ede06 RD |
3088 | elsif Ekind (E) = E_Procedure then |
3089 | Error_Msg_NE | |
f8c59c05 | 3090 | ("?j?with of obsolescent procedure& declared#", N, E); |
3f1ede06 RD |
3091 | else |
3092 | Error_Msg_NE | |
685bc70f | 3093 | ("??with of obsolescent function& declared#", N, E); |
3f1ede06 RD |
3094 | end if; |
3095 | ||
3096 | -- If we do not have a with clause, then ignore any reference to an | |
3097 | -- obsolescent package name. We only want to give the one warning of | |
3098 | -- withing the package, not one each time it is used to qualify. | |
3099 | ||
3100 | elsif Ekind (E) = E_Package then | |
3101 | return; | |
3102 | ||
3103 | -- Procedure call statement | |
3104 | ||
3105 | elsif Nkind (P) = N_Procedure_Call_Statement then | |
3106 | Error_Msg_NE | |
685bc70f | 3107 | ("??call to obsolescent procedure& declared#", N, E); |
3f1ede06 RD |
3108 | |
3109 | -- Function call | |
3110 | ||
3111 | elsif Nkind (P) = N_Function_Call then | |
3112 | Error_Msg_NE | |
685bc70f | 3113 | ("??call to obsolescent function& declared#", N, E); |
3f1ede06 RD |
3114 | |
3115 | -- Reference to obsolescent type | |
3116 | ||
3117 | elsif Is_Type (E) then | |
3118 | Error_Msg_NE | |
685bc70f | 3119 | ("??reference to obsolescent type& declared#", N, E); |
3f1ede06 RD |
3120 | |
3121 | -- Reference to obsolescent component | |
3122 | ||
8a95f4e8 | 3123 | elsif Ekind_In (E, E_Component, E_Discriminant) then |
3f1ede06 | 3124 | Error_Msg_NE |
685bc70f | 3125 | ("??reference to obsolescent component& declared#", N, E); |
3f1ede06 RD |
3126 | |
3127 | -- Reference to obsolescent variable | |
3128 | ||
3129 | elsif Ekind (E) = E_Variable then | |
3130 | Error_Msg_NE | |
685bc70f | 3131 | ("??reference to obsolescent variable& declared#", N, E); |
3f1ede06 RD |
3132 | |
3133 | -- Reference to obsolescent constant | |
3134 | ||
685bc70f | 3135 | elsif Ekind (E) = E_Constant or else Ekind (E) in Named_Kind then |
3f1ede06 | 3136 | Error_Msg_NE |
685bc70f | 3137 | ("??reference to obsolescent constant& declared#", N, E); |
3f1ede06 RD |
3138 | |
3139 | -- Reference to obsolescent enumeration literal | |
3140 | ||
3141 | elsif Ekind (E) = E_Enumeration_Literal then | |
3142 | Error_Msg_NE | |
685bc70f | 3143 | ("??reference to obsolescent enumeration literal& declared#", N, E); |
3f1ede06 RD |
3144 | |
3145 | -- Generic message for any other case we missed | |
3146 | ||
3147 | else | |
3148 | Error_Msg_NE | |
685bc70f | 3149 | ("??reference to obsolescent entity& declared#", N, E); |
3f1ede06 RD |
3150 | end if; |
3151 | ||
3152 | -- Output additional warning if present | |
3153 | ||
21d27997 RD |
3154 | for J in Obsolescent_Warnings.First .. Obsolescent_Warnings.Last loop |
3155 | if Obsolescent_Warnings.Table (J).Ent = E then | |
3156 | String_To_Name_Buffer (Obsolescent_Warnings.Table (J).Msg); | |
3157 | Error_Msg_Strlen := Name_Len; | |
3158 | Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); | |
685bc70f | 3159 | Error_Msg_N ("\\??~", N); |
21d27997 | 3160 | exit; |
3f1ede06 | 3161 | end if; |
21d27997 | 3162 | end loop; |
3f1ede06 RD |
3163 | end Output_Obsolescent_Entity_Warnings; |
3164 | ||
996ae0b0 RK |
3165 | ---------------------------------- |
3166 | -- Output_Unreferenced_Messages -- | |
3167 | ---------------------------------- | |
3168 | ||
3169 | procedure Output_Unreferenced_Messages is | |
996ae0b0 | 3170 | begin |
d50a26f2 | 3171 | for J in Unreferenced_Entities.First .. Unreferenced_Entities.Last loop |
434632ce AC |
3172 | Warn_On_Unreferenced_Entity (Unreferenced_Entities.Table (J)); |
3173 | end loop; | |
3174 | end Output_Unreferenced_Messages; | |
fbf5a39b | 3175 | |
9a18e785 RD |
3176 | ----------------------------------------- |
3177 | -- Output_Unused_Warnings_Off_Warnings -- | |
3178 | ----------------------------------------- | |
3179 | ||
3180 | procedure Output_Unused_Warnings_Off_Warnings is | |
3181 | begin | |
3182 | for J in Warnings_Off_Pragmas.First .. Warnings_Off_Pragmas.Last loop | |
3183 | declare | |
3184 | Wentry : Warnings_Off_Entry renames Warnings_Off_Pragmas.Table (J); | |
3185 | N : Node_Id renames Wentry.N; | |
3186 | E : Node_Id renames Wentry.E; | |
3187 | ||
3188 | begin | |
a90bd866 | 3189 | -- Turn off Warnings_Off, or we won't get the warning |
9a18e785 RD |
3190 | |
3191 | Set_Warnings_Off (E, False); | |
3192 | ||
3193 | -- Nothing to do if pragma was used to suppress a general warning | |
3194 | ||
3195 | if Warnings_Off_Used (E) then | |
3196 | null; | |
3197 | ||
3198 | -- If pragma was used both in unmodified and unreferenced contexts | |
3199 | -- then that's as good as the general case, no warning. | |
3200 | ||
3201 | elsif Warnings_Off_Used_Unmodified (E) | |
3202 | and | |
3203 | Warnings_Off_Used_Unreferenced (E) | |
3204 | then | |
3205 | null; | |
3206 | ||
3207 | -- Used only in context where Unmodified would have worked | |
3208 | ||
3209 | elsif Warnings_Off_Used_Unmodified (E) then | |
ed2233dc | 3210 | Error_Msg_NE |
685bc70f | 3211 | ("?W?could use Unmodified instead of " |
9a18e785 RD |
3212 | & "Warnings Off for &", Pragma_Identifier (N), E); |
3213 | ||
3214 | -- Used only in context where Unreferenced would have worked | |
3215 | ||
3216 | elsif Warnings_Off_Used_Unreferenced (E) then | |
ed2233dc | 3217 | Error_Msg_NE |
685bc70f | 3218 | ("?W?could use Unreferenced instead of " |
9a18e785 RD |
3219 | & "Warnings Off for &", Pragma_Identifier (N), E); |
3220 | ||
3221 | -- Not used at all | |
3222 | ||
3223 | else | |
ed2233dc | 3224 | Error_Msg_NE |
685bc70f | 3225 | ("?W?pragma Warnings Off for & unused, " |
9a18e785 RD |
3226 | & "could be omitted", N, E); |
3227 | end if; | |
3228 | end; | |
3229 | end loop; | |
3230 | end Output_Unused_Warnings_Off_Warnings; | |
3231 | ||
434632ce AC |
3232 | --------------------------- |
3233 | -- Referenced_Check_Spec -- | |
3234 | --------------------------- | |
fbf5a39b | 3235 | |
434632ce AC |
3236 | function Referenced_Check_Spec (E : Entity_Id) return Boolean is |
3237 | begin | |
3238 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
3239 | return Referenced (E) or else Referenced (Spec_Entity (E)); | |
3240 | else | |
3241 | return Referenced (E); | |
3242 | end if; | |
3243 | end Referenced_Check_Spec; | |
996ae0b0 | 3244 | |
434632ce AC |
3245 | ---------------------------------- |
3246 | -- Referenced_As_LHS_Check_Spec -- | |
3247 | ---------------------------------- | |
996ae0b0 | 3248 | |
434632ce AC |
3249 | function Referenced_As_LHS_Check_Spec (E : Entity_Id) return Boolean is |
3250 | begin | |
3251 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
3252 | return Referenced_As_LHS (E) | |
3253 | or else Referenced_As_LHS (Spec_Entity (E)); | |
3254 | else | |
3255 | return Referenced_As_LHS (E); | |
3256 | end if; | |
3257 | end Referenced_As_LHS_Check_Spec; | |
996ae0b0 | 3258 | |
561b5849 RD |
3259 | -------------------------------------------- |
3260 | -- Referenced_As_Out_Parameter_Check_Spec -- | |
3261 | -------------------------------------------- | |
3262 | ||
3263 | function Referenced_As_Out_Parameter_Check_Spec | |
3264 | (E : Entity_Id) return Boolean | |
3265 | is | |
3266 | begin | |
3267 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
3268 | return Referenced_As_Out_Parameter (E) | |
3269 | or else Referenced_As_Out_Parameter (Spec_Entity (E)); | |
3270 | else | |
3271 | return Referenced_As_Out_Parameter (E); | |
3272 | end if; | |
3273 | end Referenced_As_Out_Parameter_Check_Spec; | |
3274 | ||
634a926b AC |
3275 | -------------------------------------- |
3276 | -- Warn_On_Constant_Valid_Condition -- | |
3277 | -------------------------------------- | |
3278 | ||
3279 | procedure Warn_On_Constant_Valid_Condition (Op : Node_Id) is | |
62807842 AC |
3280 | Left : constant Node_Id := Left_Opnd (Op); |
3281 | Right : constant Node_Id := Right_Opnd (Op); | |
3282 | ||
634a926b AC |
3283 | True_Result : Boolean; |
3284 | False_Result : Boolean; | |
3285 | ||
3286 | begin | |
3287 | -- Determine the potential outcome of the comparison assuming that the | |
57f6e00c | 3288 | -- scalar operands are valid. |
634a926b AC |
3289 | |
3290 | if Constant_Condition_Warnings | |
3291 | and then Comes_From_Source (Original_Node (Op)) | |
57f6e00c AC |
3292 | and then Is_Scalar_Type (Etype (Left)) |
3293 | and then Is_Scalar_Type (Etype (Right)) | |
62807842 AC |
3294 | |
3295 | -- Do not consider instances because the check was already performed | |
3296 | -- in the generic. | |
3297 | ||
634a926b | 3298 | and then not In_Instance |
62807842 AC |
3299 | |
3300 | -- Do not consider comparisons between two static expressions such as | |
3301 | -- constants or literals because those values cannot be invalidated. | |
3302 | ||
3303 | and then not (Is_Static_Expression (Left) | |
3304 | and then Is_Static_Expression (Right)) | |
3305 | ||
3306 | -- Do not consider comparison between an attribute reference and a | |
3307 | -- compile-time known value since this is most likely a conditional | |
3308 | -- compilation. | |
3309 | ||
634a926b | 3310 | and then not Is_Attribute_And_Known_Value_Comparison (Op) |
62807842 AC |
3311 | |
3312 | -- Do not consider internal files to allow for various assertions and | |
3313 | -- safeguards within our runtime. | |
3314 | ||
8ab31c0c | 3315 | and then not In_Internal_Unit (Op) |
634a926b AC |
3316 | then |
3317 | Test_Comparison | |
3318 | (Op => Op, | |
3319 | Assume_Valid => True, | |
3320 | True_Result => True_Result, | |
3321 | False_Result => False_Result); | |
3322 | ||
3323 | -- Warn on a possible evaluation to False / True in the presence of | |
3324 | -- invalid values. | |
3325 | ||
3326 | if True_Result then | |
3327 | Error_Msg_N | |
3328 | ("condition can only be False if invalid values present??", Op); | |
3329 | ||
3330 | elsif False_Result then | |
3331 | Error_Msg_N | |
3332 | ("condition can only be True if invalid values present??", Op); | |
3333 | end if; | |
3334 | end if; | |
3335 | end Warn_On_Constant_Valid_Condition; | |
3336 | ||
996ae0b0 RK |
3337 | ----------------------------- |
3338 | -- Warn_On_Known_Condition -- | |
3339 | ----------------------------- | |
3340 | ||
3341 | procedure Warn_On_Known_Condition (C : Node_Id) is | |
dcd5fd67 PMR |
3342 | Test_Result : Boolean := False; |
3343 | -- Force initialization to facilitate static analysis | |
892125cd AC |
3344 | |
3345 | function Is_Known_Branch return Boolean; | |
3346 | -- If the type of the condition is Boolean, the constant value of the | |
3347 | -- condition is a boolean literal. If the type is a derived boolean | |
3348 | -- type, the constant is wrapped in a type conversion of the derived | |
3349 | -- literal. If the value of the condition is not a literal, no warnings | |
3350 | -- can be produced. This function returns True if the result can be | |
3351 | -- determined, and Test_Result is set True/False accordingly. Otherwise | |
3352 | -- False is returned, and Test_Result is unchanged. | |
996ae0b0 | 3353 | |
3f1ede06 RD |
3354 | procedure Track (N : Node_Id; Loc : Node_Id); |
3355 | -- Adds continuation warning(s) pointing to reason (assignment or test) | |
3356 | -- for the operand of the conditional having a known value (or at least | |
3357 | -- enough is known about the value to issue the warning). N is the node | |
3358 | -- which is judged to have a known value. Loc is the warning location. | |
3359 | ||
892125cd AC |
3360 | --------------------- |
3361 | -- Is_Known_Branch -- | |
3362 | --------------------- | |
3363 | ||
3364 | function Is_Known_Branch return Boolean is | |
3365 | begin | |
3366 | if Etype (C) = Standard_Boolean | |
3367 | and then Is_Entity_Name (C) | |
3368 | and then | |
3369 | (Entity (C) = Standard_False or else Entity (C) = Standard_True) | |
3370 | then | |
3371 | Test_Result := Entity (C) = Standard_True; | |
3372 | return True; | |
3373 | ||
3374 | elsif Is_Boolean_Type (Etype (C)) | |
3375 | and then Nkind (C) = N_Unchecked_Type_Conversion | |
3376 | and then Is_Entity_Name (Expression (C)) | |
3377 | and then Ekind (Entity (Expression (C))) = E_Enumeration_Literal | |
3378 | then | |
3379 | Test_Result := | |
3380 | Chars (Entity (Expression (C))) = Chars (Standard_True); | |
3381 | return True; | |
3382 | ||
3383 | else | |
3384 | return False; | |
3385 | end if; | |
3386 | end Is_Known_Branch; | |
3387 | ||
3f1ede06 RD |
3388 | ----------- |
3389 | -- Track -- | |
3390 | ----------- | |
3391 | ||
3392 | procedure Track (N : Node_Id; Loc : Node_Id) is | |
3393 | Nod : constant Node_Id := Original_Node (N); | |
3394 | ||
3395 | begin | |
3396 | if Nkind (Nod) in N_Op_Compare then | |
3397 | Track (Left_Opnd (Nod), Loc); | |
3398 | Track (Right_Opnd (Nod), Loc); | |
3399 | ||
c230ed0b | 3400 | elsif Is_Entity_Name (Nod) and then Is_Object (Entity (Nod)) then |
3f1ede06 RD |
3401 | declare |
3402 | CV : constant Node_Id := Current_Value (Entity (Nod)); | |
3403 | ||
3404 | begin | |
3405 | if Present (CV) then | |
3406 | Error_Msg_Sloc := Sloc (CV); | |
3407 | ||
3408 | if Nkind (CV) not in N_Subexpr then | |
b785e0b8 | 3409 | Error_Msg_N ("\\??(see test #)", Loc); |
3f1ede06 RD |
3410 | |
3411 | elsif Nkind (Parent (CV)) = | |
3412 | N_Case_Statement_Alternative | |
3413 | then | |
b785e0b8 | 3414 | Error_Msg_N ("\\??(see case alternative #)", Loc); |
3f1ede06 RD |
3415 | |
3416 | else | |
b785e0b8 | 3417 | Error_Msg_N ("\\??(see assignment #)", Loc); |
3f1ede06 RD |
3418 | end if; |
3419 | end if; | |
3420 | end; | |
3421 | end if; | |
3422 | end Track; | |
3423 | ||
634a926b AC |
3424 | -- Local variables |
3425 | ||
3426 | Orig : constant Node_Id := Original_Node (C); | |
3427 | P : Node_Id; | |
3428 | ||
3f1ede06 RD |
3429 | -- Start of processing for Warn_On_Known_Condition |
3430 | ||
996ae0b0 | 3431 | begin |
6f12117a RD |
3432 | -- Adjust SCO condition if from source |
3433 | ||
00838d9a AC |
3434 | if Generate_SCO |
3435 | and then Comes_From_Source (Orig) | |
892125cd | 3436 | and then Is_Known_Branch |
00838d9a | 3437 | then |
6f12117a | 3438 | declare |
6f12117a RD |
3439 | Atrue : Boolean; |
3440 | ||
3441 | begin | |
892125cd | 3442 | Atrue := Test_Result; |
6f12117a | 3443 | |
51bf9bdf | 3444 | if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then |
6f12117a RD |
3445 | Atrue := not Atrue; |
3446 | end if; | |
3447 | ||
25adc5fb | 3448 | Set_SCO_Condition (Orig, Atrue); |
6f12117a RD |
3449 | end; |
3450 | end if; | |
3451 | ||
3a336262 AC |
3452 | -- Argument replacement in an inlined body can make conditions static. |
3453 | -- Do not emit warnings in this case. | |
fbf5a39b AC |
3454 | |
3455 | if In_Inlined_Body then | |
3456 | return; | |
3457 | end if; | |
3458 | ||
996ae0b0 | 3459 | if Constant_Condition_Warnings |
892125cd | 3460 | and then Is_Known_Branch |
ef7c5fa9 | 3461 | and then Comes_From_Source (Orig) |
996ae0b0 RK |
3462 | and then not In_Instance |
3463 | then | |
ef7c5fa9 AC |
3464 | -- Don't warn if comparison of result of attribute against a constant |
3465 | -- value, since this is likely legitimate conditional compilation. | |
3466 | ||
634a926b | 3467 | if Is_Attribute_And_Known_Value_Comparison (C) then |
ef7c5fa9 AC |
3468 | return; |
3469 | end if; | |
3470 | ||
996ae0b0 RK |
3471 | -- See if this is in a statement or a declaration |
3472 | ||
3473 | P := Parent (C); | |
3474 | loop | |
3475 | -- If tree is not attached, do not issue warning (this is very | |
f24ea912 | 3476 | -- peculiar, and probably arises from some other error condition). |
996ae0b0 RK |
3477 | |
3478 | if No (P) then | |
3479 | return; | |
3480 | ||
3481 | -- If we are in a declaration, then no warning, since in practice | |
3482 | -- conditionals in declarations are used for intended tests which | |
3483 | -- may be known at compile time, e.g. things like | |
3484 | ||
3485 | -- x : constant Integer := 2 + (Word'Size = 32); | |
3486 | ||
3487 | -- And a warning is annoying in such cases | |
3488 | ||
3489 | elsif Nkind (P) in N_Declaration | |
3490 | or else | |
3491 | Nkind (P) in N_Later_Decl_Item | |
3492 | then | |
3493 | return; | |
3494 | ||
21d27997 RD |
3495 | -- Don't warn in assert or check pragma, since presumably tests in |
3496 | -- such a context are very definitely intended, and might well be | |
996ae0b0 RK |
3497 | -- known at compile time. Note that we have to test the original |
3498 | -- node, since assert pragmas get rewritten at analysis time. | |
3499 | ||
3500 | elsif Nkind (Original_Node (P)) = N_Pragma | |
6e759c2a BD |
3501 | and then Nam_In (Pragma_Name_Unmapped (Original_Node (P)), |
3502 | Name_Assert, Name_Check) | |
996ae0b0 RK |
3503 | then |
3504 | return; | |
3505 | end if; | |
3506 | ||
3507 | exit when Is_Statement (P); | |
3508 | P := Parent (P); | |
3509 | end loop; | |
3510 | ||
07fc65c4 | 3511 | -- Here we issue the warning unless some sub-operand has warnings |
bd6f5b5c ES |
3512 | -- set off, in which case we suppress the warning for the node. If |
3513 | -- the original expression is an inequality, it has been expanded | |
3514 | -- into a negation, and the value of the original expression is the | |
3515 | -- negation of the equality. If the expression is an entity that | |
3516 | -- appears within a negation, it is clearer to flag the negation | |
3517 | -- itself, and report on its constant value. | |
07fc65c4 GB |
3518 | |
3519 | if not Operand_Has_Warnings_Suppressed (C) then | |
bd6f5b5c | 3520 | declare |
892125cd | 3521 | True_Branch : Boolean := Test_Result; |
bd6f5b5c ES |
3522 | Cond : Node_Id := C; |
3523 | ||
3524 | begin | |
2c6336be AC |
3525 | if Present (Parent (C)) |
3526 | and then Nkind (Parent (C)) = N_Op_Not | |
bd6f5b5c ES |
3527 | then |
3528 | True_Branch := not True_Branch; | |
2c6336be | 3529 | Cond := Parent (C); |
bd6f5b5c ES |
3530 | end if; |
3531 | ||
2c6336be AC |
3532 | -- Condition always True |
3533 | ||
bd6f5b5c | 3534 | if True_Branch then |
8d7559ff ES |
3535 | if Is_Entity_Name (Original_Node (C)) |
3536 | and then Nkind (Cond) /= N_Op_Not | |
3537 | then | |
ed2233dc | 3538 | Error_Msg_NE |
1db700c3 | 3539 | ("object & is always True at this point?c?", |
2c6336be | 3540 | Cond, Original_Node (C)); |
3f1ede06 RD |
3541 | Track (Original_Node (C), Cond); |
3542 | ||
8d7559ff | 3543 | else |
685bc70f | 3544 | Error_Msg_N ("condition is always True?c?", Cond); |
3f1ede06 | 3545 | Track (Cond, Cond); |
8d7559ff | 3546 | end if; |
3f1ede06 | 3547 | |
2c6336be AC |
3548 | -- Condition always False |
3549 | ||
bd6f5b5c | 3550 | else |
2c6336be AC |
3551 | if Is_Entity_Name (Original_Node (C)) |
3552 | and then Nkind (Cond) /= N_Op_Not | |
3553 | then | |
3554 | Error_Msg_NE | |
1db700c3 | 3555 | ("object & is always False at this point?c?", |
2c6336be AC |
3556 | Cond, Original_Node (C)); |
3557 | Track (Original_Node (C), Cond); | |
3558 | ||
3559 | else | |
3560 | Error_Msg_N ("condition is always False?c?", Cond); | |
3561 | Track (Cond, Cond); | |
3562 | end if; | |
bd6f5b5c ES |
3563 | end if; |
3564 | end; | |
996ae0b0 RK |
3565 | end if; |
3566 | end if; | |
3567 | end Warn_On_Known_Condition; | |
3568 | ||
561b5849 RD |
3569 | --------------------------------------- |
3570 | -- Warn_On_Modified_As_Out_Parameter -- | |
3571 | --------------------------------------- | |
3572 | ||
3573 | function Warn_On_Modified_As_Out_Parameter (E : Entity_Id) return Boolean is | |
3574 | begin | |
3575 | return | |
3576 | (Warn_On_Modified_Unread and then Is_Only_Out_Parameter (E)) | |
ae05cdd6 | 3577 | or else Warn_On_All_Unread_Out_Parameters; |
561b5849 RD |
3578 | end Warn_On_Modified_As_Out_Parameter; |
3579 | ||
76b84bf0 AC |
3580 | --------------------------------- |
3581 | -- Warn_On_Overlapping_Actuals -- | |
3582 | --------------------------------- | |
3583 | ||
3584 | procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is | |
6f5c2c4b | 3585 | function Is_Covered_Formal (Formal : Node_Id) return Boolean; |
ae05cdd6 | 3586 | -- Return True if Formal is covered by the rule |
6f5c2c4b | 3587 | |
3e3bc136 AC |
3588 | function Refer_Same_Object |
3589 | (Act1 : Node_Id; | |
3590 | Act2 : Node_Id) return Boolean; | |
6f5c2c4b AC |
3591 | -- Two names are known to refer to the same object if the two names |
3592 | -- are known to denote the same object; or one of the names is a | |
3593 | -- selected_component, indexed_component, or slice and its prefix is | |
3594 | -- known to refer to the same object as the other name; or one of the | |
3595 | -- two names statically denotes a renaming declaration whose renamed | |
3596 | -- object_name is known to refer to the same object as the other name | |
3597 | -- (RM 6.4.1(6.11/3)) | |
3598 | ||
6f5c2c4b AC |
3599 | ----------------------- |
3600 | -- Is_Covered_Formal -- | |
3601 | ----------------------- | |
3602 | ||
3603 | function Is_Covered_Formal (Formal : Node_Id) return Boolean is | |
3604 | begin | |
8190087e | 3605 | return |
ae05cdd6 | 3606 | Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) |
8190087e | 3607 | and then (Is_Elementary_Type (Etype (Formal)) |
ae05cdd6 RD |
3608 | or else Is_Record_Type (Etype (Formal)) |
3609 | or else Is_Array_Type (Etype (Formal))); | |
6f5c2c4b AC |
3610 | end Is_Covered_Formal; |
3611 | ||
3e3bc136 AC |
3612 | ----------------------- |
3613 | -- Refer_Same_Object -- | |
3614 | ----------------------- | |
3615 | ||
3616 | function Refer_Same_Object | |
3617 | (Act1 : Node_Id; | |
3618 | Act2 : Node_Id) return Boolean | |
3619 | is | |
3620 | begin | |
3621 | return | |
3622 | Denotes_Same_Object (Act1, Act2) | |
3623 | or else Denotes_Same_Prefix (Act1, Act2); | |
3624 | end Refer_Same_Object; | |
3625 | ||
3626 | -- Local variables | |
3627 | ||
c99ab5f9 HK |
3628 | Act1 : Node_Id; |
3629 | Act2 : Node_Id; | |
3630 | Form1 : Entity_Id; | |
3631 | Form2 : Entity_Id; | |
3632 | Warn_Only : Boolean; | |
3633 | -- GNAT warns on overlapping in-out parameters even when there are no | |
3634 | -- two in-out parameters of an elementary type, as stated in | |
3c0ae05d | 3635 | -- RM 6.5.1 (17/2). |
3e3bc136 AC |
3636 | |
3637 | -- Start of processing for Warn_On_Overlapping_Actuals | |
3638 | ||
76b84bf0 | 3639 | begin |
3e3bc136 | 3640 | |
6f5c2c4b | 3641 | if Ada_Version < Ada_2012 and then not Warn_On_Overlap then |
76b84bf0 AC |
3642 | return; |
3643 | end if; | |
3644 | ||
c99ab5f9 HK |
3645 | -- The call is illegal only if there are at least two in-out parameters |
3646 | -- of the same elementary type. | |
3c0ae05d AC |
3647 | |
3648 | Warn_Only := True; | |
3649 | Form1 := First_Formal (Subp); | |
3650 | while Present (Form1) loop | |
3651 | Form2 := Next_Formal (Form1); | |
3652 | while Present (Form2) loop | |
3653 | if Is_Elementary_Type (Etype (Form1)) | |
3654 | and then Is_Elementary_Type (Etype (Form2)) | |
3655 | and then Ekind (Form1) /= E_In_Parameter | |
3656 | and then Ekind (Form2) /= E_In_Parameter | |
3657 | then | |
3658 | Warn_Only := False; | |
3659 | exit; | |
3660 | end if; | |
3661 | ||
3662 | Next_Formal (Form2); | |
3663 | end loop; | |
3664 | ||
3665 | Next_Formal (Form1); | |
3666 | end loop; | |
3667 | ||
76b84bf0 AC |
3668 | -- Exclude calls rewritten as enumeration literals |
3669 | ||
6f5c2c4b AC |
3670 | if Nkind (N) not in N_Subprogram_Call |
3671 | and then Nkind (N) /= N_Entry_Call_Statement | |
3672 | then | |
76b84bf0 AC |
3673 | return; |
3674 | end if; | |
3675 | ||
6f5c2c4b AC |
3676 | -- If a call C has two or more parameters of mode in out or out that are |
3677 | -- of an elementary type, then the call is legal only if for each name | |
3678 | -- N that is passed as a parameter of mode in out or out to the call C, | |
3679 | -- there is no other name among the other parameters of mode in out or | |
3680 | -- out to C that is known to denote the same object (RM 6.4.1(6.15/3)) | |
76b84bf0 | 3681 | |
ae05cdd6 RD |
3682 | -- If appropriate warning switch is set, we also report warnings on |
3683 | -- overlapping parameters that are record types or array types. | |
76b84bf0 AC |
3684 | |
3685 | Form1 := First_Formal (Subp); | |
3686 | Act1 := First_Actual (N); | |
76b84bf0 | 3687 | while Present (Form1) and then Present (Act1) loop |
6f5c2c4b | 3688 | if Is_Covered_Formal (Form1) then |
76b84bf0 AC |
3689 | Form2 := First_Formal (Subp); |
3690 | Act2 := First_Actual (N); | |
76b84bf0 AC |
3691 | while Present (Form2) and then Present (Act2) loop |
3692 | if Form1 /= Form2 | |
6f5c2c4b AC |
3693 | and then Is_Covered_Formal (Form2) |
3694 | and then Refer_Same_Object (Act1, Act2) | |
76b84bf0 | 3695 | then |
6f5c2c4b | 3696 | -- Guard against previous errors |
76b84bf0 AC |
3697 | |
3698 | if Error_Posted (N) | |
3699 | or else No (Etype (Act1)) | |
3700 | or else No (Etype (Act2)) | |
3701 | then | |
3702 | null; | |
3703 | ||
6f5c2c4b AC |
3704 | -- If the actual is a function call in prefix notation, |
3705 | -- there is no real overlap. | |
76b84bf0 AC |
3706 | |
3707 | elsif Nkind (Act2) = N_Function_Call then | |
3708 | null; | |
3709 | ||
ae05cdd6 | 3710 | -- If type is not by-copy, assume that aliasing is intended |
110fcc77 | 3711 | |
1e194575 | 3712 | elsif |
6f5c2c4b AC |
3713 | Present (Underlying_Type (Etype (Form1))) |
3714 | and then | |
3715 | (Is_By_Reference_Type (Underlying_Type (Etype (Form1))) | |
c230ed0b AC |
3716 | or else |
3717 | Convention (Underlying_Type (Etype (Form1))) = | |
3718 | Convention_Ada_Pass_By_Reference) | |
76b84bf0 AC |
3719 | then |
3720 | null; | |
27cdc66a | 3721 | |
8190087e | 3722 | -- Under Ada 2012 we only report warnings on overlapping |
ae05cdd6 | 3723 | -- arrays and record types if switch is set. |
8190087e AC |
3724 | |
3725 | elsif Ada_Version >= Ada_2012 | |
ae05cdd6 RD |
3726 | and then not Is_Elementary_Type (Etype (Form1)) |
3727 | and then not Warn_On_Overlap | |
8190087e AC |
3728 | then |
3729 | null; | |
3730 | ||
0247964d | 3731 | -- Here we may need to issue overlap message |
6f5c2c4b | 3732 | |
76b84bf0 | 3733 | else |
8190087e | 3734 | Error_Msg_Warn := |
0247964d AC |
3735 | |
3736 | -- Overlap checking is an error only in Ada 2012. For | |
3737 | -- earlier versions of Ada, this is a warning. | |
3738 | ||
8190087e | 3739 | Ada_Version < Ada_2012 |
0247964d AC |
3740 | |
3741 | -- Overlap is only illegal in Ada 2012 in the case of | |
3742 | -- elementary types (passed by copy). For other types, | |
3743 | -- we always have a warning in all Ada versions. | |
3744 | ||
3745 | or else not Is_Elementary_Type (Etype (Form1)) | |
3746 | ||
c99ab5f9 HK |
3747 | -- debug flag -gnatd.E changes the error to a warning |
3748 | -- even in Ada 2012 mode. | |
0247964d | 3749 | |
3c0ae05d | 3750 | or else Error_To_Warning |
3c0ae05d | 3751 | or else Warn_Only; |
6f5c2c4b | 3752 | |
76b84bf0 AC |
3753 | declare |
3754 | Act : Node_Id; | |
3755 | Form : Entity_Id; | |
27cdc66a | 3756 | |
76b84bf0 | 3757 | begin |
27cdc66a RD |
3758 | -- Find matching actual |
3759 | ||
76b84bf0 AC |
3760 | Act := First_Actual (N); |
3761 | Form := First_Formal (Subp); | |
3762 | while Act /= Act2 loop | |
3763 | Next_Formal (Form); | |
3764 | Next_Actual (Act); | |
3765 | end loop; | |
3766 | ||
1e194575 AC |
3767 | if Is_Elementary_Type (Etype (Act1)) |
3768 | and then Ekind (Form2) = E_In_Parameter | |
3769 | then | |
60370fb1 | 3770 | null; -- No real aliasing |
1e194575 AC |
3771 | |
3772 | elsif Is_Elementary_Type (Etype (Act2)) | |
3773 | and then Ekind (Form2) = E_In_Parameter | |
3774 | then | |
60370fb1 | 3775 | null; -- Ditto |
1e194575 | 3776 | |
110fcc77 AC |
3777 | -- If the call was written in prefix notation, and |
3778 | -- thus its prefix before rewriting was a selected | |
3779 | -- component, count only visible actuals in the call. | |
27cdc66a | 3780 | |
1e194575 | 3781 | elsif Is_Entity_Name (First_Actual (N)) |
76b84bf0 | 3782 | and then Nkind (Original_Node (N)) = Nkind (N) |
65a07a30 RD |
3783 | and then Nkind (Name (Original_Node (N))) = |
3784 | N_Selected_Component | |
76b84bf0 AC |
3785 | and then |
3786 | Is_Entity_Name (Prefix (Name (Original_Node (N)))) | |
3787 | and then | |
3788 | Entity (Prefix (Name (Original_Node (N)))) = | |
3789 | Entity (First_Actual (N)) | |
3790 | then | |
3791 | if Act1 = First_Actual (N) then | |
3792 | Error_Msg_FE | |
b785e0b8 | 3793 | ("<<`IN OUT` prefix overlaps with " |
0247964d | 3794 | & "actual for&", Act1, Form); |
e4982b64 | 3795 | |
76b84bf0 | 3796 | else |
ae05cdd6 | 3797 | -- For greater clarity, give name of formal |
e4982b64 AC |
3798 | |
3799 | Error_Msg_Node_2 := Form; | |
76b84bf0 | 3800 | Error_Msg_FE |
b785e0b8 | 3801 | ("<<writable actual for & overlaps with " |
0247964d | 3802 | & "actual for&", Act1, Form); |
76b84bf0 AC |
3803 | end if; |
3804 | ||
3805 | else | |
0247964d AC |
3806 | -- For greater clarity, give name of formal |
3807 | ||
f2acf80c | 3808 | Error_Msg_Node_2 := Form; |
0247964d AC |
3809 | |
3810 | -- This is one of the messages | |
3811 | ||
76b84bf0 | 3812 | Error_Msg_FE |
b785e0b8 | 3813 | ("<<writable actual for & overlaps with " |
0247964d | 3814 | & "actual for&", Act1, Form1); |
76b84bf0 AC |
3815 | end if; |
3816 | end; | |
3817 | end if; | |
27cdc66a | 3818 | |
76b84bf0 AC |
3819 | return; |
3820 | end if; | |
3821 | ||
3822 | Next_Formal (Form2); | |
3823 | Next_Actual (Act2); | |
3824 | end loop; | |
3825 | end if; | |
3826 | ||
3827 | Next_Formal (Form1); | |
3828 | Next_Actual (Act1); | |
3829 | end loop; | |
3830 | end Warn_On_Overlapping_Actuals; | |
3831 | ||
3f1ede06 RD |
3832 | ------------------------------ |
3833 | -- Warn_On_Suspicious_Index -- | |
3834 | ------------------------------ | |
3835 | ||
3836 | procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id) is | |
3837 | ||
3838 | Low_Bound : Uint; | |
3839 | -- Set to lower bound for a suspicious type | |
3840 | ||
3841 | Ent : Entity_Id; | |
3842 | -- Entity for array reference | |
3843 | ||
3844 | Typ : Entity_Id; | |
3845 | -- Array type | |
3846 | ||
3847 | function Is_Suspicious_Type (Typ : Entity_Id) return Boolean; | |
3848 | -- Tests to see if Typ is a type for which we may have a suspicious | |
3849 | -- index, namely an unconstrained array type, whose lower bound is | |
3850 | -- either zero or one. If so, True is returned, and Low_Bound is set | |
3851 | -- to this lower bound. If not, False is returned, and Low_Bound is | |
3852 | -- undefined on return. | |
3853 | -- | |
f3d57416 | 3854 | -- For now, we limit this to standard string types, so any other |
3f1ede06 RD |
3855 | -- unconstrained types return False. We may change our minds on this |
3856 | -- later on, but strings seem the most important case. | |
3857 | ||
3858 | procedure Test_Suspicious_Index; | |
3859 | -- Test if index is of suspicious type and if so, generate warning | |
3860 | ||
3861 | ------------------------ | |
3862 | -- Is_Suspicious_Type -- | |
3863 | ------------------------ | |
3864 | ||
3865 | function Is_Suspicious_Type (Typ : Entity_Id) return Boolean is | |
3866 | LB : Node_Id; | |
3867 | ||
3868 | begin | |
3869 | if Is_Array_Type (Typ) | |
3870 | and then not Is_Constrained (Typ) | |
3871 | and then Number_Dimensions (Typ) = 1 | |
bc3c2eca | 3872 | and then Is_Standard_String_Type (Typ) |
9a18e785 | 3873 | and then not Has_Warnings_Off (Typ) |
3f1ede06 RD |
3874 | then |
3875 | LB := Type_Low_Bound (Etype (First_Index (Typ))); | |
3876 | ||
3877 | if Compile_Time_Known_Value (LB) then | |
3878 | Low_Bound := Expr_Value (LB); | |
3879 | return Low_Bound = Uint_0 or else Low_Bound = Uint_1; | |
3880 | end if; | |
3881 | end if; | |
3882 | ||
3883 | return False; | |
3884 | end Is_Suspicious_Type; | |
3885 | ||
3886 | --------------------------- | |
3887 | -- Test_Suspicious_Index -- | |
3888 | --------------------------- | |
3889 | ||
3890 | procedure Test_Suspicious_Index is | |
3891 | ||
3892 | function Length_Reference (N : Node_Id) return Boolean; | |
3893 | -- Check if node N is of the form Name'Length | |
3894 | ||
3895 | procedure Warn1; | |
3896 | -- Generate first warning line | |
3897 | ||
6877306f AC |
3898 | procedure Warn_On_Index_Below_Lower_Bound; |
3899 | -- Generate a warning on indexing the array with a literal value | |
3900 | -- below the lower bound of the index type. | |
3901 | ||
3902 | procedure Warn_On_Literal_Index; | |
3903 | -- Generate a warning on indexing the array with a literal value | |
3904 | ||
3f1ede06 RD |
3905 | ---------------------- |
3906 | -- Length_Reference -- | |
3907 | ---------------------- | |
3908 | ||
3909 | function Length_Reference (N : Node_Id) return Boolean is | |
3910 | R : constant Node_Id := Original_Node (N); | |
3911 | begin | |
3912 | return | |
3913 | Nkind (R) = N_Attribute_Reference | |
c230ed0b AC |
3914 | and then Attribute_Name (R) = Name_Length |
3915 | and then Is_Entity_Name (Prefix (R)) | |
3916 | and then Entity (Prefix (R)) = Ent; | |
3f1ede06 RD |
3917 | end Length_Reference; |
3918 | ||
3919 | ----------- | |
3920 | -- Warn1 -- | |
3921 | ----------- | |
3922 | ||
3923 | procedure Warn1 is | |
3924 | begin | |
3925 | Error_Msg_Uint_1 := Low_Bound; | |
19d846a0 | 3926 | Error_Msg_FE -- CODEFIX |
685bc70f | 3927 | ("?w?index for& may assume lower bound of^", X, Ent); |
3f1ede06 RD |
3928 | end Warn1; |
3929 | ||
6877306f AC |
3930 | ------------------------------------- |
3931 | -- Warn_On_Index_Below_Lower_Bound -- | |
3932 | ------------------------------------- | |
3f1ede06 | 3933 | |
6877306f AC |
3934 | procedure Warn_On_Index_Below_Lower_Bound is |
3935 | begin | |
3936 | if Is_Standard_String_Type (Typ) then | |
3937 | Discard_Node | |
3938 | (Compile_Time_Constraint_Error | |
3939 | (N => X, | |
3940 | Msg => "?w?string index should be positive")); | |
3941 | else | |
3942 | Discard_Node | |
3943 | (Compile_Time_Constraint_Error | |
3944 | (N => X, | |
3945 | Msg => "?w?index out of the allowed range")); | |
3946 | end if; | |
3947 | end Warn_On_Index_Below_Lower_Bound; | |
3f1ede06 | 3948 | |
6877306f AC |
3949 | --------------------------- |
3950 | -- Warn_On_Literal_Index -- | |
3951 | --------------------------- | |
3f1ede06 | 3952 | |
6877306f AC |
3953 | procedure Warn_On_Literal_Index is |
3954 | begin | |
3f1ede06 RD |
3955 | Warn1; |
3956 | ||
3957 | -- Case where original form of subscript is an integer literal | |
3958 | ||
3959 | if Nkind (Original_Node (X)) = N_Integer_Literal then | |
3960 | if Intval (X) = Low_Bound then | |
19d846a0 | 3961 | Error_Msg_FE -- CODEFIX |
685bc70f | 3962 | ("\?w?suggested replacement: `&''First`", X, Ent); |
3f1ede06 RD |
3963 | else |
3964 | Error_Msg_Uint_1 := Intval (X) - Low_Bound; | |
19d846a0 | 3965 | Error_Msg_FE -- CODEFIX |
685bc70f | 3966 | ("\?w?suggested replacement: `&''First + ^`", X, Ent); |
3f1ede06 RD |
3967 | |
3968 | end if; | |
3969 | ||
3970 | -- Case where original form of subscript is more complex | |
3971 | ||
3972 | else | |
3973 | -- Build string X'First - 1 + expression where the expression | |
3974 | -- is the original subscript. If the expression starts with "1 | |
3975 | -- + ", then the "- 1 + 1" is elided. | |
3976 | ||
3977 | Error_Msg_String (1 .. 13) := "'First - 1 + "; | |
3978 | Error_Msg_Strlen := 13; | |
3979 | ||
3980 | declare | |
3981 | Sref : Source_Ptr := Sloc (First_Node (Original_Node (X))); | |
3982 | Tref : constant Source_Buffer_Ptr := | |
3983 | Source_Text (Get_Source_File_Index (Sref)); | |
3984 | -- Tref (Sref) is used to scan the subscript | |
3985 | ||
3986 | Pctr : Natural; | |
f3d57416 | 3987 | -- Parentheses counter when scanning subscript |
3f1ede06 RD |
3988 | |
3989 | begin | |
3990 | -- Tref (Sref) points to start of subscript | |
3991 | ||
3992 | -- Elide - 1 if subscript starts with 1 + | |
3993 | ||
3994 | if Tref (Sref .. Sref + 2) = "1 +" then | |
3995 | Error_Msg_Strlen := Error_Msg_Strlen - 6; | |
3996 | Sref := Sref + 2; | |
3997 | ||
3998 | elsif Tref (Sref .. Sref + 1) = "1+" then | |
3999 | Error_Msg_Strlen := Error_Msg_Strlen - 6; | |
4000 | Sref := Sref + 1; | |
4001 | end if; | |
4002 | ||
4003 | -- Now we will copy the subscript to the string buffer | |
4004 | ||
4005 | Pctr := 0; | |
4006 | loop | |
4007 | -- Count parens, exit if terminating right paren. Note | |
4008 | -- check to ignore paren appearing as character literal. | |
4009 | ||
4010 | if Tref (Sref + 1) = ''' | |
4011 | and then | |
4012 | Tref (Sref - 1) = ''' | |
4013 | then | |
4014 | null; | |
4015 | else | |
4016 | if Tref (Sref) = '(' then | |
4017 | Pctr := Pctr + 1; | |
4018 | elsif Tref (Sref) = ')' then | |
4019 | exit when Pctr = 0; | |
4020 | Pctr := Pctr - 1; | |
4021 | end if; | |
4022 | end if; | |
4023 | ||
4024 | -- Done if terminating double dot (slice case) | |
4025 | ||
4026 | exit when Pctr = 0 | |
4027 | and then (Tref (Sref .. Sref + 1) = ".." | |
c230ed0b | 4028 | or else |
3f1ede06 RD |
4029 | Tref (Sref .. Sref + 2) = " .."); |
4030 | ||
4031 | -- Quit if we have hit EOF character, something wrong | |
4032 | ||
4033 | if Tref (Sref) = EOF then | |
4034 | return; | |
4035 | end if; | |
4036 | ||
4037 | -- String literals are too much of a pain to handle | |
4038 | ||
4039 | if Tref (Sref) = '"' or else Tref (Sref) = '%' then | |
4040 | return; | |
4041 | end if; | |
4042 | ||
4043 | -- If we have a 'Range reference, then this is a case | |
a90bd866 | 4044 | -- where we cannot easily give a replacement. Don't try. |
3f1ede06 RD |
4045 | |
4046 | if Tref (Sref .. Sref + 4) = "range" | |
4047 | and then Tref (Sref - 1) < 'A' | |
4048 | and then Tref (Sref + 5) < 'A' | |
4049 | then | |
4050 | return; | |
4051 | end if; | |
4052 | ||
4053 | -- Else store next character | |
4054 | ||
4055 | Error_Msg_Strlen := Error_Msg_Strlen + 1; | |
4056 | Error_Msg_String (Error_Msg_Strlen) := Tref (Sref); | |
4057 | Sref := Sref + 1; | |
4058 | ||
4059 | -- If we get more than 40 characters then the expression | |
4060 | -- is too long to copy, or something has gone wrong. In | |
4061 | -- either case, just skip the attempt at a suggested fix. | |
4062 | ||
4063 | if Error_Msg_Strlen > 40 then | |
4064 | return; | |
4065 | end if; | |
4066 | end loop; | |
4067 | end; | |
4068 | ||
4069 | -- Replacement subscript is now in string buffer | |
4070 | ||
19d846a0 | 4071 | Error_Msg_FE -- CODEFIX |
685bc70f | 4072 | ("\?w?suggested replacement: `&~`", Original_Node (X), Ent); |
3f1ede06 | 4073 | end if; |
6877306f AC |
4074 | end Warn_On_Literal_Index; |
4075 | ||
4076 | -- Start of processing for Test_Suspicious_Index | |
4077 | ||
4078 | begin | |
4079 | -- Nothing to do if subscript does not come from source (we don't | |
4080 | -- want to give garbage warnings on compiler expanded code, e.g. the | |
4081 | -- loops generated for slice assignments. Such junk warnings would | |
4082 | -- be placed on source constructs with no subscript in sight). | |
4083 | ||
4084 | if not Comes_From_Source (Original_Node (X)) then | |
4085 | return; | |
4086 | end if; | |
4087 | ||
4088 | -- Case where subscript is a constant integer | |
4089 | ||
4090 | if Nkind (X) = N_Integer_Literal then | |
4091 | ||
4092 | -- Case where subscript is lower than the lowest possible bound. | |
4093 | -- This might be the case for example when programmers try to | |
4094 | -- access a string at index 0, as they are used to in other | |
4095 | -- programming languages like C. | |
4096 | ||
4097 | if Intval (X) < Low_Bound then | |
4098 | Warn_On_Index_Below_Lower_Bound; | |
4099 | else | |
4100 | Warn_On_Literal_Index; | |
4101 | end if; | |
3f1ede06 RD |
4102 | |
4103 | -- Case where subscript is of the form X'Length | |
4104 | ||
4105 | elsif Length_Reference (X) then | |
4106 | Warn1; | |
4107 | Error_Msg_Node_2 := Ent; | |
ed2233dc | 4108 | Error_Msg_FE |
685bc70f | 4109 | ("\?w?suggest replacement of `&''Length` by `&''Last`", |
3f1ede06 RD |
4110 | X, Ent); |
4111 | ||
4112 | -- Case where subscript is of the form X'Length - expression | |
4113 | ||
4114 | elsif Nkind (X) = N_Op_Subtract | |
4115 | and then Length_Reference (Left_Opnd (X)) | |
4116 | then | |
4117 | Warn1; | |
4118 | Error_Msg_Node_2 := Ent; | |
ed2233dc | 4119 | Error_Msg_FE |
685bc70f | 4120 | ("\?w?suggest replacement of `&''Length` by `&''Last`", |
3f1ede06 RD |
4121 | Left_Opnd (X), Ent); |
4122 | end if; | |
4123 | end Test_Suspicious_Index; | |
4124 | ||
4125 | -- Start of processing for Warn_On_Suspicious_Index | |
4126 | ||
4127 | begin | |
4128 | -- Only process if warnings activated | |
4129 | ||
4130 | if Warn_On_Assumed_Low_Bound then | |
4131 | ||
4132 | -- Test if array is simple entity name | |
4133 | ||
4134 | if Is_Entity_Name (Name) then | |
4135 | ||
4136 | -- Test if array is parameter of unconstrained string type | |
4137 | ||
4138 | Ent := Entity (Name); | |
4139 | Typ := Etype (Ent); | |
4140 | ||
4141 | if Is_Formal (Ent) | |
4142 | and then Is_Suspicious_Type (Typ) | |
fad0600d | 4143 | and then not Low_Bound_Tested (Ent) |
3f1ede06 RD |
4144 | then |
4145 | Test_Suspicious_Index; | |
4146 | end if; | |
4147 | end if; | |
4148 | end if; | |
4149 | end Warn_On_Suspicious_Index; | |
4150 | ||
71140fc6 YM |
4151 | ------------------------------- |
4152 | -- Warn_On_Suspicious_Update -- | |
4153 | ------------------------------- | |
4154 | ||
4155 | procedure Warn_On_Suspicious_Update (N : Node_Id) is | |
4156 | Par : constant Node_Id := Parent (N); | |
4157 | Arg : Node_Id; | |
4158 | ||
4159 | begin | |
4160 | -- Only process if warnings activated | |
4161 | ||
4162 | if Warn_On_Suspicious_Contract then | |
4163 | if Nkind_In (Par, N_Op_Eq, N_Op_Ne) then | |
4164 | if N = Left_Opnd (Par) then | |
4165 | Arg := Right_Opnd (Par); | |
4166 | else | |
4167 | Arg := Left_Opnd (Par); | |
4168 | end if; | |
4169 | ||
4170 | if Same_Object (Prefix (N), Arg) then | |
4171 | if Nkind (Par) = N_Op_Eq then | |
4172 | Error_Msg_N | |
4173 | ("suspicious equality test with modified version of " | |
4174 | & "same object?T?", Par); | |
4175 | else | |
4176 | Error_Msg_N | |
4177 | ("suspicious inequality test with modified version of " | |
4178 | & "same object?T?", Par); | |
4179 | end if; | |
4180 | end if; | |
4181 | end if; | |
4182 | end if; | |
4183 | end Warn_On_Suspicious_Update; | |
4184 | ||
434632ce AC |
4185 | -------------------------------------- |
4186 | -- Warn_On_Unassigned_Out_Parameter -- | |
4187 | -------------------------------------- | |
4188 | ||
4189 | procedure Warn_On_Unassigned_Out_Parameter | |
4190 | (Return_Node : Node_Id; | |
4191 | Scope_Id : Entity_Id) | |
4192 | is | |
4193 | Form : Entity_Id; | |
4194 | Form2 : Entity_Id; | |
4195 | ||
4196 | begin | |
4197 | -- Ignore if procedure or return statement does not come from source | |
4198 | ||
4199 | if not Comes_From_Source (Scope_Id) | |
4200 | or else not Comes_From_Source (Return_Node) | |
4201 | then | |
4202 | return; | |
4203 | end if; | |
4204 | ||
4205 | -- Loop through formals | |
4206 | ||
4207 | Form := First_Formal (Scope_Id); | |
4208 | while Present (Form) loop | |
4209 | ||
4210 | -- We are only interested in OUT parameters that come from source | |
4211 | -- and are never set in the source, and furthermore only in scalars | |
4212 | -- since non-scalars generate too many false positives. | |
4213 | ||
4214 | if Ekind (Form) = E_Out_Parameter | |
4215 | and then Never_Set_In_Source_Check_Spec (Form) | |
4216 | and then Is_Scalar_Type (Etype (Form)) | |
4217 | and then not Present (Unset_Reference (Form)) | |
4218 | then | |
4219 | -- Before we issue the warning, an add ad hoc defence against the | |
4220 | -- most common case of false positives with this warning which is | |
4221 | -- the case where there is a Boolean OUT parameter that has been | |
4222 | -- set, and whose meaning is "ignore the values of the other | |
4223 | -- parameters". We can't of course reliably tell this case at | |
4224 | -- compile time, but the following test kills a lot of false | |
4225 | -- positives, without generating a significant number of false | |
4226 | -- negatives (missed real warnings). | |
4227 | ||
4228 | Form2 := First_Formal (Scope_Id); | |
4229 | while Present (Form2) loop | |
4230 | if Ekind (Form2) = E_Out_Parameter | |
4231 | and then Root_Type (Etype (Form2)) = Standard_Boolean | |
4232 | and then not Never_Set_In_Source_Check_Spec (Form2) | |
4233 | then | |
4234 | return; | |
4235 | end if; | |
4236 | ||
4237 | Next_Formal (Form2); | |
4238 | end loop; | |
4239 | ||
f3d57416 | 4240 | -- Here all conditions are met, record possible unset reference |
434632ce AC |
4241 | |
4242 | Set_Unset_Reference (Form, Return_Node); | |
4243 | end if; | |
4244 | ||
4245 | Next_Formal (Form); | |
4246 | end loop; | |
4247 | end Warn_On_Unassigned_Out_Parameter; | |
4248 | ||
4249 | --------------------------------- | |
4250 | -- Warn_On_Unreferenced_Entity -- | |
4251 | --------------------------------- | |
4252 | ||
4253 | procedure Warn_On_Unreferenced_Entity | |
4254 | (Spec_E : Entity_Id; | |
4255 | Body_E : Entity_Id := Empty) | |
4256 | is | |
4257 | E : Entity_Id := Spec_E; | |
67ce0d7e | 4258 | |
434632ce | 4259 | begin |
9a18e785 RD |
4260 | if not Referenced_Check_Spec (E) |
4261 | and then not Has_Pragma_Unreferenced_Check_Spec (E) | |
4262 | and then not Warnings_Off_Check_Spec (E) | |
4bd4bb7f | 4263 | and then not Has_Junk_Name (Spec_E) |
e0709184 | 4264 | and then not Is_Exported (Spec_E) |
9a18e785 | 4265 | then |
434632ce AC |
4266 | case Ekind (E) is |
4267 | when E_Variable => | |
4268 | ||
561b5849 RD |
4269 | -- Case of variable that is assigned but not read. We suppress |
4270 | -- the message if the variable is volatile, has an address | |
f3d57416 | 4271 | -- clause, is aliased, or is a renaming, or is imported. |
434632ce AC |
4272 | |
4273 | if Referenced_As_LHS_Check_Spec (E) | |
4274 | and then No (Address_Clause (E)) | |
4275 | and then not Is_Volatile (E) | |
4276 | then | |
561b5849 | 4277 | if Warn_On_Modified_Unread |
434632ce | 4278 | and then not Is_Imported (E) |
434632ce AC |
4279 | and then not Is_Aliased (E) |
4280 | and then No (Renamed_Object (E)) | |
434632ce | 4281 | then |
9d77af56 | 4282 | if not Has_Pragma_Unmodified_Check_Spec (E) then |
483c78cb | 4283 | Error_Msg_N -- CODEFIX |
98b779ae | 4284 | ("?m?variable & is assigned but never read!", E); |
9d77af56 RD |
4285 | end if; |
4286 | ||
434632ce AC |
4287 | Set_Last_Assignment (E, Empty); |
4288 | end if; | |
4289 | ||
561b5849 RD |
4290 | -- Normal case of neither assigned nor read (exclude variables |
4291 | -- referenced as out parameters, since we already generated | |
4292 | -- appropriate warnings at the call point in this case). | |
4293 | ||
4294 | elsif not Referenced_As_Out_Parameter (E) then | |
434632ce | 4295 | |
434632ce AC |
4296 | -- We suppress the message for types for which a valid |
4297 | -- pragma Unreferenced_Objects has been given, otherwise | |
4298 | -- we go ahead and give the message. | |
4299 | ||
4300 | if not Has_Pragma_Unreferenced_Objects (Etype (E)) then | |
4301 | ||
4302 | -- Distinguish renamed case in message | |
4303 | ||
4304 | if Present (Renamed_Object (E)) | |
4305 | and then Comes_From_Source (Renamed_Object (E)) | |
4306 | then | |
19d846a0 | 4307 | Error_Msg_N -- CODEFIX |
685bc70f | 4308 | ("?u?renamed variable & is not referenced!", E); |
434632ce | 4309 | else |
19d846a0 | 4310 | Error_Msg_N -- CODEFIX |
685bc70f | 4311 | ("?u?variable & is not referenced!", E); |
434632ce AC |
4312 | end if; |
4313 | end if; | |
4314 | end if; | |
4315 | ||
4316 | when E_Constant => | |
09c954dc AC |
4317 | if not Has_Pragma_Unreferenced_Objects (Etype (E)) then |
4318 | if Present (Renamed_Object (E)) | |
4319 | and then Comes_From_Source (Renamed_Object (E)) | |
4320 | then | |
4321 | Error_Msg_N -- CODEFIX | |
4322 | ("?u?renamed constant & is not referenced!", E); | |
4323 | else | |
4324 | Error_Msg_N -- CODEFIX | |
4325 | ("?u?constant & is not referenced!", E); | |
4326 | end if; | |
434632ce AC |
4327 | end if; |
4328 | ||
d8f43ee6 HK |
4329 | when E_In_Out_Parameter |
4330 | | E_In_Parameter | |
4331 | => | |
4332 | -- Do not emit message for formals of a renaming, because they | |
4333 | -- are never referenced explicitly. | |
434632ce | 4334 | |
685bc70f AC |
4335 | if Nkind (Original_Node (Unit_Declaration_Node (Scope (E)))) /= |
4336 | N_Subprogram_Renaming_Declaration | |
434632ce AC |
4337 | then |
4338 | -- Suppress this message for an IN OUT parameter of a | |
4339 | -- non-scalar type, since it is normal to have only an | |
4340 | -- assignment in such a case. | |
4341 | ||
4342 | if Ekind (E) = E_In_Parameter | |
4343 | or else not Referenced_As_LHS_Check_Spec (E) | |
005ae225 | 4344 | or else Is_Scalar_Type (Etype (E)) |
434632ce AC |
4345 | then |
4346 | if Present (Body_E) then | |
4347 | E := Body_E; | |
4348 | end if; | |
9a18e785 RD |
4349 | |
4350 | if not Is_Trivial_Subprogram (Scope (E)) then | |
19d846a0 | 4351 | Error_Msg_NE -- CODEFIX |
685bc70f | 4352 | ("?u?formal parameter & is not referenced!", |
9a18e785 RD |
4353 | E, Spec_E); |
4354 | end if; | |
434632ce AC |
4355 | end if; |
4356 | end if; | |
4357 | ||
fa031669 | 4358 | when E_Out_Parameter => |
434632ce AC |
4359 | null; |
4360 | ||
fa031669 | 4361 | when E_Discriminant => |
685bc70f | 4362 | Error_Msg_N ("?u?discriminant & is not referenced!", E); |
fa031669 | 4363 | |
d8f43ee6 HK |
4364 | when E_Named_Integer |
4365 | | E_Named_Real | |
4366 | => | |
19d846a0 | 4367 | Error_Msg_N -- CODEFIX |
685bc70f | 4368 | ("?u?named number & is not referenced!", E); |
434632ce | 4369 | |
fa031669 | 4370 | when Formal_Object_Kind => |
19d846a0 | 4371 | Error_Msg_N -- CODEFIX |
685bc70f | 4372 | ("?u?formal object & is not referenced!", E); |
fa031669 | 4373 | |
434632ce | 4374 | when E_Enumeration_Literal => |
19d846a0 | 4375 | Error_Msg_N -- CODEFIX |
685bc70f | 4376 | ("?u?literal & is not referenced!", E); |
434632ce | 4377 | |
fa031669 | 4378 | when E_Function => |
19d846a0 | 4379 | Error_Msg_N -- CODEFIX |
685bc70f | 4380 | ("?u?function & is not referenced!", E); |
434632ce | 4381 | |
fa031669 | 4382 | when E_Procedure => |
19d846a0 | 4383 | Error_Msg_N -- CODEFIX |
685bc70f | 4384 | ("?u?procedure & is not referenced!", E); |
434632ce | 4385 | |
fa031669 | 4386 | when E_Package => |
19d846a0 | 4387 | Error_Msg_N -- CODEFIX |
685bc70f | 4388 | ("?u?package & is not referenced!", E); |
fa031669 AC |
4389 | |
4390 | when E_Exception => | |
19d846a0 | 4391 | Error_Msg_N -- CODEFIX |
685bc70f | 4392 | ("?u?exception & is not referenced!", E); |
fa031669 AC |
4393 | |
4394 | when E_Label => | |
19d846a0 | 4395 | Error_Msg_N -- CODEFIX |
685bc70f | 4396 | ("?u?label & is not referenced!", E); |
fa031669 | 4397 | |
434632ce | 4398 | when E_Generic_Procedure => |
483c78cb | 4399 | Error_Msg_N -- CODEFIX |
685bc70f | 4400 | ("?u?generic procedure & is never instantiated!", E); |
434632ce | 4401 | |
fa031669 | 4402 | when E_Generic_Function => |
483c78cb | 4403 | Error_Msg_N -- CODEFIX |
685bc70f | 4404 | ("?u?generic function & is never instantiated!", E); |
434632ce | 4405 | |
fa031669 | 4406 | when Type_Kind => |
19d846a0 | 4407 | Error_Msg_N -- CODEFIX |
685bc70f | 4408 | ("?u?type & is not referenced!", E); |
434632ce AC |
4409 | |
4410 | when others => | |
19d846a0 | 4411 | Error_Msg_N -- CODEFIX |
685bc70f | 4412 | ("?u?& is not referenced!", E); |
434632ce AC |
4413 | end case; |
4414 | ||
4415 | -- Kill warnings on the entity on which the message has been posted | |
b3083540 AC |
4416 | -- (nothing is posted on out parameters because back end might be |
4417 | -- able to uncover an uninitialized path, and warn accordingly). | |
434632ce | 4418 | |
b3083540 AC |
4419 | if Ekind (E) /= E_Out_Parameter then |
4420 | Set_Warnings_Off (E); | |
4421 | end if; | |
434632ce AC |
4422 | end if; |
4423 | end Warn_On_Unreferenced_Entity; | |
4424 | ||
3f1ede06 RD |
4425 | -------------------------------- |
4426 | -- Warn_On_Useless_Assignment -- | |
4427 | -------------------------------- | |
4428 | ||
4429 | procedure Warn_On_Useless_Assignment | |
4430 | (Ent : Entity_Id; | |
561b5849 | 4431 | N : Node_Id := Empty) |
3f1ede06 | 4432 | is |
561b5849 RD |
4433 | P : Node_Id; |
4434 | X : Node_Id; | |
3f1ede06 RD |
4435 | |
4436 | function Check_Ref (N : Node_Id) return Traverse_Result; | |
4e7a4f6e AC |
4437 | -- Used to instantiate Traverse_Func. Returns Abandon if a reference to |
4438 | -- the entity in question is found. | |
3f1ede06 RD |
4439 | |
4440 | function Test_No_Refs is new Traverse_Func (Check_Ref); | |
4441 | ||
4442 | --------------- | |
4443 | -- Check_Ref -- | |
4444 | --------------- | |
4445 | ||
4446 | function Check_Ref (N : Node_Id) return Traverse_Result is | |
4447 | begin | |
4448 | -- Check reference to our identifier. We use name equality here | |
4449 | -- because the exception handlers have not yet been analyzed. This | |
4450 | -- is not quite right, but it really does not matter that we fail | |
4451 | -- to output the warning in some obscure cases of name clashes. | |
4452 | ||
c230ed0b | 4453 | if Nkind (N) = N_Identifier and then Chars (N) = Chars (Ent) then |
3f1ede06 RD |
4454 | return Abandon; |
4455 | else | |
4456 | return OK; | |
4457 | end if; | |
4458 | end Check_Ref; | |
4459 | ||
4460 | -- Start of processing for Warn_On_Useless_Assignment | |
4461 | ||
4462 | begin | |
561b5849 RD |
4463 | -- Check if this is a case we want to warn on, a scalar or access |
4464 | -- variable with the last assignment field set, with warnings enabled, | |
4465 | -- and which is not imported or exported. We also check that it is OK | |
4466 | -- to capture the value. We are not going to capture any value, but | |
4e7a4f6e | 4467 | -- the warning message depends on the same kind of conditions. |
3f1ede06 | 4468 | |
67ce0d7e | 4469 | if Is_Assignable (Ent) |
874a0341 | 4470 | and then not Is_Return_Object (Ent) |
3f1ede06 | 4471 | and then Present (Last_Assignment (Ent)) |
3f1ede06 RD |
4472 | and then not Is_Imported (Ent) |
4473 | and then not Is_Exported (Ent) | |
561b5849 | 4474 | and then Safe_To_Capture_Value (N, Ent) |
9a18e785 | 4475 | and then not Has_Pragma_Unreferenced_Check_Spec (Ent) |
4bd4bb7f | 4476 | and then not Has_Junk_Name (Ent) |
3f1ede06 RD |
4477 | then |
4478 | -- Before we issue the message, check covering exception handlers. | |
9a18e785 | 4479 | -- Search up tree for enclosing statement sequences and handlers. |
3f1ede06 RD |
4480 | |
4481 | P := Parent (Last_Assignment (Ent)); | |
4482 | while Present (P) loop | |
4483 | ||
9a18e785 RD |
4484 | -- Something is really wrong if we don't find a handled statement |
4485 | -- sequence, so just suppress the warning. | |
3f1ede06 RD |
4486 | |
4487 | if No (P) then | |
4488 | Set_Last_Assignment (Ent, Empty); | |
4489 | return; | |
4490 | ||
4491 | -- When we hit a package/subprogram body, issue warning and exit | |
4492 | ||
814cc240 AC |
4493 | elsif Nkind_In (P, N_Entry_Body, |
4494 | N_Package_Body, | |
4495 | N_Subprogram_Body, | |
4496 | N_Task_Body) | |
3f1ede06 | 4497 | then |
67ce0d7e RD |
4498 | -- Case of assigned value never referenced |
4499 | ||
561b5849 | 4500 | if No (N) then |
a51cd0ec AC |
4501 | declare |
4502 | LA : constant Node_Id := Last_Assignment (Ent); | |
67ce0d7e | 4503 | |
a51cd0ec AC |
4504 | begin |
4505 | -- Don't give this for OUT and IN OUT formals, since | |
4506 | -- clearly caller may reference the assigned value. Also | |
0a3ec628 AC |
4507 | -- never give such warnings for internal variables. In |
4508 | -- either case, word the warning in a conditional way, | |
4509 | -- because in the case of a component of a controlled | |
4510 | -- type, the assigned value might be referenced in the | |
4511 | -- Finalize operation, so we can't make a definitive | |
4512 | -- statement that it's never referenced. | |
67ce0d7e | 4513 | |
a51cd0ec AC |
4514 | if Ekind (Ent) = E_Variable |
4515 | and then not Is_Internal_Name (Chars (Ent)) | |
4516 | then | |
4517 | -- Give appropriate message, distinguishing between | |
4518 | -- assignment statements and out parameters. | |
4519 | ||
f991bd8e HK |
4520 | if Nkind_In (Parent (LA), N_Parameter_Association, |
4521 | N_Procedure_Call_Statement) | |
a51cd0ec AC |
4522 | then |
4523 | Error_Msg_NE | |
f991bd8e HK |
4524 | ("?m?& modified by call, but value might not be " |
4525 | & "referenced", LA, Ent); | |
a51cd0ec AC |
4526 | |
4527 | else | |
4528 | Error_Msg_NE -- CODEFIX | |
0a3ec628 AC |
4529 | ("?m?possibly useless assignment to&, value " |
4530 | & "might not be referenced!", LA, Ent); | |
a51cd0ec | 4531 | end if; |
561b5849 | 4532 | end if; |
a51cd0ec | 4533 | end; |
67ce0d7e RD |
4534 | |
4535 | -- Case of assigned value overwritten | |
4536 | ||
3f1ede06 | 4537 | else |
a51cd0ec AC |
4538 | declare |
4539 | LA : constant Node_Id := Last_Assignment (Ent); | |
561b5849 | 4540 | |
a51cd0ec AC |
4541 | begin |
4542 | Error_Msg_Sloc := Sloc (N); | |
4543 | ||
4544 | -- Give appropriate message, distinguishing between | |
4545 | -- assignment statements and out parameters. | |
4546 | ||
4547 | if Nkind_In (Parent (LA), N_Procedure_Call_Statement, | |
4548 | N_Parameter_Association) | |
4549 | then | |
4550 | Error_Msg_NE | |
685bc70f | 4551 | ("?m?& modified by call, but value overwritten #!", |
a51cd0ec AC |
4552 | LA, Ent); |
4553 | else | |
4554 | Error_Msg_NE -- CODEFIX | |
685bc70f | 4555 | ("?m?useless assignment to&, value overwritten #!", |
a51cd0ec AC |
4556 | LA, Ent); |
4557 | end if; | |
4558 | end; | |
3f1ede06 RD |
4559 | end if; |
4560 | ||
67ce0d7e RD |
4561 | -- Clear last assignment indication and we are done |
4562 | ||
3f1ede06 RD |
4563 | Set_Last_Assignment (Ent, Empty); |
4564 | return; | |
4565 | ||
4566 | -- Enclosing handled sequence of statements | |
4567 | ||
4568 | elsif Nkind (P) = N_Handled_Sequence_Of_Statements then | |
4569 | ||
4570 | -- Check exception handlers present | |
4571 | ||
4572 | if Present (Exception_Handlers (P)) then | |
4573 | ||
4574 | -- If we are not at the top level, we regard an inner | |
4575 | -- exception handler as a decisive indicator that we should | |
4576 | -- not generate the warning, since the variable in question | |
f3d57416 | 4577 | -- may be accessed after an exception in the outer block. |
3f1ede06 | 4578 | |
814cc240 AC |
4579 | if not Nkind_In (Parent (P), N_Entry_Body, |
4580 | N_Package_Body, | |
4581 | N_Subprogram_Body, | |
4582 | N_Task_Body) | |
3f1ede06 RD |
4583 | then |
4584 | Set_Last_Assignment (Ent, Empty); | |
4585 | return; | |
4586 | ||
4587 | -- Otherwise we are at the outer level. An exception | |
4588 | -- handler is significant only if it references the | |
4e7a4f6e | 4589 | -- variable in question, or if the entity in question |
026c3cfd | 4590 | -- is an OUT or IN OUT parameter, in which case |
4e7a4f6e | 4591 | -- the caller can reference it after the exception |
308e6f3a | 4592 | -- handler completes. |
3f1ede06 RD |
4593 | |
4594 | else | |
4e7a4f6e AC |
4595 | if Is_Formal (Ent) then |
4596 | Set_Last_Assignment (Ent, Empty); | |
4597 | return; | |
3f1ede06 | 4598 | |
4e7a4f6e AC |
4599 | else |
4600 | X := First (Exception_Handlers (P)); | |
4601 | while Present (X) loop | |
4602 | if Test_No_Refs (X) = Abandon then | |
4603 | Set_Last_Assignment (Ent, Empty); | |
4604 | return; | |
4605 | end if; | |
4606 | ||
4607 | X := Next (X); | |
4608 | end loop; | |
4609 | end if; | |
3f1ede06 RD |
4610 | end if; |
4611 | end if; | |
4612 | end if; | |
4613 | ||
4614 | P := Parent (P); | |
4615 | end loop; | |
4616 | end if; | |
4617 | end Warn_On_Useless_Assignment; | |
4618 | ||
4619 | --------------------------------- | |
4620 | -- Warn_On_Useless_Assignments -- | |
4621 | --------------------------------- | |
4622 | ||
4623 | procedure Warn_On_Useless_Assignments (E : Entity_Id) is | |
4624 | Ent : Entity_Id; | |
bdfb8ec4 | 4625 | |
3f1ede06 | 4626 | begin |
bdfb8ec4 AC |
4627 | Process_Deferred_References; |
4628 | ||
3f1ede06 RD |
4629 | if Warn_On_Modified_Unread |
4630 | and then In_Extended_Main_Source_Unit (E) | |
4631 | then | |
4632 | Ent := First_Entity (E); | |
4633 | while Present (Ent) loop | |
4634 | Warn_On_Useless_Assignment (Ent); | |
4635 | Next_Entity (Ent); | |
4636 | end loop; | |
4637 | end if; | |
4638 | end Warn_On_Useless_Assignments; | |
4639 | ||
9a18e785 RD |
4640 | ----------------------------- |
4641 | -- Warnings_Off_Check_Spec -- | |
4642 | ----------------------------- | |
4643 | ||
4644 | function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean is | |
4645 | begin | |
4646 | if Is_Formal (E) and then Present (Spec_Entity (E)) then | |
4647 | ||
4648 | -- Note: use of OR here instead of OR ELSE is deliberate, we want | |
4649 | -- to mess with flags on both entities. | |
4650 | ||
4651 | return Has_Warnings_Off (E) | |
4652 | or | |
4653 | Has_Warnings_Off (Spec_Entity (E)); | |
4654 | ||
4655 | else | |
4656 | return Has_Warnings_Off (E); | |
4657 | end if; | |
4658 | end Warnings_Off_Check_Spec; | |
4659 | ||
996ae0b0 | 4660 | end Sem_Warn; |