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