Add assember CFI directives to millicode division and remainder routines.
[official-gcc.git] / gcc / ada / sem_warn.adb
blob834d48d311cbe439e3908b8272cad852515d9b64
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 Present (PA) and then 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 Is_Access_Subprogram_Type (Etype (Actual)) then
595 return Abandon;
596 else
597 Next_Actual (Actual);
598 end if;
599 end loop;
600 end;
602 -- Declaration of the variable in question
604 elsif Nkind (N) = N_Object_Declaration
605 and then Defining_Identifier (N) = Var
606 then
607 return Abandon;
608 end if;
610 -- All OK, continue scan
612 return OK;
613 end Test_Ref;
615 -- Start of processing for Check_Infinite_Loop_Warning
617 begin
618 -- Skip processing if debug flag gnatd.w is set
620 if Debug_Flag_Dot_W then
621 return;
622 end if;
624 -- Deal with Iteration scheme present
626 declare
627 Iter : constant Node_Id := Iteration_Scheme (Loop_Statement);
629 begin
630 if Present (Iter) then
632 -- While iteration
634 if Present (Condition (Iter)) then
636 -- Skip processing for while iteration with conditions actions,
637 -- since they make it too complicated to get the warning right.
639 if Has_Condition_Actions (Iter) then
640 return;
641 end if;
643 -- Capture WHILE condition
645 Expression := Condition (Iter);
647 -- For Loop_Parameter_Specification, do not process, since loop
648 -- will always terminate. For Iterator_Specification, also do not
649 -- process. Either it will always terminate (e.g. "for X of
650 -- Some_Array ..."), or we can't tell if it's going to terminate
651 -- without looking at the iterator, so any warning here would be
652 -- noise.
654 elsif Present (Loop_Parameter_Specification (Iter))
655 or else Present (Iterator_Specification (Iter))
656 then
657 return;
658 end if;
659 end if;
660 end;
662 -- Check chain of EXIT statements, we only process loops that have a
663 -- single exit condition (either a single EXIT WHEN statement, or a
664 -- WHILE loop not containing any EXIT WHEN statements).
666 declare
667 Ident : constant Node_Id := Identifier (Loop_Statement);
668 Exit_Stmt : Node_Id;
670 begin
671 -- If we don't have a proper chain set, ignore call entirely. This
672 -- happens because of previous errors.
674 if No (Entity (Ident))
675 or else Ekind (Entity (Ident)) /= E_Loop
676 then
677 Check_Error_Detected;
678 return;
679 end if;
681 -- Otherwise prepare to scan list of EXIT statements
683 Exit_Stmt := First_Exit_Statement (Entity (Ident));
684 while Present (Exit_Stmt) loop
686 -- Check for EXIT WHEN
688 if Present (Condition (Exit_Stmt)) then
690 -- Quit processing if EXIT WHEN in WHILE loop, or more than
691 -- one EXIT WHEN statement present in the loop.
693 if Present (Expression) then
694 return;
696 -- Otherwise capture condition from EXIT WHEN statement
698 else
699 Expression := Condition (Exit_Stmt);
700 end if;
702 -- If an unconditional exit statement is the last statement in the
703 -- loop, assume that no warning is needed, without any attempt at
704 -- checking whether the exit is reachable.
706 elsif Exit_Stmt = Last (Statements (Loop_Statement)) then
707 return;
708 end if;
710 Exit_Stmt := Next_Exit_Statement (Exit_Stmt);
711 end loop;
712 end;
714 -- Return if no condition to test
716 if No (Expression) then
717 return;
718 end if;
720 -- Initial conditions met, see if condition is of right form
722 Find_Var (Expression);
724 -- Nothing to do if local variable from source not found. If it's a
725 -- renaming, it is probably renaming something too complicated to deal
726 -- with here.
728 if No (Var)
729 or else Ekind (Var) /= E_Variable
730 or else Is_Library_Level_Entity (Var)
731 or else not Comes_From_Source (Var)
732 or else Nkind (Parent (Var)) = N_Object_Renaming_Declaration
733 then
734 return;
736 -- Nothing to do if there is some indirection involved (assume that the
737 -- designated variable might be modified in some way we don't see).
738 -- However, if no function call was found, then we don't care about
739 -- indirections, because the condition must be something like "while X
740 -- /= null loop", so we don't care if X.all is modified in the loop.
742 elsif Function_Call_Found and then Has_Indirection (Etype (Var)) then
743 return;
745 -- Same sort of thing for volatile variable, might be modified by
746 -- some other task or by the operating system in some way.
748 elsif Is_Volatile (Var) then
749 return;
750 end if;
752 -- Filter out case of original statement sequence starting with delay.
753 -- We assume this is a multi-tasking program and that the condition
754 -- is affected by other threads (some kind of busy wait).
756 declare
757 Fstm : constant Node_Id :=
758 Original_Node (First (Statements (Loop_Statement)));
759 begin
760 if Nkind (Fstm) in N_Delay_Statement then
761 return;
762 end if;
763 end;
765 -- We have a variable reference of the right form, now we scan the loop
766 -- body to see if it looks like it might not be modified
768 if No_Ref_Found (Loop_Statement) = OK then
769 Error_Msg_NE
770 ("??variable& is not modified in loop body!", Ref, Var);
771 Error_Msg_N
772 ("\??possible infinite loop!", Ref);
773 end if;
774 end Check_Infinite_Loop_Warning;
776 ----------------------------
777 -- Check_Low_Bound_Tested --
778 ----------------------------
780 procedure Check_Low_Bound_Tested (Expr : Node_Id) is
781 procedure Check_Low_Bound_Tested_For (Opnd : Node_Id);
782 -- Determine whether operand Opnd denotes attribute 'First whose prefix
783 -- is a formal parameter. If this is the case, mark the entity of the
784 -- prefix as having its low bound tested.
786 --------------------------------
787 -- Check_Low_Bound_Tested_For --
788 --------------------------------
790 procedure Check_Low_Bound_Tested_For (Opnd : Node_Id) is
791 begin
792 if Nkind (Opnd) = N_Attribute_Reference
793 and then Attribute_Name (Opnd) = Name_First
794 and then Is_Entity_Name (Prefix (Opnd))
795 and then Present (Entity (Prefix (Opnd)))
796 and then Is_Formal (Entity (Prefix (Opnd)))
797 then
798 Set_Low_Bound_Tested (Entity (Prefix (Opnd)));
799 end if;
800 end Check_Low_Bound_Tested_For;
802 -- Start of processing for Check_Low_Bound_Tested
804 begin
805 if Comes_From_Source (Expr) then
806 Check_Low_Bound_Tested_For (Left_Opnd (Expr));
807 Check_Low_Bound_Tested_For (Right_Opnd (Expr));
808 end if;
809 end Check_Low_Bound_Tested;
811 ----------------------
812 -- Check_References --
813 ----------------------
815 procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is
816 E1 : Entity_Id;
817 E1T : Entity_Id;
818 UR : Node_Id;
820 function Body_Formal
821 (E : Entity_Id;
822 Accept_Statement : Node_Id) return Entity_Id;
823 -- For an entry formal entity from an entry declaration, find the
824 -- corresponding body formal from the given accept statement.
826 function Generic_Body_Formal (E : Entity_Id) return Entity_Id;
827 -- Warnings on unused formals of subprograms are placed on the entity
828 -- in the subprogram body, which seems preferable because it suggests
829 -- a better codefix for GNAT Studio. The analysis of generic subprogram
830 -- bodies uses a different circuitry, so the choice for the proper
831 -- placement of the warning in the generic case takes place here, by
832 -- finding the body entity that corresponds to a formal in a spec.
834 procedure May_Need_Initialized_Actual (Ent : Entity_Id);
835 -- If an entity of a generic type has default initialization, then the
836 -- corresponding actual type should be fully initialized, or else there
837 -- will be uninitialized components in the instantiation, that might go
838 -- unreported. This routine marks the type of the uninitialized variable
839 -- appropriately to allow the compiler to emit an appropriate warning
840 -- in the instance. In a sense, the use of a type that requires full
841 -- initialization is a weak part of the generic contract.
843 function Missing_Subunits return Boolean;
844 -- We suppress warnings when there are missing subunits, because this
845 -- may generate too many false positives: entities in a parent may only
846 -- be referenced in one of the subunits. We make an exception for
847 -- subunits that contain no other stubs.
849 procedure Output_Reference_Error (M : String);
850 -- Used to output an error message. Deals with posting the error on the
851 -- body formal in the accept case.
853 function Publicly_Referenceable (Ent : Entity_Id) return Boolean;
854 -- This is true if the entity in question is potentially referenceable
855 -- from another unit. This is true for entities in packages that are at
856 -- the library level.
858 function Warnings_Off_E1 return Boolean;
859 -- Return True if Warnings_Off is set for E1, or for its Etype (E1T),
860 -- or for the base type of E1T.
862 -----------------
863 -- Body_Formal --
864 -----------------
866 function Body_Formal
867 (E : Entity_Id;
868 Accept_Statement : Node_Id) return Entity_Id
870 Body_Param : Node_Id;
871 Body_E : Entity_Id;
873 begin
874 -- Loop to find matching parameter in accept statement
876 Body_Param := First (Parameter_Specifications (Accept_Statement));
877 while Present (Body_Param) loop
878 Body_E := Defining_Identifier (Body_Param);
880 if Chars (Body_E) = Chars (E) then
881 return Body_E;
882 end if;
884 Next (Body_Param);
885 end loop;
887 -- Should never fall through, should always find a match
889 raise Program_Error;
890 end Body_Formal;
892 -------------------------
893 -- Generic_Body_Formal --
894 -------------------------
896 function Generic_Body_Formal (E : Entity_Id) return Entity_Id is
897 Gen_Decl : constant Node_Id := Unit_Declaration_Node (Scope (E));
898 Gen_Body : constant Entity_Id := Corresponding_Body (Gen_Decl);
899 Form : Entity_Id;
901 begin
902 if No (Gen_Body) then
903 return E;
905 else
906 Form := First_Entity (Gen_Body);
907 while Present (Form) loop
908 if Chars (Form) = Chars (E) then
909 return Form;
910 end if;
912 Next_Entity (Form);
913 end loop;
914 end if;
916 -- Should never fall through, should always find a match
918 raise Program_Error;
919 end Generic_Body_Formal;
921 ---------------------------------
922 -- May_Need_Initialized_Actual --
923 ---------------------------------
925 procedure May_Need_Initialized_Actual (Ent : Entity_Id) is
926 T : constant Entity_Id := Etype (Ent);
927 Par : constant Node_Id := Parent (T);
929 begin
930 if not Is_Generic_Type (T) then
931 null;
933 elsif Nkind (Par) = N_Private_Extension_Declaration then
935 -- We only indicate the first such variable in the generic.
937 if No (Uninitialized_Variable (Par)) then
938 Set_Uninitialized_Variable (Par, Ent);
939 end if;
941 elsif Nkind (Par) = N_Formal_Type_Declaration
942 and then Nkind (Formal_Type_Definition (Par)) =
943 N_Formal_Private_Type_Definition
944 then
945 if No (Uninitialized_Variable (Formal_Type_Definition (Par))) then
946 Set_Uninitialized_Variable (Formal_Type_Definition (Par), Ent);
947 end if;
948 end if;
949 end May_Need_Initialized_Actual;
951 ----------------------
952 -- Missing_Subunits --
953 ----------------------
955 function Missing_Subunits return Boolean is
956 D : Node_Id;
958 begin
959 if not Unloaded_Subunits then
961 -- Normal compilation, all subunits are present
963 return False;
965 elsif E /= Main_Unit_Entity then
967 -- No warnings on a stub that is not the main unit
969 return True;
971 elsif Nkind (Unit_Declaration_Node (E)) in N_Proper_Body then
972 D := First (Declarations (Unit_Declaration_Node (E)));
973 while Present (D) loop
975 -- No warnings if the proper body contains nested stubs
977 if Nkind (D) in N_Body_Stub then
978 return True;
979 end if;
981 Next (D);
982 end loop;
984 return False;
986 else
987 -- Missing stubs elsewhere
989 return True;
990 end if;
991 end Missing_Subunits;
993 ----------------------------
994 -- Output_Reference_Error --
995 ----------------------------
997 procedure Output_Reference_Error (M : String) is
998 begin
999 -- Never issue messages for internal names or renamings
1001 if Is_Internal_Name (Chars (E1))
1002 or else Nkind (Parent (E1)) = N_Object_Renaming_Declaration
1003 then
1004 return;
1005 end if;
1007 -- Don't output message for IN OUT formal unless we have the warning
1008 -- flag specifically set. It is a bit odd to distinguish IN OUT
1009 -- formals from other cases. This distinction is historical in
1010 -- nature. Warnings for IN OUT formals were added fairly late.
1012 if Ekind (E1) = E_In_Out_Parameter
1013 and then not Check_Unreferenced_Formals
1014 then
1015 return;
1016 end if;
1018 -- Other than accept case, post error on defining identifier
1020 if No (Anod) then
1021 Error_Msg_N (M, E1);
1023 -- Accept case, find body formal to post the message
1025 else
1026 Error_Msg_NE (M, Body_Formal (E1, Accept_Statement => Anod), E1);
1028 end if;
1029 end Output_Reference_Error;
1031 ----------------------------
1032 -- Publicly_Referenceable --
1033 ----------------------------
1035 function Publicly_Referenceable (Ent : Entity_Id) return Boolean is
1036 P : Node_Id;
1037 Prev : Node_Id;
1039 begin
1040 -- A formal parameter is never referenceable outside the body of its
1041 -- subprogram or entry.
1043 if Is_Formal (Ent) then
1044 return False;
1045 end if;
1047 -- Examine parents to look for a library level package spec. But if
1048 -- we find a body or block or other similar construct along the way,
1049 -- we cannot be referenced.
1051 Prev := Ent;
1052 P := Parent (Ent);
1053 loop
1054 case Nkind (P) is
1056 -- If we get to top of tree, then publicly referenceable
1058 when N_Empty =>
1059 return True;
1061 -- If we reach a generic package declaration, then always
1062 -- consider this referenceable, since any instantiation will
1063 -- have access to the entities in the generic package. Note
1064 -- that the package itself may not be instantiated, but then
1065 -- we will get a warning for the package entity.
1067 -- Note that generic formal parameters are themselves not
1068 -- publicly referenceable in an instance, and warnings on them
1069 -- are useful.
1071 when N_Generic_Package_Declaration =>
1072 return
1073 not Is_List_Member (Prev)
1074 or else List_Containing (Prev) /=
1075 Generic_Formal_Declarations (P);
1077 -- Similarly, the generic formals of a generic subprogram are
1078 -- not accessible.
1080 when N_Generic_Subprogram_Declaration =>
1081 if Is_List_Member (Prev)
1082 and then List_Containing (Prev) =
1083 Generic_Formal_Declarations (P)
1084 then
1085 return False;
1086 else
1087 P := Parent (P);
1088 end if;
1090 -- If we reach a subprogram body, entity is not referenceable
1091 -- unless it is the defining entity of the body. This will
1092 -- happen, e.g. when a function is an attribute renaming that
1093 -- is rewritten as a body.
1095 when N_Subprogram_Body =>
1096 if Ent /= Defining_Entity (P) then
1097 return False;
1098 else
1099 P := Parent (P);
1100 end if;
1102 -- If we reach any other body, definitely not referenceable
1104 when N_Block_Statement
1105 | N_Entry_Body
1106 | N_Package_Body
1107 | N_Protected_Body
1108 | N_Subunit
1109 | N_Task_Body
1111 return False;
1113 -- For all other cases, keep looking up tree
1115 when others =>
1116 Prev := P;
1117 P := Parent (P);
1118 end case;
1119 end loop;
1120 end Publicly_Referenceable;
1122 ---------------------
1123 -- Warnings_Off_E1 --
1124 ---------------------
1126 function Warnings_Off_E1 return Boolean is
1127 begin
1128 return Has_Warnings_Off (E1T)
1129 or else Has_Warnings_Off (Base_Type (E1T))
1130 or else Warnings_Off_Check_Spec (E1);
1131 end Warnings_Off_E1;
1133 -- Start of processing for Check_References
1135 begin
1136 -- No messages if warnings are suppressed, or if we have detected any
1137 -- real errors so far (this last check avoids junk messages resulting
1138 -- from errors, e.g. a subunit that is not loaded).
1140 if Warning_Mode = Suppress or else Serious_Errors_Detected /= 0 then
1141 return;
1142 end if;
1144 -- We also skip the messages if any subunits were not loaded (see
1145 -- comment in Sem_Ch10 to understand how this is set, and why it is
1146 -- necessary to suppress the warnings in this case).
1148 if Missing_Subunits then
1149 return;
1150 end if;
1152 -- Otherwise loop through entities, looking for suspicious stuff
1154 E1 := First_Entity (E);
1155 while Present (E1) loop
1156 -- We are only interested in source entities. We also don't issue
1157 -- warnings within instances, since the proper place for such
1158 -- warnings is on the template when it is compiled, and we don't
1159 -- issue warnings for variables with names like Junk, Discard etc.
1161 if Comes_From_Source (E1)
1162 and then Instantiation_Location (Sloc (E1)) = No_Location
1163 then
1164 E1T := Etype (E1);
1166 -- We are interested in variables and out/in-out parameters, but
1167 -- we exclude protected types, too complicated to worry about.
1169 if Ekind (E1) = E_Variable
1170 or else
1171 (Ekind (E1) in E_Out_Parameter | E_In_Out_Parameter
1172 and then not Is_Protected_Type (Current_Scope))
1173 then
1174 -- If the formal has a class-wide type, retrieve its type
1175 -- because checks below depend on its private nature.
1177 if Is_Class_Wide_Type (E1T) then
1178 E1T := Etype (E1T);
1179 end if;
1181 -- Case of an unassigned variable
1183 -- First gather any Unset_Reference indication for E1. In the
1184 -- case of an 'out' parameter, it is the Spec_Entity that is
1185 -- relevant.
1187 if Ekind (E1) = E_Out_Parameter
1188 and then Present (Spec_Entity (E1))
1189 then
1190 UR := Unset_Reference (Spec_Entity (E1));
1191 else
1192 UR := Unset_Reference (E1);
1193 end if;
1195 -- Special processing for access types
1197 if Present (UR) and then Is_Access_Type (E1T) then
1199 -- For access types, the only time we made a UR entry was
1200 -- for a dereference, and so we post the appropriate warning
1201 -- here (note that the dereference may not be explicit in
1202 -- the source, for example in the case of a dispatching call
1203 -- with an anonymous access controlling formal, or of an
1204 -- assignment of a pointer involving discriminant check on
1205 -- the designated object).
1207 if not Warnings_Off_E1 then
1208 Error_Msg_NE ("??& may be null!", UR, E1);
1209 end if;
1211 goto Continue;
1213 -- Case of variable that could be a constant. Note that we
1214 -- never signal such messages for generic package entities,
1215 -- since a given instance could have modifications outside
1216 -- the package.
1218 -- Note that we used to check Address_Taken here, but we don't
1219 -- want to do that since it can be set for non-source cases,
1220 -- e.g. the Unrestricted_Access from a valid attribute, and
1221 -- the wanted effect is included in Never_Set_In_Source.
1223 elsif Warn_On_Constant
1224 and then Ekind (E1) = E_Variable
1225 and then Has_Initial_Value (E1)
1226 and then Never_Set_In_Source (E1)
1227 and then not Generic_Package_Spec_Entity (E1)
1228 then
1229 -- A special case, if this variable is volatile and not
1230 -- imported, it is not helpful to tell the programmer
1231 -- to mark the variable as constant, since this would be
1232 -- illegal by virtue of RM C.6(13). Instead we suggest
1233 -- using pragma Export (can't be Import because of the
1234 -- initial value).
1236 if (Is_Volatile (E1) or else Has_Volatile_Components (E1))
1237 and then not Is_Imported (E1)
1238 then
1239 Error_Msg_N
1240 ("?k?& is not modified, consider pragma Export for "
1241 & "volatile variable!", E1);
1243 -- Another special case, Exception_Occurrence, this catches
1244 -- the case of exception choice (and a bit more too, but not
1245 -- worth doing more investigation here).
1247 elsif Is_RTE (E1T, RE_Exception_Occurrence) then
1248 null;
1250 -- Here we give the warning if referenced and no pragma
1251 -- Unreferenced or Unmodified is present.
1253 elsif Referenced (E1)
1254 and then not Has_Unreferenced (E1)
1255 and then not Has_Unmodified (E1)
1256 and then not Warnings_Off_E1
1257 and then not Has_Junk_Name (E1)
1258 then
1259 Error_Msg_N -- CODEFIX
1260 ("?k?& is not modified, could be declared constant!",
1261 E1);
1262 end if;
1264 -- Other cases of a variable or parameter never set in source
1266 elsif Never_Set_In_Source_Check_Spec (E1)
1268 -- No warning if address taken somewhere
1270 and then not Address_Taken (E1)
1272 -- No warning if explicit initial value
1274 and then not Has_Initial_Value (E1)
1276 -- No warning for generic package spec entities, since we
1277 -- might set them in a child unit or something like that
1279 and then not Generic_Package_Spec_Entity (E1)
1281 -- No warning if fully initialized type, except that for
1282 -- this purpose we do not consider access types to qualify
1283 -- as fully initialized types (relying on an access type
1284 -- variable being null when it is never set is a bit odd).
1286 -- Also we generate warning for an out parameter that is
1287 -- never referenced, since again it seems odd to rely on
1288 -- default initialization to set an out parameter value.
1290 and then (Is_Access_Type (E1T)
1291 or else Ekind (E1) = E_Out_Parameter
1292 or else not Is_Fully_Initialized_Type (E1T))
1293 then
1294 -- Do not output complaint about never being assigned a
1295 -- value if a pragma Unmodified applies to the variable
1296 -- we are examining, or if it is a parameter, if there is
1297 -- a pragma Unreferenced for the corresponding spec, or
1298 -- if the type is marked as having unreferenced objects.
1299 -- The last is a little peculiar, but better too few than
1300 -- too many warnings in this situation.
1302 if Has_Pragma_Unreferenced_Objects (E1T)
1303 or else Has_Pragma_Unmodified_Check_Spec (E1)
1304 then
1305 null;
1307 -- IN OUT parameter case where parameter is referenced. We
1308 -- separate this out, since this is the case where we delay
1309 -- output of the warning until more information is available
1310 -- (about use in an instantiation or address being taken).
1312 elsif Ekind (E1) = E_In_Out_Parameter
1313 and then Referenced_Check_Spec (E1)
1314 then
1315 -- Suppress warning if private type, and the procedure
1316 -- has a separate declaration in a different unit. This
1317 -- is the case where the client of a package sees only
1318 -- the private type, and it may be quite reasonable
1319 -- for the logical view to be IN OUT, even if the
1320 -- implementation ends up using access types or some
1321 -- other method to achieve the local effect of a
1322 -- modification. On the other hand if the spec and body
1323 -- are in the same unit, we are in the package body and
1324 -- there we have less excuse for a junk IN OUT parameter.
1326 if Has_Private_Declaration (E1T)
1327 and then Present (Spec_Entity (E1))
1328 and then not In_Same_Source_Unit (E1, Spec_Entity (E1))
1329 then
1330 null;
1332 -- Suppress warning for any parameter of a dispatching
1333 -- operation, since it is quite reasonable to have an
1334 -- operation that is overridden, and for some subclasses
1335 -- needs the formal to be IN OUT and for others happens
1336 -- not to assign it.
1338 elsif Is_Dispatching_Operation
1339 (Scope (Goto_Spec_Entity (E1)))
1340 then
1341 null;
1343 -- Suppress warning if composite type contains any access
1344 -- component, since the logical effect of modifying a
1345 -- parameter may be achieved by modifying a referenced
1346 -- object. This rationale does not apply to private
1347 -- types, so we warn in that case.
1349 elsif Is_Composite_Type (E1T)
1350 and then not Is_Private_Type (E1T)
1351 and then Has_Access_Values (E1T)
1352 then
1353 null;
1355 -- Suppress warning on formals of an entry body. All
1356 -- references are attached to the formal in the entry
1357 -- declaration, which are marked Is_Entry_Formal.
1359 elsif Ekind (Scope (E1)) = E_Entry
1360 and then not Is_Entry_Formal (E1)
1361 then
1362 null;
1364 -- OK, looks like warning for an IN OUT parameter that
1365 -- could be IN makes sense, but we delay the output of
1366 -- the warning, pending possibly finding out later on
1367 -- that the associated subprogram is used as a generic
1368 -- actual, or its address/access is taken. In these two
1369 -- cases, we suppress the warning because the context may
1370 -- force use of IN OUT, even if in this particular case
1371 -- the formal is not modified.
1373 elsif Warn_On_No_Value_Assigned then
1374 -- Suppress the warnings for a junk name
1376 if not Has_Junk_Name (E1) then
1377 In_Out_Warnings.Append (E1);
1378 end if;
1379 end if;
1381 -- Other cases of formals
1383 elsif Is_Formal (E1) then
1384 if not Is_Trivial_Subprogram (Scope (E1)) then
1385 if Referenced_Check_Spec (E1) then
1386 if not Has_Pragma_Unmodified_Check_Spec (E1)
1387 and then not Warnings_Off_E1
1388 and then not Has_Junk_Name (E1)
1389 and then Warn_On_No_Value_Assigned
1390 then
1391 Output_Reference_Error
1392 ("?v?formal parameter& is read but "
1393 & "never assigned!");
1394 end if;
1396 elsif not Has_Pragma_Unreferenced_Check_Spec (E1)
1397 and then not Warnings_Off_E1
1398 and then not Has_Junk_Name (E1)
1399 and then Check_Unreferenced_Formals
1400 then
1401 Output_Reference_Error
1402 ("?f?formal parameter& is not referenced!");
1403 end if;
1404 end if;
1406 -- Case of variable
1408 else
1409 if Referenced (E1) then
1410 if Warn_On_No_Value_Assigned
1411 and then not Has_Unmodified (E1)
1412 and then not Warnings_Off_E1
1413 and then not Has_Junk_Name (E1)
1414 then
1415 if Is_Access_Type (E1T)
1416 or else
1417 not Is_Partially_Initialized_Type (E1T, False)
1418 then
1419 Output_Reference_Error
1420 ("?v?variable& is read but never assigned!");
1421 end if;
1423 May_Need_Initialized_Actual (E1);
1424 end if;
1426 elsif Check_Unreferenced
1427 and then not Has_Unreferenced (E1)
1428 and then not Warnings_Off_E1
1429 and then not Has_Junk_Name (E1)
1430 then
1431 Output_Reference_Error -- CODEFIX
1432 ("?u?variable& is never read and never assigned!");
1433 end if;
1435 -- Deal with special case where this variable is hidden
1436 -- by a loop variable.
1438 if Ekind (E1) = E_Variable
1439 and then Present (Hiding_Loop_Variable (E1))
1440 and then not Warnings_Off_E1
1441 and then Warn_On_Hiding
1442 then
1443 Error_Msg_N
1444 ("?h?for loop implicitly declares loop variable!",
1445 Hiding_Loop_Variable (E1));
1447 Error_Msg_Sloc := Sloc (E1);
1448 Error_Msg_N
1449 ("\?h?declaration hides & declared#!",
1450 Hiding_Loop_Variable (E1));
1451 end if;
1452 end if;
1454 goto Continue;
1455 end if;
1457 -- Check for unset reference. If type of object has
1458 -- preelaborable initialization, warning is misleading.
1460 if Warn_On_No_Value_Assigned
1461 and then Present (UR)
1462 and then not Known_To_Have_Preelab_Init (Etype (E1))
1463 then
1465 -- Don't issue warning if appearing inside Initial_Condition
1466 -- pragma or aspect, since that expression is not evaluated
1467 -- at the point where it occurs in the source.
1469 if In_Pragma_Expression (UR, Name_Initial_Condition) then
1470 goto Continue;
1471 end if;
1473 -- Here we issue the warning, all checks completed
1475 -- If we have a return statement, this was a case of an OUT
1476 -- parameter not being set at the time of the return. (Note:
1477 -- it can't be N_Extended_Return_Statement, because those
1478 -- are only for functions, and functions do not allow OUT
1479 -- parameters.)
1481 if not Is_Trivial_Subprogram (Scope (E1)) then
1482 if Nkind (UR) = N_Simple_Return_Statement
1483 and then not Has_Pragma_Unmodified_Check_Spec (E1)
1484 then
1485 if not Warnings_Off_E1
1486 and then not Has_Junk_Name (E1)
1487 then
1488 Error_Msg_NE
1489 ("?v?OUT parameter& not set before return",
1490 UR, E1);
1491 end if;
1493 -- If the unset reference is a selected component
1494 -- prefix from source, mention the component as well.
1495 -- If the selected component comes from expansion, all
1496 -- we know is that the entity is not fully initialized
1497 -- at the point of the reference. Locate a random
1498 -- uninitialized component to get a better message.
1500 elsif Nkind (Parent (UR)) = N_Selected_Component then
1501 -- Suppress possibly superfluous warning if component
1502 -- is known to exist and is partially initialized.
1504 if not Has_Discriminants (Etype (E1))
1505 and then
1506 Is_Partially_Initialized_Type
1507 (Etype (Parent (UR)), False)
1508 then
1509 goto Continue;
1510 end if;
1512 Error_Msg_Node_2 := Selector_Name (Parent (UR));
1514 if not Comes_From_Source (Parent (UR)) then
1515 declare
1516 Comp : Entity_Id;
1518 begin
1519 Comp := First_Component (E1T);
1520 while Present (Comp) loop
1521 if Nkind (Parent (Comp)) =
1522 N_Component_Declaration
1523 and then No (Expression (Parent (Comp)))
1524 then
1525 Error_Msg_Node_2 := Comp;
1526 exit;
1527 end if;
1529 Next_Component (Comp);
1530 end loop;
1531 end;
1532 end if;
1534 -- Issue proper warning. This is a case of referencing
1535 -- a variable before it has been explicitly assigned.
1536 -- For access types, UR was only set for dereferences,
1537 -- so the issue is that the value may be null.
1539 if not Warnings_Off_E1 then
1540 if Is_Access_Type (Etype (Parent (UR))) then
1541 Error_Msg_N ("??`&.&` may be null!", UR);
1542 else
1543 Error_Msg_N
1544 ("??`&.&` may be referenced before "
1545 & "it has a value!", UR);
1546 end if;
1547 end if;
1549 -- All other cases of unset reference active
1551 elsif not Warnings_Off_E1 then
1552 Error_Msg_N
1553 ("??& may be referenced before it has a value!", UR);
1554 end if;
1555 end if;
1557 goto Continue;
1559 end if;
1560 end if;
1562 -- Then check for unreferenced entities. Note that we are only
1563 -- interested in entities whose Referenced flag is not set.
1565 if not Referenced_Check_Spec (E1)
1567 -- If Referenced_As_LHS is set, then that's still interesting
1568 -- (potential "assigned but never read" case), but not if we
1569 -- have pragma Unreferenced, which cancels this warning.
1571 and then (not Referenced_As_LHS_Check_Spec (E1)
1572 or else not Has_Unreferenced (E1))
1574 -- Check that warnings on unreferenced entities are enabled
1576 and then
1577 ((Check_Unreferenced and then not Is_Formal (E1))
1579 -- Case of warning on unreferenced formal
1581 or else (Check_Unreferenced_Formals and then Is_Formal (E1))
1583 -- Case of warning on unread variables modified by an
1584 -- assignment, or an OUT parameter if it is the only one.
1586 or else (Warn_On_Modified_Unread
1587 and then Referenced_As_LHS_Check_Spec (E1))
1589 -- Case of warning on any unread OUT parameter (note such
1590 -- indications are only set if the appropriate warning
1591 -- options were set, so no need to recheck here.)
1593 or else Referenced_As_Out_Parameter_Check_Spec (E1))
1595 -- All other entities, including local packages that cannot be
1596 -- referenced from elsewhere, including those declared within a
1597 -- package body.
1599 and then (Is_Object (E1)
1600 or else Is_Type (E1)
1601 or else Ekind (E1) = E_Label
1602 or else Ekind (E1) in E_Exception
1603 | E_Named_Integer
1604 | E_Named_Real
1605 or else Is_Overloadable (E1)
1607 -- Package case, if the main unit is a package spec
1608 -- or generic package spec, then there may be a
1609 -- corresponding body that references this package
1610 -- in some other file. Otherwise we can be sure
1611 -- that there is no other reference.
1613 or else
1614 (Ekind (E1) = E_Package
1615 and then
1616 not Is_Package_Or_Generic_Package
1617 (Cunit_Entity (Current_Sem_Unit))))
1619 -- Consider private type referenced if full view is referenced.
1620 -- If there is not full view, this is a generic type on which
1621 -- warnings are also useful.
1623 and then
1624 not (Is_Private_Type (E1)
1625 and then Present (Full_View (E1))
1626 and then Referenced (Full_View (E1)))
1628 -- Don't worry about full view, only about private type
1630 and then not Has_Private_Declaration (E1)
1632 -- Eliminate dispatching operations from consideration, we
1633 -- cannot tell if these are referenced or not in any easy
1634 -- manner (note this also catches Adjust/Finalize/Initialize).
1636 and then not Is_Dispatching_Operation (E1)
1638 -- Check entity that can be publicly referenced (we do not give
1639 -- messages for such entities, since there could be other
1640 -- units, not involved in this compilation, that contain
1641 -- relevant references.
1643 and then not Publicly_Referenceable (E1)
1645 -- Class wide types are marked as source entities, but they are
1646 -- not really source entities, and are always created, so we do
1647 -- not care if they are not referenced.
1649 and then Ekind (E1) /= E_Class_Wide_Type
1651 -- Objects other than parameters of task types are allowed to
1652 -- be non-referenced, since they start up tasks.
1654 and then ((Ekind (E1) /= E_Variable
1655 and then Ekind (E1) /= E_Constant
1656 and then Ekind (E1) /= E_Component)
1658 -- Check that E1T is not a task or a composite type
1659 -- with a task component.
1661 or else not Has_Task (E1T))
1663 -- For subunits, only place warnings on the main unit itself,
1664 -- since parent units are not completely compiled.
1666 and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
1667 or else Get_Source_Unit (E1) = Main_Unit)
1669 -- No warning on a return object, because these are often
1670 -- created with a single expression and an implicit return.
1671 -- If the object is a variable there will be a warning
1672 -- indicating that it could be declared constant.
1674 and then not
1675 (Ekind (E1) = E_Constant and then Is_Return_Object (E1))
1676 then
1677 -- Suppress warnings in internal units if not in -gnatg mode
1678 -- (these would be junk warnings for an applications program,
1679 -- since they refer to problems in internal units).
1681 if GNAT_Mode or else not In_Internal_Unit (E1) then
1682 -- We do not immediately flag the error. This is because we
1683 -- have not expanded generic bodies yet, and they may have
1684 -- the missing reference. So instead we park the entity on a
1685 -- list, for later processing. However for the case of an
1686 -- accept statement we want to output messages now, since
1687 -- we know we already have all information at hand, and we
1688 -- also want to have separate warnings for each accept
1689 -- statement for the same entry.
1691 if Present (Anod) then
1692 pragma Assert (Is_Formal (E1));
1694 -- The unreferenced entity is E1, but post the warning
1695 -- on the body entity for this accept statement.
1697 if not Warnings_Off_E1 then
1698 Warn_On_Unreferenced_Entity
1699 (E1, Body_Formal (E1, Accept_Statement => Anod));
1700 end if;
1702 elsif not Warnings_Off_E1
1703 and then not Has_Junk_Name (E1)
1704 then
1705 if Is_Formal (E1)
1706 and then Nkind (Unit_Declaration_Node (Scope (E1)))
1707 = N_Generic_Subprogram_Declaration
1708 then
1709 Unreferenced_Entities.Append
1710 (Generic_Body_Formal (E1));
1711 else
1712 Unreferenced_Entities.Append (E1);
1713 end if;
1714 end if;
1715 end if;
1717 -- Generic units are referenced in the generic body, but if they
1718 -- are not public and never instantiated we want to force a
1719 -- warning on them. We treat them as redundant constructs to
1720 -- minimize noise.
1722 elsif Is_Generic_Subprogram (E1)
1723 and then not Is_Instantiated (E1)
1724 and then not Publicly_Referenceable (E1)
1725 and then Warn_On_Redundant_Constructs
1726 then
1727 if not Warnings_Off_E1 and then not Has_Junk_Name (E1) then
1728 Unreferenced_Entities.Append (E1);
1730 -- Force warning on entity
1732 Set_Referenced (E1, False);
1733 end if;
1734 end if;
1735 end if;
1737 -- Recurse into nested package or block. Do not recurse into a formal
1738 -- package, because the corresponding body is not analyzed.
1740 <<Continue>>
1741 if (Is_Package_Or_Generic_Package (E1)
1742 and then Nkind (Parent (E1)) = N_Package_Specification
1743 and then
1744 Nkind (Original_Node (Unit_Declaration_Node (E1))) /=
1745 N_Formal_Package_Declaration)
1747 or else Ekind (E1) = E_Block
1748 then
1749 Check_References (E1);
1750 end if;
1752 Next_Entity (E1);
1753 end loop;
1754 end Check_References;
1756 ---------------------------
1757 -- Check_Unset_Reference --
1758 ---------------------------
1760 procedure Check_Unset_Reference (N : Node_Id) is
1761 Typ : constant Entity_Id := Etype (N);
1763 function Is_OK_Fully_Initialized return Boolean;
1764 -- This function returns true if the given node N is fully initialized
1765 -- so that the reference is safe as far as this routine is concerned.
1766 -- Safe generally means that the type of N is a fully initialized type.
1767 -- The one special case is that for access types, which are always fully
1768 -- initialized, we don't consider a dereference OK since it will surely
1769 -- be dereferencing a null value, which won't do.
1771 function Prefix_Has_Dereference (Pref : Node_Id) return Boolean;
1772 -- Used to test indexed or selected component or slice to see if the
1773 -- evaluation of the prefix depends on a dereference, and if so, returns
1774 -- True, in which case we always check the prefix, even if we know that
1775 -- the referenced component is initialized. Pref is the prefix to test.
1777 -----------------------------
1778 -- Is_OK_Fully_Initialized --
1779 -----------------------------
1781 function Is_OK_Fully_Initialized return Boolean is
1782 begin
1783 if Is_Access_Type (Typ) and then Is_Dereferenced (N) then
1784 return False;
1786 -- A type subject to pragma Default_Initial_Condition may be fully
1787 -- default initialized depending on inheritance and the argument of
1788 -- the pragma (SPARK RM 3.1 and SPARK RM 7.3.3).
1790 elsif Has_Fully_Default_Initializing_DIC_Pragma (Typ) then
1791 return True;
1793 else
1794 return Is_Fully_Initialized_Type (Typ);
1795 end if;
1796 end Is_OK_Fully_Initialized;
1798 ----------------------------
1799 -- Prefix_Has_Dereference --
1800 ----------------------------
1802 function Prefix_Has_Dereference (Pref : Node_Id) return Boolean is
1803 begin
1804 -- If prefix is of an access type, it certainly needs a dereference
1806 if Is_Access_Type (Etype (Pref)) then
1807 return True;
1809 -- If prefix is explicit dereference, that's a dereference for sure
1811 elsif Nkind (Pref) = N_Explicit_Dereference then
1812 return True;
1814 -- If prefix is itself a component reference or slice check prefix
1816 elsif Nkind (Pref) = N_Slice
1817 or else Nkind (Pref) = N_Indexed_Component
1818 or else Nkind (Pref) = N_Selected_Component
1819 then
1820 return Prefix_Has_Dereference (Prefix (Pref));
1822 -- All other cases do not involve a dereference
1824 else
1825 return False;
1826 end if;
1827 end Prefix_Has_Dereference;
1829 -- Start of processing for Check_Unset_Reference
1831 begin
1832 -- Nothing to do if warnings suppressed
1834 if Warning_Mode = Suppress then
1835 return;
1836 end if;
1838 -- Ignore reference unless it comes from source. Almost always if we
1839 -- have a reference from generated code, it is bogus (e.g. calls to init
1840 -- procs to set default discriminant values).
1842 if not Comes_From_Source (Original_Node (N)) then
1843 return;
1844 end if;
1846 -- Otherwise see what kind of node we have. If the entity already has an
1847 -- unset reference, it is not necessarily the earliest in the text,
1848 -- because resolution of the prefix of selected components is completed
1849 -- before the resolution of the selected component itself. As a result,
1850 -- given (R /= null and then R.X > 0), the occurrences of R are examined
1851 -- in right-to-left order. If there is already an unset reference, we
1852 -- check whether N is earlier before proceeding.
1854 case Nkind (N) is
1856 -- For identifier or expanded name, examine the entity involved
1858 when N_Expanded_Name
1859 | N_Identifier
1861 declare
1862 E : constant Entity_Id := Entity (N);
1864 begin
1865 if Ekind (E) in E_Variable | E_Out_Parameter
1866 and then Never_Set_In_Source_Check_Spec (E)
1867 and then not Has_Initial_Value (E)
1868 and then (No (Unset_Reference (E))
1869 or else
1870 Earlier_In_Extended_Unit
1871 (N, Unset_Reference (E)))
1872 and then not Has_Pragma_Unmodified_Check_Spec (E)
1873 and then not Warnings_Off_Check_Spec (E)
1874 and then not Has_Junk_Name (E)
1875 then
1876 -- We may have an unset reference. The first test is whether
1877 -- this is an access to a discriminant of a record or a
1878 -- component with default initialization. Both of these
1879 -- cases can be ignored, since the actual object that is
1880 -- referenced is definitely initialized. Note that this
1881 -- covers the case of reading discriminants of an OUT
1882 -- parameter, which is OK even in Ada 83.
1884 -- Note that we are only interested in a direct reference to
1885 -- a record component here. If the reference is through an
1886 -- access type, then the access object is being referenced,
1887 -- not the record, and still deserves an unset reference.
1889 if Nkind (Parent (N)) = N_Selected_Component
1890 and not Is_Access_Type (Typ)
1891 then
1892 declare
1893 ES : constant Entity_Id :=
1894 Entity (Selector_Name (Parent (N)));
1895 begin
1896 if Ekind (ES) = E_Discriminant
1897 or else
1898 (Present (Declaration_Node (ES))
1899 and then
1900 Present (Expression (Declaration_Node (ES))))
1901 then
1902 return;
1903 end if;
1904 end;
1905 end if;
1907 -- Exclude fully initialized types
1909 if Is_OK_Fully_Initialized then
1910 return;
1911 end if;
1913 -- Here we have a potential unset reference. But before we
1914 -- get worried about it, we have to make sure that the
1915 -- entity declaration is in the same procedure as the
1916 -- reference, since if they are in separate procedures, then
1917 -- we have no idea about sequential execution.
1919 -- The tests in the loop below catch all such cases, but do
1920 -- allow the reference to appear in a loop, block, or
1921 -- package spec that is nested within the declaring scope.
1922 -- As always, it is possible to construct cases where the
1923 -- warning is wrong, that is why it is a warning.
1925 Potential_Unset_Reference : declare
1926 SR : Entity_Id;
1927 SE : constant Entity_Id := Scope (E);
1929 function Within_Postcondition return Boolean;
1930 -- Returns True if N is within a Postcondition, a
1931 -- Refined_Post, an Ensures component in a Test_Case,
1932 -- or a Contract_Cases.
1934 --------------------------
1935 -- Within_Postcondition --
1936 --------------------------
1938 function Within_Postcondition return Boolean is
1939 Nod, P : Node_Id;
1941 begin
1942 Nod := Parent (N);
1943 while Present (Nod) loop
1944 if Nkind (Nod) = N_Pragma
1945 and then
1946 Pragma_Name_Unmapped (Nod)
1947 in Name_Postcondition
1948 | Name_Refined_Post
1949 | Name_Contract_Cases
1950 then
1951 return True;
1953 elsif Present (Parent (Nod)) then
1954 P := Parent (Nod);
1956 if Nkind (P) = N_Pragma
1957 and then Pragma_Name (P) = Name_Test_Case
1958 and then Nod = Test_Case_Arg (P, Name_Ensures)
1959 then
1960 return True;
1961 end if;
1963 -- Prevent the search from going too far
1965 elsif Is_Body_Or_Package_Declaration (Nod) then
1966 exit;
1967 end if;
1969 Nod := Parent (Nod);
1970 end loop;
1972 return False;
1973 end Within_Postcondition;
1975 -- Start of processing for Potential_Unset_Reference
1977 begin
1978 SR := Current_Scope;
1979 while SR /= SE loop
1980 if SR = Standard_Standard
1981 or else Is_Subprogram (SR)
1982 or else Is_Concurrent_Body (SR)
1983 or else Is_Concurrent_Type (SR)
1984 then
1985 return;
1986 end if;
1988 SR := Scope (SR);
1989 end loop;
1991 -- Case of reference has an access type. This is a
1992 -- special case since access types are always set to null
1993 -- so cannot be truly uninitialized, but we still want to
1994 -- warn about cases of obvious null dereference.
1996 if Is_Access_Type (Typ) then
1997 Access_Type_Case : declare
1998 P : Node_Id;
2000 function Process
2001 (N : Node_Id) return Traverse_Result;
2002 -- Process function for instantiation of Traverse
2003 -- below. Checks if N contains reference to E other
2004 -- than a dereference.
2006 function Ref_In (Nod : Node_Id) return Boolean;
2007 -- Determines whether Nod contains a reference to
2008 -- the entity E that is not a dereference.
2010 -------------
2011 -- Process --
2012 -------------
2014 function Process
2015 (N : Node_Id) return Traverse_Result
2017 begin
2018 if Is_Entity_Name (N)
2019 and then Entity (N) = E
2020 and then not Is_Dereferenced (N)
2021 then
2022 return Abandon;
2023 else
2024 return OK;
2025 end if;
2026 end Process;
2028 ------------
2029 -- Ref_In --
2030 ------------
2032 function Ref_In (Nod : Node_Id) return Boolean is
2033 function Traverse is new Traverse_Func (Process);
2034 begin
2035 return Traverse (Nod) = Abandon;
2036 end Ref_In;
2038 -- Start of processing for Access_Type_Case
2040 begin
2041 -- Don't bother if we are inside an instance, since
2042 -- the compilation of the generic template is where
2043 -- the warning should be issued.
2045 if In_Instance then
2046 return;
2047 end if;
2049 -- Don't bother if this is not the main unit. If we
2050 -- try to give this warning for with'ed units, we
2051 -- get some false positives, since we do not record
2052 -- references in other units.
2054 if not In_Extended_Main_Source_Unit (E)
2055 or else
2056 not In_Extended_Main_Source_Unit (N)
2057 then
2058 return;
2059 end if;
2061 -- We are only interested in dereferences
2063 if not Is_Dereferenced (N) then
2064 return;
2065 end if;
2067 -- One more check, don't bother with references
2068 -- that are inside conditional statements or WHILE
2069 -- loops if the condition references the entity in
2070 -- question. This avoids most false positives.
2072 P := Parent (N);
2073 loop
2074 P := Parent (P);
2075 exit when No (P);
2077 if Nkind (P) in N_If_Statement | N_Elsif_Part
2078 and then Ref_In (Condition (P))
2079 then
2080 return;
2082 elsif Nkind (P) = N_Loop_Statement
2083 and then Present (Iteration_Scheme (P))
2084 and then
2085 Ref_In (Condition (Iteration_Scheme (P)))
2086 then
2087 return;
2088 end if;
2089 end loop;
2090 end Access_Type_Case;
2091 end if;
2093 -- One more check, don't bother if we are within a
2094 -- postcondition, since the expression occurs in a
2095 -- place unrelated to the actual test.
2097 if not Within_Postcondition then
2099 -- Here we definitely have a case for giving a warning
2100 -- for a reference to an unset value. But we don't
2101 -- give the warning now. Instead set Unset_Reference
2102 -- in the identifier involved. The reason for this is
2103 -- that if we find the variable is never ever assigned
2104 -- a value then that warning is more important and
2105 -- there is no point in giving the reference warning.
2107 -- If this is an identifier, set the field directly
2109 if Nkind (N) = N_Identifier then
2110 Set_Unset_Reference (E, N);
2112 -- Otherwise it is an expanded name, so set the field
2113 -- of the actual identifier for the reference.
2115 else
2116 Set_Unset_Reference (E, Selector_Name (N));
2117 end if;
2118 end if;
2119 end Potential_Unset_Reference;
2120 end if;
2121 end;
2123 -- Indexed component or slice
2125 when N_Indexed_Component
2126 | N_Slice
2128 -- If prefix does not involve dereferencing an access type, then
2129 -- we know we are OK if the component type is fully initialized,
2130 -- since the component will have been set as part of the default
2131 -- initialization.
2133 if not Prefix_Has_Dereference (Prefix (N))
2134 and then Is_OK_Fully_Initialized
2135 then
2136 return;
2138 -- Look at prefix in access type case, or if the component is not
2139 -- fully initialized.
2141 else
2142 Check_Unset_Reference (Prefix (N));
2143 end if;
2145 -- Record component
2147 when N_Selected_Component =>
2148 declare
2149 Pref : constant Node_Id := Prefix (N);
2150 Ent : constant Entity_Id := Entity (Selector_Name (N));
2152 begin
2153 -- If prefix involves dereferencing an access type, always
2154 -- check the prefix, since the issue then is whether this
2155 -- access value is null.
2157 if Prefix_Has_Dereference (Pref) then
2158 null;
2160 -- Always go to prefix if no selector entity is set. Can this
2161 -- happen in the normal case? Not clear, but it definitely can
2162 -- happen in error cases.
2164 elsif No (Ent) then
2165 null;
2167 -- For a record component, check some cases where we have
2168 -- reasonable cause to consider that the component is known to
2169 -- be or probably is initialized. In this case, we don't care
2170 -- if the prefix itself was explicitly initialized.
2172 -- Discriminants are always considered initialized
2174 elsif Ekind (Ent) = E_Discriminant then
2175 return;
2177 -- An explicitly initialized component is certainly initialized
2179 elsif Nkind (Parent (Ent)) = N_Component_Declaration
2180 and then Present (Expression (Parent (Ent)))
2181 then
2182 return;
2184 -- A fully initialized component is initialized
2186 elsif Is_OK_Fully_Initialized then
2187 return;
2188 end if;
2190 -- If none of those cases apply, check the record type prefix
2192 Check_Unset_Reference (Pref);
2193 end;
2195 -- Type conversions can appear in assignment statements both
2196 -- as variable names and as expressions. We examine their own
2197 -- expressions only when processing their parent node.
2199 when N_Type_Conversion =>
2200 Check_Unset_Reference (Expression (N));
2202 -- For explicit dereference, always check prefix, which will generate
2203 -- an unset reference (since this is a case of dereferencing null).
2205 when N_Explicit_Dereference =>
2206 Check_Unset_Reference (Prefix (N));
2208 -- All other cases are not cases of an unset reference
2210 when others =>
2211 null;
2212 end case;
2213 end Check_Unset_Reference;
2215 ------------------------
2216 -- Check_Unused_Withs --
2217 ------------------------
2219 procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit) is
2221 Munite : constant Entity_Id := Cunit_Entity (Main_Unit);
2222 -- This is needed for checking the special renaming case
2224 procedure Check_One_Unit (Unit : Unit_Number_Type);
2225 -- Subsidiary procedure, performs checks for specified unit
2227 --------------------
2228 -- Check_One_Unit --
2229 --------------------
2231 procedure Check_One_Unit (Unit : Unit_Number_Type) is
2232 Cnode : constant Node_Id := Cunit (Unit);
2234 Is_Visible_Renaming : Boolean := False;
2236 procedure Check_Inner_Package (Pack : Entity_Id);
2237 -- Pack is a package local to a unit in a with_clause. Both the unit
2238 -- and Pack are referenced. If none of the entities in Pack are
2239 -- referenced, then the only occurrence of Pack is in a USE clause
2240 -- or a pragma, and a warning is worthwhile as well.
2242 function Check_System_Aux (Lunit : Entity_Id) return Boolean;
2243 -- Before giving a warning on a with_clause for System, check whether
2244 -- a system extension is present.
2246 function Find_Package_Renaming
2247 (P : Entity_Id;
2248 L : Entity_Id) return Entity_Id;
2249 -- The only reference to a context unit may be in a renaming
2250 -- declaration. If this renaming declares a visible entity, do not
2251 -- warn that the context clause could be moved to the body, because
2252 -- the renaming may be intended to re-export the unit.
2254 function Has_Visible_Entities (P : Entity_Id) return Boolean;
2255 -- This function determines if a package has any visible entities.
2256 -- True is returned if there is at least one declared visible entity,
2257 -- otherwise False is returned (e.g. case of only pragmas present).
2259 -------------------------
2260 -- Check_Inner_Package --
2261 -------------------------
2263 procedure Check_Inner_Package (Pack : Entity_Id) is
2264 E : Entity_Id;
2265 Un : constant Node_Id := Sinfo.Nodes.Unit (Cnode);
2267 function Check_Use_Clause (N : Node_Id) return Traverse_Result;
2268 -- If N is a use_clause for Pack, emit warning
2270 procedure Check_Use_Clauses is new
2271 Traverse_Proc (Check_Use_Clause);
2273 ----------------------
2274 -- Check_Use_Clause --
2275 ----------------------
2277 function Check_Use_Clause (N : Node_Id) return Traverse_Result is
2278 begin
2279 if Nkind (N) = N_Use_Package_Clause
2280 and then Entity (Name (N)) = Pack
2281 then
2282 -- Suppress message if any serious errors detected that turn
2283 -- off expansion, and thus result in false positives for
2284 -- this warning.
2286 if Serious_Errors_Detected = 0 then
2287 Error_Msg_Qual_Level := 1;
2288 Error_Msg_NE -- CODEFIX
2289 ("?u?no entities of package& are referenced!",
2290 Name (N), Pack);
2291 Error_Msg_Qual_Level := 0;
2292 end if;
2293 end if;
2295 return OK;
2296 end Check_Use_Clause;
2298 -- Start of processing for Check_Inner_Package
2300 begin
2301 E := First_Entity (Pack);
2302 while Present (E) loop
2303 if Referenced_Check_Spec (E) then
2304 return;
2305 end if;
2307 Next_Entity (E);
2308 end loop;
2310 -- No entities of the package are referenced. Check whether the
2311 -- reference to the package itself is a use clause, and if so
2312 -- place a warning on it.
2314 Check_Use_Clauses (Un);
2315 end Check_Inner_Package;
2317 ----------------------
2318 -- Check_System_Aux --
2319 ----------------------
2321 function Check_System_Aux (Lunit : Entity_Id) return Boolean is
2322 Ent : Entity_Id;
2324 begin
2325 if Chars (Lunit) = Name_System
2326 and then Scope (Lunit) = Standard_Standard
2327 and then Present_System_Aux
2328 then
2329 Ent := First_Entity (System_Aux_Id);
2330 while Present (Ent) loop
2331 if Referenced_Check_Spec (Ent) then
2332 return True;
2333 end if;
2335 Next_Entity (Ent);
2336 end loop;
2337 end if;
2339 return False;
2340 end Check_System_Aux;
2342 ---------------------------
2343 -- Find_Package_Renaming --
2344 ---------------------------
2346 function Find_Package_Renaming
2347 (P : Entity_Id;
2348 L : Entity_Id) return Entity_Id
2350 E1 : Entity_Id;
2351 R : Entity_Id;
2353 begin
2354 Is_Visible_Renaming := False;
2356 E1 := First_Entity (P);
2357 while Present (E1) loop
2358 if Ekind (E1) = E_Package and then Renamed_Entity (E1) = L then
2359 Is_Visible_Renaming := not Is_Hidden (E1);
2360 return E1;
2362 elsif Ekind (E1) = E_Package
2363 and then No (Renamed_Entity (E1))
2364 and then not Is_Generic_Instance (E1)
2365 then
2366 R := Find_Package_Renaming (E1, L);
2368 if Present (R) then
2369 Is_Visible_Renaming := not Is_Hidden (R);
2370 return R;
2371 end if;
2372 end if;
2374 Next_Entity (E1);
2375 end loop;
2377 return Empty;
2378 end Find_Package_Renaming;
2380 --------------------------
2381 -- Has_Visible_Entities --
2382 --------------------------
2384 function Has_Visible_Entities (P : Entity_Id) return Boolean is
2385 E : Entity_Id;
2387 begin
2388 -- If unit in context is not a package, it is a subprogram that
2389 -- is not called or a generic unit that is not instantiated
2390 -- in the current unit, and warning is appropriate.
2392 if Ekind (P) /= E_Package then
2393 return True;
2394 end if;
2396 -- If unit comes from a limited_with clause, look for declaration
2397 -- of shadow entities.
2399 if Present (Limited_View (P)) then
2400 E := First_Entity (Limited_View (P));
2401 else
2402 E := First_Entity (P);
2403 end if;
2405 while Present (E) and then E /= First_Private_Entity (P) loop
2406 if Comes_From_Source (E) or else Present (Limited_View (P)) then
2407 return True;
2408 end if;
2410 Next_Entity (E);
2411 end loop;
2413 return False;
2414 end Has_Visible_Entities;
2416 -- Local variables
2418 Ent : Entity_Id;
2419 Item : Node_Id;
2420 Lunit : Entity_Id;
2421 Pack : Entity_Id;
2423 -- Start of processing for Check_One_Unit
2425 begin
2426 -- Only do check in units that are part of the extended main unit.
2427 -- This is actually a necessary restriction, because in the case of
2428 -- subprogram acting as its own specification, there can be with's in
2429 -- subunits that we will not see.
2431 if not In_Extended_Main_Source_Unit (Cnode) then
2432 return;
2433 end if;
2435 -- Loop through context items in this unit
2437 Item := First (Context_Items (Cnode));
2438 while Present (Item) loop
2439 if Nkind (Item) = N_With_Clause
2440 and then not Implicit_With (Item)
2441 and then In_Extended_Main_Source_Unit (Item)
2443 -- Guard for no entity present. Not clear under what conditions
2444 -- this happens, but it does occur, and since this is only a
2445 -- warning, we just suppress the warning in this case.
2447 and then Nkind (Name (Item)) in N_Has_Entity
2448 and then Present (Entity (Name (Item)))
2449 then
2450 Lunit := Entity (Name (Item));
2452 -- Check if this unit is referenced (skip the check if this
2453 -- is explicitly marked by a pragma Unreferenced).
2455 if not Referenced (Lunit) and then not Has_Unreferenced (Lunit)
2456 then
2457 -- Suppress warnings in internal units if not in -gnatg mode
2458 -- (these would be junk warnings for an application program,
2459 -- since they refer to problems in internal units).
2461 if GNAT_Mode or else not Is_Internal_Unit (Unit) then
2462 -- Here we definitely have a non-referenced unit. If it
2463 -- is the special call for a spec unit, then just set the
2464 -- flag to be read later.
2466 if Unit = Spec_Unit then
2467 Set_Unreferenced_In_Spec (Item);
2469 -- Otherwise simple unreferenced message, but skip this
2470 -- if no visible entities, because that is most likely a
2471 -- case where warning would be false positive (e.g. a
2472 -- package with only a linker options pragma and nothing
2473 -- else or a pragma elaborate with a body library task).
2475 elsif Has_Visible_Entities (Lunit) then
2476 Error_Msg_N -- CODEFIX
2477 ("?u?unit& is not referenced!", Name (Item));
2478 end if;
2479 end if;
2481 -- If main unit is a renaming of this unit, then we consider
2482 -- the with to be OK (obviously it is needed in this case).
2483 -- This may be transitive: the unit in the with_clause may
2484 -- itself be a renaming, in which case both it and the main
2485 -- unit rename the same ultimate package.
2487 elsif Present (Renamed_Entity (Munite))
2488 and then
2489 (Renamed_Entity (Munite) = Lunit
2490 or else Renamed_Entity (Munite) = Renamed_Entity (Lunit))
2491 then
2492 null;
2494 -- If this unit is referenced, and it is a package, we do
2495 -- another test, to see if any of the entities in the package
2496 -- are referenced. If none of the entities are referenced, we
2497 -- still post a warning. This occurs if the only use of the
2498 -- package is in a use clause, or in a package renaming
2499 -- declaration. This check is skipped for packages that are
2500 -- renamed in a spec, since the entities in such a package are
2501 -- visible to clients via the renaming.
2503 elsif Ekind (Lunit) = E_Package
2504 and then not Renamed_In_Spec (Lunit)
2505 then
2506 -- If Is_Instantiated is set, it means that the package is
2507 -- implicitly instantiated (this is the case of parent
2508 -- instance or an actual for a generic package formal), and
2509 -- this counts as a reference.
2511 if Is_Instantiated (Lunit) then
2512 null;
2514 -- If no entities in package, and there is a pragma
2515 -- Elaborate_Body present, then assume that this with is
2516 -- done for purposes of this elaboration.
2518 elsif No (First_Entity (Lunit))
2519 and then Has_Pragma_Elaborate_Body (Lunit)
2520 then
2521 null;
2523 -- Otherwise see if any entities have been referenced
2525 else
2526 if Limited_Present (Item) then
2527 Ent := First_Entity (Limited_View (Lunit));
2528 else
2529 Ent := First_Entity (Lunit);
2530 end if;
2532 loop
2533 -- No more entities, and we did not find one that was
2534 -- referenced. Means we have a definite case of a with
2535 -- none of whose entities was referenced.
2537 if No (Ent) then
2539 -- If in spec, just set the flag
2541 if Unit = Spec_Unit then
2542 Set_No_Entities_Ref_In_Spec (Item);
2544 elsif Check_System_Aux (Lunit) then
2545 null;
2547 -- Else the warning may be needed
2549 else
2550 -- Warn if we unreferenced flag set and we have
2551 -- not had serious errors. The reason we inhibit
2552 -- the message if there are errors is to prevent
2553 -- false positives from disabling expansion.
2555 if not Has_Unreferenced (Lunit)
2556 and then Serious_Errors_Detected = 0
2557 then
2558 -- Get possible package renaming
2560 Pack := Find_Package_Renaming (Munite, Lunit);
2562 -- No warning if either the package or its
2563 -- renaming is used as a generic actual.
2565 if Used_As_Generic_Actual (Lunit)
2566 or else
2567 (Present (Pack)
2568 and then
2569 Used_As_Generic_Actual (Pack))
2570 then
2571 exit;
2572 end if;
2574 -- Here we give the warning
2576 Error_Msg_N -- CODEFIX
2577 ("?u?no entities of & are referenced!",
2578 Name (Item));
2580 -- Flag renaming of package as well. If
2581 -- the original package has warnings off,
2582 -- we suppress the warning on the renaming
2583 -- as well.
2585 if Present (Pack)
2586 and then not Has_Warnings_Off (Lunit)
2587 and then not Has_Unreferenced (Pack)
2588 then
2589 Error_Msg_NE -- CODEFIX
2590 ("?u?no entities of& are referenced!",
2591 Unit_Declaration_Node (Pack), Pack);
2592 end if;
2593 end if;
2594 end if;
2596 exit;
2598 -- Case of entity being referenced. The reference may
2599 -- come from a limited_with_clause, in which case the
2600 -- limited view of the entity carries the flag.
2602 elsif Referenced_Check_Spec (Ent)
2603 or else Referenced_As_LHS_Check_Spec (Ent)
2604 or else Referenced_As_Out_Parameter_Check_Spec (Ent)
2605 or else
2606 (From_Limited_With (Ent)
2607 and then Is_Incomplete_Type (Ent)
2608 and then Present (Non_Limited_View (Ent))
2609 and then Referenced (Non_Limited_View (Ent)))
2610 then
2611 -- This means that the with is indeed fine, in that
2612 -- it is definitely needed somewhere, and we can
2613 -- quit worrying about this one...
2615 -- Except for one little detail: if either of the
2616 -- flags was set during spec processing, this is
2617 -- where we complain that the with could be moved
2618 -- from the spec. If the spec contains a visible
2619 -- renaming of the package, inhibit warning to move
2620 -- with_clause to body.
2622 if Ekind (Munite) = E_Package_Body then
2623 Pack :=
2624 Find_Package_Renaming
2625 (Spec_Entity (Munite), Lunit);
2626 else
2627 Pack := Empty;
2628 end if;
2630 -- If a renaming is present in the spec do not warn
2631 -- because the body or child unit may depend on it.
2633 if Present (Pack)
2634 and then Renamed_Entity (Pack) = Lunit
2635 then
2636 exit;
2638 elsif Unreferenced_In_Spec (Item) then
2639 Error_Msg_N -- CODEFIX
2640 ("?u?unit& is not referenced in spec!",
2641 Name (Item));
2643 elsif No_Entities_Ref_In_Spec (Item) then
2644 Error_Msg_N -- CODEFIX
2645 ("?u?no entities of & are referenced in spec!",
2646 Name (Item));
2648 else
2649 if Ekind (Ent) = E_Package then
2650 Check_Inner_Package (Ent);
2651 end if;
2653 exit;
2654 end if;
2656 if not Is_Visible_Renaming then
2657 Error_Msg_N -- CODEFIX
2658 ("\?u?with clause might be moved to body!",
2659 Name (Item));
2660 end if;
2662 exit;
2664 -- Move to next entity to continue search
2666 else
2667 Next_Entity (Ent);
2668 end if;
2669 end loop;
2670 end if;
2672 -- For a generic package, the only interesting kind of
2673 -- reference is an instantiation, since entities cannot be
2674 -- referenced directly.
2676 elsif Is_Generic_Unit (Lunit) then
2678 -- Unit was never instantiated, set flag for case of spec
2679 -- call, or give warning for normal call.
2681 if not Is_Instantiated (Lunit) then
2682 if Unit = Spec_Unit then
2683 Set_Unreferenced_In_Spec (Item);
2684 else
2685 Error_Msg_N -- CODEFIX
2686 ("?u?unit& is never instantiated!", Name (Item));
2687 end if;
2689 -- If unit was indeed instantiated, make sure that flag is
2690 -- not set showing it was uninstantiated in the spec, and if
2691 -- so, give warning.
2693 elsif Unreferenced_In_Spec (Item) then
2694 Error_Msg_N
2695 ("?u?unit& is not instantiated in spec!", Name (Item));
2696 Error_Msg_N -- CODEFIX
2697 ("\?u?with clause can be moved to body!", Name (Item));
2698 end if;
2699 end if;
2700 end if;
2702 Next (Item);
2703 end loop;
2704 end Check_One_Unit;
2706 -- Start of processing for Check_Unused_Withs
2708 begin
2709 -- Immediate return if no semantics or warning flag not set
2711 if not Check_Withs or else Operating_Mode = Check_Syntax then
2712 return;
2713 end if;
2715 -- Flag any unused with clauses. For a subunit, check only the units
2716 -- in its context, not those of the parent, which may be needed by other
2717 -- subunits. We will get the full warnings when we compile the parent,
2718 -- but the following is helpful when compiling a subunit by itself.
2720 if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then
2721 if Current_Sem_Unit = Main_Unit then
2722 Check_One_Unit (Main_Unit);
2723 end if;
2725 return;
2726 end if;
2728 -- Process specified units
2730 if Spec_Unit = No_Unit then
2732 -- For main call, check all units
2734 for Unit in Main_Unit .. Last_Unit loop
2735 Check_One_Unit (Unit);
2736 end loop;
2738 else
2739 -- For call for spec, check only the spec
2741 Check_One_Unit (Spec_Unit);
2742 end if;
2743 end Check_Unused_Withs;
2745 ---------------------------------
2746 -- Generic_Package_Spec_Entity --
2747 ---------------------------------
2749 function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean is
2750 S : Entity_Id;
2752 begin
2753 if Is_Package_Body_Entity (E) then
2754 return False;
2756 else
2757 S := Scope (E);
2758 loop
2759 if S = Standard_Standard then
2760 return False;
2762 elsif Ekind (S) = E_Generic_Package then
2763 return True;
2765 elsif Ekind (S) = E_Package then
2766 S := Scope (S);
2768 else
2769 return False;
2770 end if;
2771 end loop;
2772 end if;
2773 end Generic_Package_Spec_Entity;
2775 ----------------------
2776 -- Goto_Spec_Entity --
2777 ----------------------
2779 function Goto_Spec_Entity (E : Entity_Id) return Entity_Id is
2780 begin
2781 if Is_Formal (E) and then Present (Spec_Entity (E)) then
2782 return Spec_Entity (E);
2783 else
2784 return E;
2785 end if;
2786 end Goto_Spec_Entity;
2788 -------------------
2789 -- Has_Junk_Name --
2790 -------------------
2792 function Has_Junk_Name (E : Entity_Id) return Boolean is
2793 function Match (S : String) return Boolean;
2794 -- Return true if substring S is found in Name_Buffer (1 .. Name_Len)
2796 -----------
2797 -- Match --
2798 -----------
2800 function Match (S : String) return Boolean is
2801 Slen1 : constant Integer := S'Length - 1;
2803 begin
2804 for J in 1 .. Name_Len - S'Length + 1 loop
2805 if Name_Buffer (J .. J + Slen1) = S then
2806 return True;
2807 end if;
2808 end loop;
2810 return False;
2811 end Match;
2813 -- Start of processing for Has_Junk_Name
2815 begin
2816 Get_Unqualified_Decoded_Name_String (Chars (E));
2818 return
2819 Match ("discard") or else
2820 Match ("dummy") or else
2821 Match ("ignore") or else
2822 Match ("junk") or else
2823 Match ("unuse") or else
2824 Match ("tmp") or else
2825 Match ("temp");
2826 end Has_Junk_Name;
2828 --------------------------------------
2829 -- Has_Pragma_Unmodified_Check_Spec --
2830 --------------------------------------
2832 function Has_Pragma_Unmodified_Check_Spec
2833 (E : Entity_Id) return Boolean
2835 begin
2836 if Is_Formal (E) and then Present (Spec_Entity (E)) then
2838 -- Note: use of OR instead of OR ELSE here is deliberate, we want
2839 -- to mess with Unmodified flags on both body and spec entities.
2840 -- Has_Unmodified has side effects!
2842 return Has_Unmodified (E)
2844 Has_Unmodified (Spec_Entity (E));
2846 else
2847 return Has_Unmodified (E);
2848 end if;
2849 end Has_Pragma_Unmodified_Check_Spec;
2851 ----------------------------------------
2852 -- Has_Pragma_Unreferenced_Check_Spec --
2853 ----------------------------------------
2855 function Has_Pragma_Unreferenced_Check_Spec
2856 (E : Entity_Id) return Boolean
2858 begin
2859 if Is_Formal (E) and then Present (Spec_Entity (E)) then
2861 -- Note: use of OR here instead of OR ELSE is deliberate, we want
2862 -- to mess with flags on both entities.
2864 return Has_Unreferenced (E)
2866 Has_Unreferenced (Spec_Entity (E));
2868 else
2869 return Has_Unreferenced (E);
2870 end if;
2871 end Has_Pragma_Unreferenced_Check_Spec;
2873 ----------------
2874 -- Initialize --
2875 ----------------
2877 procedure Initialize is
2878 begin
2879 Warnings_Off_Pragmas.Init;
2880 Unreferenced_Entities.Init;
2881 In_Out_Warnings.Init;
2882 end Initialize;
2884 ---------------------------------------------
2885 -- Is_Attribute_And_Known_Value_Comparison --
2886 ---------------------------------------------
2888 function Is_Attribute_And_Known_Value_Comparison
2889 (Op : Node_Id) return Boolean
2891 Orig_Op : constant Node_Id := Original_Node (Op);
2893 begin
2894 return
2895 Nkind (Orig_Op) in N_Op_Compare
2896 and then Nkind (Original_Node (Left_Opnd (Orig_Op))) =
2897 N_Attribute_Reference
2898 and then Compile_Time_Known_Value (Right_Opnd (Orig_Op));
2899 end Is_Attribute_And_Known_Value_Comparison;
2901 ------------------------------------
2902 -- Never_Set_In_Source_Check_Spec --
2903 ------------------------------------
2905 function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean is
2906 begin
2907 if Is_Formal (E) and then Present (Spec_Entity (E)) then
2908 return Never_Set_In_Source (E)
2909 and then
2910 Never_Set_In_Source (Spec_Entity (E));
2911 else
2912 return Never_Set_In_Source (E);
2913 end if;
2914 end Never_Set_In_Source_Check_Spec;
2916 -------------------------------------
2917 -- Operand_Has_Warnings_Suppressed --
2918 -------------------------------------
2920 function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean is
2922 function Check_For_Warnings (N : Node_Id) return Traverse_Result;
2923 -- Function used to check one node to see if it is or was originally
2924 -- a reference to an entity for which Warnings are off. If so, Abandon
2925 -- is returned, otherwise OK_Orig is returned to continue the traversal
2926 -- of the original expression.
2928 function Traverse is new Traverse_Func (Check_For_Warnings);
2929 -- Function used to traverse tree looking for warnings
2931 ------------------------
2932 -- Check_For_Warnings --
2933 ------------------------
2935 function Check_For_Warnings (N : Node_Id) return Traverse_Result is
2936 R : constant Node_Id := Original_Node (N);
2938 begin
2939 if Nkind (R) in N_Has_Entity
2940 and then Present (Entity (R))
2941 and then Has_Warnings_Off (Entity (R))
2942 then
2943 return Abandon;
2944 else
2945 return OK_Orig;
2946 end if;
2947 end Check_For_Warnings;
2949 -- Start of processing for Operand_Has_Warnings_Suppressed
2951 begin
2952 return Traverse (N) = Abandon;
2953 end Operand_Has_Warnings_Suppressed;
2955 -----------------------------------------
2956 -- Output_Non_Modified_In_Out_Warnings --
2957 -----------------------------------------
2959 procedure Output_Non_Modified_In_Out_Warnings is
2961 function Warn_On_In_Out (E : Entity_Id) return Boolean;
2962 -- Given a formal parameter entity E, determines if there is a reason to
2963 -- suppress IN OUT warnings (not modified, could be IN) for formals of
2964 -- the subprogram. We suppress these warnings if Warnings Off is set, or
2965 -- if we have seen the address of the subprogram being taken, or if the
2966 -- subprogram is used as a generic actual (in the latter cases the
2967 -- context may force use of IN OUT, even if the parameter is not
2968 -- modified for this particular case).
2970 --------------------
2971 -- Warn_On_In_Out --
2972 --------------------
2974 function Warn_On_In_Out (E : Entity_Id) return Boolean is
2975 S : constant Entity_Id := Scope (E);
2976 SE : constant Entity_Id := Spec_Entity (E);
2978 begin
2979 -- Do not warn if address is taken, since funny business may be going
2980 -- on in treating the parameter indirectly as IN OUT.
2982 if Address_Taken (S)
2983 or else (Present (SE) and then Address_Taken (Scope (SE)))
2984 then
2985 return False;
2987 -- Do not warn if used as a generic actual, since the generic may be
2988 -- what is forcing the use of an "unnecessary" IN OUT.
2990 elsif Used_As_Generic_Actual (S)
2991 or else (Present (SE) and then Used_As_Generic_Actual (Scope (SE)))
2992 then
2993 return False;
2995 -- Else test warnings off on the subprogram
2997 elsif Warnings_Off (S) then
2998 return False;
3000 -- All tests for suppressing warning failed
3002 else
3003 return True;
3004 end if;
3005 end Warn_On_In_Out;
3007 -- Start of processing for Output_Non_Modified_In_Out_Warnings
3009 begin
3010 -- Loop through entities for which a warning may be needed
3012 for J in In_Out_Warnings.First .. In_Out_Warnings.Last loop
3013 declare
3014 E1 : constant Entity_Id := In_Out_Warnings.Table (J);
3016 begin
3017 -- Suppress warning in specific cases (see details in comments for
3018 -- No_Warn_On_In_Out).
3020 if Warn_On_In_Out (E1) then
3021 -- If -gnatwk is set then output message that it could be IN
3023 if not Is_Trivial_Subprogram (Scope (E1)) then
3024 if Warn_On_Constant then
3025 Error_Msg_N
3026 ("?k?formal parameter & is not modified!", E1);
3027 Error_Msg_N
3028 ("\?k?mode could be IN instead of `IN OUT`!", E1);
3030 -- We do not generate warnings for IN OUT parameters
3031 -- unless we have at least -gnatwu. This is deliberately
3032 -- inconsistent with the treatment of variables, but
3033 -- otherwise we get too many unexpected warnings in
3034 -- default mode.
3036 elsif Check_Unreferenced then
3037 Error_Msg_N
3038 ("?u?formal parameter& is read but "
3039 & "never assigned!", E1);
3040 end if;
3041 end if;
3043 -- Kill any other warnings on this entity, since this is the
3044 -- one that should dominate any other unreferenced warning.
3046 Set_Warnings_Off (E1);
3047 end if;
3048 end;
3049 end loop;
3050 end Output_Non_Modified_In_Out_Warnings;
3052 ----------------------------------------
3053 -- Output_Obsolescent_Entity_Warnings --
3054 ----------------------------------------
3056 procedure Output_Obsolescent_Entity_Warnings (N : Node_Id; E : Entity_Id) is
3057 P : constant Node_Id := Parent (N);
3058 S : Entity_Id;
3060 begin
3061 S := Current_Scope;
3063 -- Do not output message if we are the scope of standard. This means
3064 -- we have a reference from a context clause from when it is originally
3065 -- processed, and that's too early to tell whether it is an obsolescent
3066 -- unit doing the with'ing. In Sem_Ch10.Analyze_Compilation_Unit we make
3067 -- sure that we have a later call when the scope is available. This test
3068 -- also eliminates all messages for use clauses, which is fine (we do
3069 -- not want messages for use clauses, since they are always redundant
3070 -- with respect to the associated with clause).
3072 if S = Standard_Standard then
3073 return;
3074 end if;
3076 -- Do not output message if we are in scope of an obsolescent package
3077 -- or subprogram.
3079 loop
3080 if Is_Obsolescent (S) then
3081 return;
3082 end if;
3084 S := Scope (S);
3085 exit when S = Standard_Standard;
3086 end loop;
3088 -- Here we will output the message
3090 Error_Msg_Sloc := Sloc (E);
3092 -- Case of with clause
3094 if Nkind (P) = N_With_Clause then
3095 if Ekind (E) = E_Package then
3096 Error_Msg_NE
3097 ("?j?with of obsolescent package& declared#", N, E);
3098 elsif Ekind (E) = E_Procedure then
3099 Error_Msg_NE
3100 ("?j?with of obsolescent procedure& declared#", N, E);
3101 else
3102 Error_Msg_NE
3103 ("?j?with of obsolescent function& declared#", N, E);
3104 end if;
3106 -- If we do not have a with clause, then ignore any reference to an
3107 -- obsolescent package name. We only want to give the one warning of
3108 -- withing the package, not one each time it is used to qualify.
3110 elsif Ekind (E) = E_Package then
3111 return;
3113 -- Procedure call statement
3115 elsif Nkind (P) = N_Procedure_Call_Statement then
3116 Error_Msg_NE
3117 ("??call to obsolescent procedure& declared#", N, E);
3119 -- Function call
3121 elsif Nkind (P) = N_Function_Call then
3122 Error_Msg_NE
3123 ("??call to obsolescent function& declared#", N, E);
3125 -- Reference to obsolescent type
3127 elsif Is_Type (E) then
3128 Error_Msg_NE
3129 ("??reference to obsolescent type& declared#", N, E);
3131 -- Reference to obsolescent component
3133 elsif Ekind (E) in E_Component | E_Discriminant then
3134 Error_Msg_NE
3135 ("??reference to obsolescent component& declared#", N, E);
3137 -- Reference to obsolescent variable
3139 elsif Ekind (E) = E_Variable then
3140 Error_Msg_NE
3141 ("??reference to obsolescent variable& declared#", N, E);
3143 -- Reference to obsolescent constant
3145 elsif Ekind (E) = E_Constant or else Ekind (E) in Named_Kind then
3146 Error_Msg_NE
3147 ("??reference to obsolescent constant& declared#", N, E);
3149 -- Reference to obsolescent enumeration literal
3151 elsif Ekind (E) = E_Enumeration_Literal then
3152 Error_Msg_NE
3153 ("??reference to obsolescent enumeration literal& declared#", N, E);
3155 -- Generic message for any other case we missed
3157 else
3158 Error_Msg_NE
3159 ("??reference to obsolescent entity& declared#", N, E);
3160 end if;
3162 -- Output additional warning if present
3164 for J in Obsolescent_Warnings.First .. Obsolescent_Warnings.Last loop
3165 if Obsolescent_Warnings.Table (J).Ent = E then
3166 String_To_Name_Buffer (Obsolescent_Warnings.Table (J).Msg);
3167 Error_Msg_Strlen := Name_Len;
3168 Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
3169 Error_Msg_N ("\\??~", N);
3170 exit;
3171 end if;
3172 end loop;
3173 end Output_Obsolescent_Entity_Warnings;
3175 ----------------------------------
3176 -- Output_Unreferenced_Messages --
3177 ----------------------------------
3179 procedure Output_Unreferenced_Messages is
3180 begin
3181 for J in Unreferenced_Entities.First .. Unreferenced_Entities.Last loop
3182 Warn_On_Unreferenced_Entity (Unreferenced_Entities.Table (J));
3183 end loop;
3184 end Output_Unreferenced_Messages;
3186 -----------------------------------------
3187 -- Output_Unused_Warnings_Off_Warnings --
3188 -----------------------------------------
3190 procedure Output_Unused_Warnings_Off_Warnings is
3191 begin
3192 for J in Warnings_Off_Pragmas.First .. Warnings_Off_Pragmas.Last loop
3193 declare
3194 Wentry : Warnings_Off_Entry renames Warnings_Off_Pragmas.Table (J);
3195 N : Node_Id renames Wentry.N;
3196 E : Node_Id renames Wentry.E;
3198 begin
3199 -- Turn off Warnings_Off, or we won't get the warning
3201 Set_Warnings_Off (E, False);
3203 -- Nothing to do if pragma was used to suppress a general warning
3205 if Warnings_Off_Used (E) then
3206 null;
3208 -- If pragma was used both in unmodified and unreferenced contexts
3209 -- then that's as good as the general case, no warning.
3211 elsif Warnings_Off_Used_Unmodified (E)
3213 Warnings_Off_Used_Unreferenced (E)
3214 then
3215 null;
3217 -- Used only in context where Unmodified would have worked
3219 elsif Warnings_Off_Used_Unmodified (E) then
3220 Error_Msg_NE
3221 ("?.w?could use Unmodified instead of "
3222 & "Warnings Off for &", Pragma_Identifier (N), E);
3224 -- Used only in context where Unreferenced would have worked
3226 elsif Warnings_Off_Used_Unreferenced (E) then
3227 Error_Msg_NE
3228 ("?.w?could use Unreferenced instead of "
3229 & "Warnings Off for &", Pragma_Identifier (N), E);
3231 -- Not used at all
3233 else
3234 Error_Msg_NE
3235 ("?.w?pragma Warnings Off for & unused, "
3236 & "could be omitted", N, E);
3237 end if;
3238 end;
3239 end loop;
3240 end Output_Unused_Warnings_Off_Warnings;
3242 ---------------------------
3243 -- Referenced_Check_Spec --
3244 ---------------------------
3246 function Referenced_Check_Spec (E : Entity_Id) return Boolean is
3247 begin
3248 if Is_Formal (E) and then Present (Spec_Entity (E)) then
3249 return Referenced (E) or else Referenced (Spec_Entity (E));
3250 else
3251 return Referenced (E);
3252 end if;
3253 end Referenced_Check_Spec;
3255 ----------------------------------
3256 -- Referenced_As_LHS_Check_Spec --
3257 ----------------------------------
3259 function Referenced_As_LHS_Check_Spec (E : Entity_Id) return Boolean is
3260 begin
3261 if Is_Formal (E) and then Present (Spec_Entity (E)) then
3262 return Referenced_As_LHS (E)
3263 or else Referenced_As_LHS (Spec_Entity (E));
3264 else
3265 return Referenced_As_LHS (E);
3266 end if;
3267 end Referenced_As_LHS_Check_Spec;
3269 --------------------------------------------
3270 -- Referenced_As_Out_Parameter_Check_Spec --
3271 --------------------------------------------
3273 function Referenced_As_Out_Parameter_Check_Spec
3274 (E : Entity_Id) return Boolean
3276 begin
3277 if Is_Formal (E) and then Present (Spec_Entity (E)) then
3278 return Referenced_As_Out_Parameter (E)
3279 or else Referenced_As_Out_Parameter (Spec_Entity (E));
3280 else
3281 return Referenced_As_Out_Parameter (E);
3282 end if;
3283 end Referenced_As_Out_Parameter_Check_Spec;
3285 --------------------------------------
3286 -- Warn_On_Constant_Valid_Condition --
3287 --------------------------------------
3289 procedure Warn_On_Constant_Valid_Condition (Op : Node_Id) is
3290 Left : constant Node_Id := Left_Opnd (Op);
3291 Right : constant Node_Id := Right_Opnd (Op);
3293 function Comes_From_Simple_Condition_In_Source
3294 (Op : Node_Id) return Boolean;
3295 -- Return True if Op comes from a simple condition present in the source
3297 -------------------------------------------
3298 -- Comes_From_Simple_Condition_In_Source --
3299 -------------------------------------------
3301 function Comes_From_Simple_Condition_In_Source
3302 (Op : Node_Id) return Boolean
3304 Orig_Op : constant Node_Id := Original_Node (Op);
3306 begin
3307 if not Comes_From_Source (Orig_Op) then
3308 return False;
3309 end if;
3311 -- We do not want to give warnings on a membership test with a mark
3312 -- for a subtype that is predicated, see also Exp_Ch4.Expand_N_In.
3314 if Nkind (Orig_Op) = N_In then
3315 declare
3316 Orig_Rop : constant Node_Id :=
3317 Original_Node (Right_Opnd (Orig_Op));
3318 begin
3319 if Is_Entity_Name (Orig_Rop)
3320 and then Is_Type (Entity (Orig_Rop))
3321 and then Present (Predicate_Function (Entity (Orig_Rop)))
3322 then
3323 return False;
3324 end if;
3325 end;
3326 end if;
3328 return True;
3329 end Comes_From_Simple_Condition_In_Source;
3331 True_Result : Boolean;
3332 False_Result : Boolean;
3334 begin
3335 -- Determine the potential outcome of the comparison assuming that the
3336 -- scalar operands are valid.
3338 if Constant_Condition_Warnings
3339 and then Comes_From_Simple_Condition_In_Source (Op)
3340 and then Is_Scalar_Type (Etype (Left))
3341 and then Is_Scalar_Type (Etype (Right))
3343 -- Do not consider instances because the check was already performed
3344 -- in the generic.
3346 and then not In_Instance
3348 -- Do not consider comparisons between two static expressions such as
3349 -- constants or literals because those values cannot be invalidated.
3351 and then not (Is_Static_Expression (Left)
3352 and then Is_Static_Expression (Right))
3354 -- Do not consider comparison between an attribute reference and a
3355 -- compile-time known value since this is most likely a conditional
3356 -- compilation.
3358 and then not Is_Attribute_And_Known_Value_Comparison (Op)
3360 -- Do not consider internal files to allow for various assertions and
3361 -- safeguards within our runtime.
3363 and then not In_Internal_Unit (Op)
3364 then
3365 Test_Comparison
3366 (Op => Op,
3367 Assume_Valid => True,
3368 True_Result => True_Result,
3369 False_Result => False_Result);
3371 -- Warn on a possible evaluation to False / True in the presence of
3372 -- invalid values. But issue no warning for an assertion expression
3373 -- (or a subexpression thereof); in particular, we don't want a
3374 -- warning about an assertion that will always succeed.
3376 if In_Assertion_Expression_Pragma (Op) then
3377 null;
3379 elsif True_Result then
3380 Error_Msg_N
3381 ("condition can only be False if invalid values present?c?", Op);
3383 elsif False_Result then
3384 Error_Msg_N
3385 ("condition can only be True if invalid values present?c?", Op);
3386 end if;
3387 end if;
3388 end Warn_On_Constant_Valid_Condition;
3390 -----------------------------
3391 -- Warn_On_Known_Condition --
3392 -----------------------------
3394 procedure Warn_On_Known_Condition (C : Node_Id) is
3395 Test_Result : Boolean := False;
3396 -- Force initialization to facilitate static analysis
3398 function Is_Known_Branch return Boolean;
3399 -- If the type of the condition is Boolean, the constant value of the
3400 -- condition is a boolean literal. If the type is a derived boolean
3401 -- type, the constant is wrapped in a type conversion of the derived
3402 -- literal. If the value of the condition is not a literal, no warnings
3403 -- can be produced. This function returns True if the result can be
3404 -- determined, and Test_Result is set True/False accordingly. Otherwise
3405 -- False is returned, and Test_Result is unchanged.
3407 procedure Track (N : Node_Id);
3408 -- Adds continuation warning(s) pointing to reason (assignment or test)
3409 -- for the operand of the conditional having a known value (or at least
3410 -- enough is known about the value to issue the warning).
3412 ---------------------
3413 -- Is_Known_Branch --
3414 ---------------------
3416 function Is_Known_Branch return Boolean is
3417 begin
3418 if Etype (C) = Standard_Boolean
3419 and then Is_Entity_Name (C)
3420 and then
3421 (Entity (C) = Standard_False or else Entity (C) = Standard_True)
3422 then
3423 Test_Result := Entity (C) = Standard_True;
3424 return True;
3426 elsif Is_Boolean_Type (Etype (C))
3427 and then Nkind (C) = N_Unchecked_Type_Conversion
3428 and then Is_Entity_Name (Expression (C))
3429 and then Ekind (Entity (Expression (C))) = E_Enumeration_Literal
3430 then
3431 Test_Result :=
3432 Chars (Entity (Expression (C))) = Chars (Standard_True);
3433 return True;
3435 else
3436 return False;
3437 end if;
3438 end Is_Known_Branch;
3440 -----------
3441 -- Track --
3442 -----------
3444 procedure Track (N : Node_Id) is
3446 procedure Rec (Sub_N : Node_Id);
3447 -- Recursive helper to do the work of Track, so we can refer to N's
3448 -- Sloc in error messages. Sub_N is initially N, and a proper subnode
3449 -- when recursively walking comparison operations.
3451 procedure Rec (Sub_N : Node_Id) is
3452 Orig : constant Node_Id := Original_Node (Sub_N);
3453 begin
3454 if Nkind (Orig) in N_Op_Compare then
3455 Rec (Left_Opnd (Orig));
3456 Rec (Right_Opnd (Orig));
3458 elsif Is_Entity_Name (Orig) and then Is_Object (Entity (Orig)) then
3459 declare
3460 CV : constant Node_Id := Current_Value (Entity (Orig));
3461 begin
3462 if Present (CV) then
3463 Error_Msg_Sloc := Sloc (CV);
3465 if Nkind (CV) not in N_Subexpr then
3466 Error_Msg_N ("\\??(see test #)", N);
3468 elsif Nkind (Parent (CV)) =
3469 N_Case_Statement_Alternative
3470 then
3471 Error_Msg_N ("\\??(see case alternative #)", N);
3473 else
3474 Error_Msg_N ("\\??(see assignment #)", N);
3475 end if;
3476 end if;
3477 end;
3478 end if;
3479 end Rec;
3481 begin
3482 Rec (N);
3483 end Track;
3485 -- Local variables
3487 Orig : constant Node_Id := Original_Node (C);
3488 P : Node_Id;
3490 -- Start of processing for Warn_On_Known_Condition
3492 begin
3493 -- Adjust SCO condition if from source
3495 if Generate_SCO
3496 and then Comes_From_Source (Orig)
3497 and then Is_Known_Branch
3498 then
3499 declare
3500 Atrue : Boolean := Test_Result;
3501 begin
3502 if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then
3503 Atrue := not Atrue;
3504 end if;
3506 Set_SCO_Condition (Orig, Atrue);
3507 end;
3508 end if;
3510 -- Argument replacement in an inlined body can make conditions static.
3511 -- Do not emit warnings in this case.
3513 if In_Inlined_Body then
3514 return;
3515 end if;
3517 if Constant_Condition_Warnings
3518 and then Is_Known_Branch
3519 and then Comes_From_Source (Orig)
3520 and then Nkind (Orig) in N_Has_Entity
3521 and then not In_Instance
3522 then
3523 -- Don't warn if comparison of result of attribute against a constant
3524 -- value, since this is likely legitimate conditional compilation.
3526 if Is_Attribute_And_Known_Value_Comparison (C) then
3527 return;
3528 end if;
3530 -- See if this is in a statement or a declaration
3532 P := Parent (C);
3533 loop
3534 -- If tree is not attached, do not issue warning (this is very
3535 -- peculiar, and probably arises from some other error condition).
3537 if No (P) then
3538 return;
3540 -- If we are in a declaration, then no warning, since in practice
3541 -- conditionals in declarations are used for intended tests which
3542 -- may be known at compile time, e.g. things like
3544 -- x : constant Integer := 2 + (Word'Size = 32);
3546 -- And a warning is annoying in such cases
3548 elsif Nkind (P) in N_Declaration
3549 or else
3550 Nkind (P) in N_Later_Decl_Item
3551 then
3552 return;
3554 -- Don't warn in assert or check pragma, since presumably tests in
3555 -- such a context are very definitely intended, and might well be
3556 -- known at compile time. Note that we have to test the original
3557 -- node, since assert pragmas get rewritten at analysis time.
3559 elsif Nkind (Original_Node (P)) = N_Pragma
3560 and then
3561 Pragma_Name_Unmapped (Original_Node (P))
3562 in Name_Assert | Name_Check
3563 then
3564 return;
3565 end if;
3567 exit when Is_Statement (P);
3568 P := Parent (P);
3569 end loop;
3571 -- Here we issue the warning unless some sub-operand has warnings
3572 -- set off, in which case we suppress the warning for the node. If
3573 -- the original expression is an inequality, it has been expanded
3574 -- into a negation, and the value of the original expression is the
3575 -- negation of the equality. If the expression is an entity that
3576 -- appears within a negation, it is clearer to flag the negation
3577 -- itself, and report on its constant value.
3579 if not Operand_Has_Warnings_Suppressed (C) then
3580 declare
3581 True_Branch : Boolean := Test_Result;
3582 Cond : Node_Id := C;
3583 begin
3584 if Present (Parent (C))
3585 and then Nkind (Parent (C)) = N_Op_Not
3586 then
3587 True_Branch := not True_Branch;
3588 Cond := Parent (C);
3589 end if;
3591 -- Suppress warning if this is True/False of a derived boolean
3592 -- type with Nonzero_Is_True, which gets rewritten as Boolean
3593 -- True/False.
3595 if Is_Entity_Name (Original_Node (C))
3596 and then Ekind (Entity (Original_Node (C)))
3597 = E_Enumeration_Literal
3598 and then Nonzero_Is_True (Etype (Original_Node (C)))
3599 then
3600 null;
3602 -- Give warning for nontrivial always True/False case
3604 else
3605 if True_Branch then
3606 Error_Msg_N ("condition is always True?c?", Cond);
3607 else
3608 Error_Msg_N ("condition is always False?c?", Cond);
3609 end if;
3611 Track (Cond);
3612 end if;
3613 end;
3614 end if;
3615 end if;
3616 end Warn_On_Known_Condition;
3618 ---------------------------------------
3619 -- Warn_On_Modified_As_Out_Parameter --
3620 ---------------------------------------
3622 function Warn_On_Modified_As_Out_Parameter (E : Entity_Id) return Boolean is
3623 begin
3624 return
3625 (Warn_On_Modified_Unread and then Is_Only_Out_Parameter (E))
3626 or else Warn_On_All_Unread_Out_Parameters;
3627 end Warn_On_Modified_As_Out_Parameter;
3629 ---------------------------------
3630 -- Warn_On_Overlapping_Actuals --
3631 ---------------------------------
3633 procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is
3634 function Explicitly_By_Reference (Formal_Id : Entity_Id) return Boolean;
3635 -- Returns True iff the type of Formal_Id is explicitly by-reference
3637 function Refer_Same_Object
3638 (Act1 : Node_Id;
3639 Act2 : Node_Id) return Boolean;
3640 -- Two names are known to refer to the same object if the two names
3641 -- are known to denote the same object; or one of the names is a
3642 -- selected_component, indexed_component, or slice and its prefix is
3643 -- known to refer to the same object as the other name; or one of the
3644 -- two names statically denotes a renaming declaration whose renamed
3645 -- object_name is known to refer to the same object as the other name
3646 -- (RM 6.4.1(6.11/3))
3648 -----------------------------
3649 -- Explicitly_By_Reference --
3650 -----------------------------
3652 function Explicitly_By_Reference
3653 (Formal_Id : Entity_Id)
3654 return Boolean
3656 Typ : constant Entity_Id := Underlying_Type (Etype (Formal_Id));
3657 begin
3658 if Present (Typ) then
3659 return Is_By_Reference_Type (Typ)
3660 or else Convention (Typ) = Convention_Ada_Pass_By_Reference;
3661 else
3662 return False;
3663 end if;
3664 end Explicitly_By_Reference;
3666 -----------------------
3667 -- Refer_Same_Object --
3668 -----------------------
3670 function Refer_Same_Object
3671 (Act1 : Node_Id;
3672 Act2 : Node_Id) return Boolean
3674 begin
3675 return
3676 Denotes_Same_Object (Act1, Act2)
3677 or else Denotes_Same_Prefix (Act1, Act2);
3678 end Refer_Same_Object;
3680 -- Local variables
3682 Act1 : Node_Id;
3683 Act2 : Node_Id;
3684 Form1 : Entity_Id;
3685 Form2 : Entity_Id;
3687 -- Start of processing for Warn_On_Overlapping_Actuals
3689 begin
3690 -- Exclude calls rewritten as enumeration literals
3692 if Nkind (N) not in N_Subprogram_Call | N_Entry_Call_Statement then
3693 return;
3695 -- Guard against previous errors
3697 elsif Error_Posted (N) then
3698 return;
3699 end if;
3701 -- If a call C has two or more parameters of mode in out or out that are
3702 -- of an elementary type, then the call is legal only if for each name
3703 -- N that is passed as a parameter of mode in out or out to the call C,
3704 -- there is no other name among the other parameters of mode in out or
3705 -- out to C that is known to denote the same object (RM 6.4.1(6.15/3))
3706 -- This has been clarified in AI12-0216 to indicate that the illegality
3707 -- only occurs if both formals are of an elementary type, because of the
3708 -- nondeterminism on the write-back of the corresponding actuals.
3709 -- Earlier versions of the language made it illegal if only one of the
3710 -- actuals was an elementary parameter that overlapped a composite
3711 -- actual, and both were writable.
3713 -- If appropriate warning switch is set, we also report warnings on
3714 -- overlapping parameters that are composite types. Users find these
3715 -- warnings useful, and they are used in style guides.
3717 -- It is also worthwhile to warn on overlaps of composite objects when
3718 -- only one of the formals is (in)-out. Note that the RM rule above is
3719 -- a legality rule. We choose to implement this check as a warning to
3720 -- avoid major incompatibilities with legacy code.
3722 -- Note also that the rule in 6.4.1 (6.17/3), introduced by AI12-0324,
3723 -- is potentially more expensive to verify, and is not yet implemented.
3725 Form1 := First_Formal (Subp);
3726 Act1 := First_Actual (N);
3727 while Present (Form1) and then Present (Act1) loop
3729 Form2 := Next_Formal (Form1);
3730 Act2 := Next_Actual (Act1);
3731 while Present (Form2) and then Present (Act2) loop
3733 -- Ignore formals of generic types; they will be examined when
3734 -- instantiated.
3736 if Is_Generic_Type (Etype (Form1))
3737 or else Is_Generic_Type (Etype (Form2))
3738 then
3739 null;
3741 elsif Refer_Same_Object (Act1, Act2) then
3743 -- Case 1: two writable elementary parameters that overlap
3745 if (Is_Elementary_Type (Etype (Form1))
3746 and then Is_Elementary_Type (Etype (Form2))
3747 and then Ekind (Form1) /= E_In_Parameter
3748 and then Ekind (Form2) /= E_In_Parameter)
3750 -- Case 2: two composite parameters that overlap, one of
3751 -- which is writable.
3753 or else (Is_Composite_Type (Etype (Form1))
3754 and then Is_Composite_Type (Etype (Form2))
3755 and then (Ekind (Form1) /= E_In_Parameter
3756 or else Ekind (Form2) /= E_In_Parameter))
3758 -- Case 3: an elementary writable parameter that overlaps
3759 -- a composite one.
3761 or else (Is_Elementary_Type (Etype (Form1))
3762 and then Ekind (Form1) /= E_In_Parameter
3763 and then Is_Composite_Type (Etype (Form2)))
3765 or else (Is_Elementary_Type (Etype (Form2))
3766 and then Ekind (Form2) /= E_In_Parameter
3767 and then Is_Composite_Type (Etype (Form1)))
3768 then
3770 -- Guard against previous errors
3772 if No (Etype (Act1))
3773 or else No (Etype (Act2))
3774 then
3775 null;
3777 -- If type is explicitly by-reference, then it is not
3778 -- covered by the legality rule, which only applies to
3779 -- elementary types. Actually, the aliasing is most
3780 -- likely intended, so don't emit a warning either.
3782 elsif Explicitly_By_Reference (Form1)
3783 or else Explicitly_By_Reference (Form2)
3784 then
3785 null;
3787 -- We only report warnings on overlapping arrays and record
3788 -- types if switch is set.
3790 elsif not Warn_On_Overlap
3791 and then not (Is_Elementary_Type (Etype (Form1))
3792 and then
3793 Is_Elementary_Type (Etype (Form2)))
3794 then
3795 null;
3797 -- Here we may need to issue overlap message
3799 else
3800 Error_Msg_Warn :=
3802 -- Overlap checking is an error only in Ada 2012. For
3803 -- earlier versions of Ada, this is a warning.
3805 Ada_Version < Ada_2012
3807 -- Overlap is only illegal since Ada 2012 and only for
3808 -- elementary types (passed by copy). For other types
3809 -- we always have a warning in all versions. This is
3810 -- clarified by AI12-0216.
3812 or else not
3813 (Is_Elementary_Type (Etype (Form1))
3814 and then Is_Elementary_Type (Etype (Form2)))
3816 -- debug flag -gnatd.E changes the error to a warning
3817 -- even in Ada 2012 mode.
3819 or else Error_To_Warning;
3821 -- For greater clarity, give name of formal
3823 Error_Msg_Node_2 := Form2;
3825 -- This is one of the messages
3827 Error_Msg_FE
3828 ("<.i<writable actual for & overlaps with actual for &",
3829 Act1, Form1);
3830 end if;
3831 end if;
3832 end if;
3834 Next_Formal (Form2);
3835 Next_Actual (Act2);
3836 end loop;
3838 Next_Formal (Form1);
3839 Next_Actual (Act1);
3840 end loop;
3841 end Warn_On_Overlapping_Actuals;
3843 ------------------------------
3844 -- Warn_On_Suspicious_Index --
3845 ------------------------------
3847 procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id) is
3849 Low_Bound : Uint;
3850 -- Set to lower bound for a suspicious type
3852 Ent : Entity_Id;
3853 -- Entity for array reference
3855 Typ : Entity_Id;
3856 -- Array type
3858 function Is_Suspicious_Type (Typ : Entity_Id) return Boolean;
3859 -- Tests to see if Typ is a type for which we may have a suspicious
3860 -- index, namely an unconstrained array type, whose lower bound is
3861 -- either zero or one. If so, True is returned, and Low_Bound is set
3862 -- to this lower bound. If not, False is returned, and Low_Bound is
3863 -- undefined on return.
3865 -- For now, we limit this to standard string types, so any other
3866 -- unconstrained types return False. We may change our minds on this
3867 -- later on, but strings seem the most important case.
3869 procedure Test_Suspicious_Index;
3870 -- Test if index is of suspicious type and if so, generate warning
3872 ------------------------
3873 -- Is_Suspicious_Type --
3874 ------------------------
3876 function Is_Suspicious_Type (Typ : Entity_Id) return Boolean is
3877 LB : Node_Id;
3879 begin
3880 if Is_Array_Type (Typ)
3881 and then not Is_Constrained (Typ)
3882 and then Number_Dimensions (Typ) = 1
3883 and then Is_Standard_String_Type (Typ)
3884 and then not Has_Warnings_Off (Typ)
3885 then
3886 LB := Type_Low_Bound (Etype (First_Index (Typ)));
3888 if Compile_Time_Known_Value (LB) then
3889 Low_Bound := Expr_Value (LB);
3890 return Low_Bound = Uint_0 or else Low_Bound = Uint_1;
3891 end if;
3892 end if;
3894 return False;
3895 end Is_Suspicious_Type;
3897 ---------------------------
3898 -- Test_Suspicious_Index --
3899 ---------------------------
3901 procedure Test_Suspicious_Index is
3903 function Length_Reference (N : Node_Id) return Boolean;
3904 -- Check if node N is of the form Name'Length
3906 procedure Warn1;
3907 -- Generate first warning line
3909 procedure Warn_On_Index_Below_Lower_Bound;
3910 -- Generate a warning on indexing the array with a literal value
3911 -- below the lower bound of the index type.
3913 procedure Warn_On_Literal_Index;
3914 -- Generate a warning on indexing the array with a literal value
3916 ----------------------
3917 -- Length_Reference --
3918 ----------------------
3920 function Length_Reference (N : Node_Id) return Boolean is
3921 R : constant Node_Id := Original_Node (N);
3922 begin
3923 return
3924 Nkind (R) = N_Attribute_Reference
3925 and then Attribute_Name (R) = Name_Length
3926 and then Is_Entity_Name (Prefix (R))
3927 and then Entity (Prefix (R)) = Ent;
3928 end Length_Reference;
3930 -----------
3931 -- Warn1 --
3932 -----------
3934 procedure Warn1 is
3935 begin
3936 Error_Msg_Uint_1 := Low_Bound;
3937 Error_Msg_FE -- CODEFIX
3938 ("?w?index for& may assume lower bound of^", X, Ent);
3939 end Warn1;
3941 -------------------------------------
3942 -- Warn_On_Index_Below_Lower_Bound --
3943 -------------------------------------
3945 procedure Warn_On_Index_Below_Lower_Bound is
3946 begin
3947 if Is_Standard_String_Type (Typ) then
3948 Discard_Node
3949 (Compile_Time_Constraint_Error
3950 (N => X,
3951 Msg => "?w?string index should be positive"));
3952 else
3953 Discard_Node
3954 (Compile_Time_Constraint_Error
3955 (N => X,
3956 Msg => "?w?index out of the allowed range"));
3957 end if;
3958 end Warn_On_Index_Below_Lower_Bound;
3960 ---------------------------
3961 -- Warn_On_Literal_Index --
3962 ---------------------------
3964 procedure Warn_On_Literal_Index is
3965 begin
3966 Warn1;
3968 -- Case where original form of subscript is an integer literal
3970 if Nkind (Original_Node (X)) = N_Integer_Literal then
3971 if Intval (X) = Low_Bound then
3972 Error_Msg_FE -- CODEFIX
3973 ("\?w?suggested replacement: `&''First`", X, Ent);
3974 else
3975 Error_Msg_Uint_1 := Intval (X) - Low_Bound;
3976 Error_Msg_FE -- CODEFIX
3977 ("\?w?suggested replacement: `&''First + ^`", X, Ent);
3979 end if;
3981 -- Case where original form of subscript is more complex
3983 else
3984 -- Build string X'First - 1 + expression where the expression
3985 -- is the original subscript. If the expression starts with "1
3986 -- + ", then the "- 1 + 1" is elided.
3988 Error_Msg_String (1 .. 13) := "'First - 1 + ";
3989 Error_Msg_Strlen := 13;
3991 declare
3992 Sref : Source_Ptr := Sloc (First_Node (Original_Node (X)));
3993 Tref : constant Source_Buffer_Ptr :=
3994 Source_Text (Get_Source_File_Index (Sref));
3995 -- Tref (Sref) is used to scan the subscript
3997 Pctr : Natural;
3998 -- Parentheses counter when scanning subscript
4000 begin
4001 -- Tref (Sref) points to start of subscript
4003 -- Elide - 1 if subscript starts with 1 +
4005 if Tref (Sref .. Sref + 2) = "1 +" then
4006 Error_Msg_Strlen := Error_Msg_Strlen - 6;
4007 Sref := Sref + 2;
4009 elsif Tref (Sref .. Sref + 1) = "1+" then
4010 Error_Msg_Strlen := Error_Msg_Strlen - 6;
4011 Sref := Sref + 1;
4012 end if;
4014 -- Now we will copy the subscript to the string buffer
4016 Pctr := 0;
4017 loop
4018 -- Count parens, exit if terminating right paren. Note
4019 -- check to ignore paren appearing as character literal.
4021 if Tref (Sref + 1) = '''
4022 and then
4023 Tref (Sref - 1) = '''
4024 then
4025 null;
4026 else
4027 if Tref (Sref) = '(' then
4028 Pctr := Pctr + 1;
4029 elsif Tref (Sref) = ')' then
4030 exit when Pctr = 0;
4031 Pctr := Pctr - 1;
4032 end if;
4033 end if;
4035 -- Done if terminating double dot (slice case)
4037 exit when Pctr = 0
4038 and then (Tref (Sref .. Sref + 1) = ".."
4039 or else
4040 Tref (Sref .. Sref + 2) = " ..");
4042 -- Quit if we have hit EOF character, something wrong
4044 if Tref (Sref) = EOF then
4045 return;
4046 end if;
4048 -- String literals are too much of a pain to handle
4050 if Tref (Sref) = '"' or else Tref (Sref) = '%' then
4051 return;
4052 end if;
4054 -- If we have a 'Range reference, then this is a case
4055 -- where we cannot easily give a replacement. Don't try.
4057 if Tref (Sref .. Sref + 4) = "range"
4058 and then Tref (Sref - 1) < 'A'
4059 and then Tref (Sref + 5) < 'A'
4060 then
4061 return;
4062 end if;
4064 -- Else store next character
4066 Error_Msg_Strlen := Error_Msg_Strlen + 1;
4067 Error_Msg_String (Error_Msg_Strlen) := Tref (Sref);
4068 Sref := Sref + 1;
4070 -- If we get more than 40 characters then the expression
4071 -- is too long to copy, or something has gone wrong. In
4072 -- either case, just skip the attempt at a suggested fix.
4074 if Error_Msg_Strlen > 40 then
4075 return;
4076 end if;
4077 end loop;
4078 end;
4080 -- Replacement subscript is now in string buffer
4082 Error_Msg_FE -- CODEFIX
4083 ("\?w?suggested replacement: `&~`", Original_Node (X), Ent);
4084 end if;
4085 end Warn_On_Literal_Index;
4087 -- Start of processing for Test_Suspicious_Index
4089 begin
4090 -- Nothing to do if subscript does not come from source (we don't
4091 -- want to give garbage warnings on compiler expanded code, e.g. the
4092 -- loops generated for slice assignments. Such junk warnings would
4093 -- be placed on source constructs with no subscript in sight).
4095 if not Comes_From_Source (Original_Node (X)) then
4096 return;
4097 end if;
4099 -- Case where subscript is a constant integer
4101 if Nkind (X) = N_Integer_Literal then
4103 -- Case where subscript is lower than the lowest possible bound.
4104 -- This might be the case for example when programmers try to
4105 -- access a string at index 0, as they are used to in other
4106 -- programming languages like C.
4108 if Intval (X) < Low_Bound then
4109 Warn_On_Index_Below_Lower_Bound;
4110 else
4111 Warn_On_Literal_Index;
4112 end if;
4114 -- Case where subscript is of the form X'Length
4116 elsif Length_Reference (X) then
4117 Warn1;
4118 Error_Msg_Node_2 := Ent;
4119 Error_Msg_FE
4120 ("\?w?suggest replacement of `&''Length` by `&''Last`",
4121 X, Ent);
4123 -- Case where subscript is of the form X'Length - expression
4125 elsif Nkind (X) = N_Op_Subtract
4126 and then Length_Reference (Left_Opnd (X))
4127 then
4128 Warn1;
4129 Error_Msg_Node_2 := Ent;
4130 Error_Msg_FE
4131 ("\?w?suggest replacement of `&''Length` by `&''Last`",
4132 Left_Opnd (X), Ent);
4133 end if;
4134 end Test_Suspicious_Index;
4136 -- Start of processing for Warn_On_Suspicious_Index
4138 begin
4139 -- Only process if warnings activated
4141 if Warn_On_Assumed_Low_Bound then
4143 -- Test if array is simple entity name
4145 if Is_Entity_Name (Name) then
4147 -- Test if array is parameter of unconstrained string type
4149 Ent := Entity (Name);
4150 Typ := Etype (Ent);
4152 if Is_Formal (Ent)
4153 and then Is_Suspicious_Type (Typ)
4154 and then not Low_Bound_Tested (Ent)
4155 then
4156 Test_Suspicious_Index;
4157 end if;
4158 end if;
4159 end if;
4160 end Warn_On_Suspicious_Index;
4162 -------------------------------
4163 -- Warn_On_Suspicious_Update --
4164 -------------------------------
4166 procedure Warn_On_Suspicious_Update (N : Node_Id) is
4167 Par : constant Node_Id := Parent (N);
4168 Arg : Node_Id;
4170 begin
4171 -- Only process if warnings activated
4173 if Warn_On_Suspicious_Contract then
4174 if Nkind (Par) in N_Op_Eq | N_Op_Ne then
4175 if N = Left_Opnd (Par) then
4176 Arg := Right_Opnd (Par);
4177 else
4178 Arg := Left_Opnd (Par);
4179 end if;
4181 if Same_Object (Prefix (N), Arg) then
4182 if Nkind (Par) = N_Op_Eq then
4183 Error_Msg_N
4184 ("suspicious equality test with modified version of "
4185 & "same object?.t?", Par);
4186 else
4187 Error_Msg_N
4188 ("suspicious inequality test with modified version of "
4189 & "same object?.t?", Par);
4190 end if;
4191 end if;
4192 end if;
4193 end if;
4194 end Warn_On_Suspicious_Update;
4196 --------------------------------------
4197 -- Warn_On_Unassigned_Out_Parameter --
4198 --------------------------------------
4200 procedure Warn_On_Unassigned_Out_Parameter
4201 (Return_Node : Node_Id;
4202 Scope_Id : Entity_Id)
4204 Form : Entity_Id;
4206 begin
4207 -- Ignore if procedure or return statement does not come from source
4209 if not Comes_From_Source (Scope_Id)
4210 or else not Comes_From_Source (Return_Node)
4211 then
4212 return;
4213 end if;
4215 -- Before we issue the warning, add an ad hoc defence against the most
4216 -- common case of false positives with this warning which is the case
4217 -- where there is a Boolean OUT parameter that has been set, and whose
4218 -- meaning is "ignore the values of the other parameters". We can't of
4219 -- course reliably tell this case at compile time, but the following
4220 -- test kills a lot of false positives, without generating a significant
4221 -- number of false negatives (missed real warnings).
4223 Form := First_Formal (Scope_Id);
4224 while Present (Form) loop
4225 if Ekind (Form) = E_Out_Parameter
4226 and then Root_Type (Etype (Form)) = Standard_Boolean
4227 and then not Never_Set_In_Source_Check_Spec (Form)
4228 then
4229 return;
4230 end if;
4232 Next_Formal (Form);
4233 end loop;
4235 -- Loop through formals
4237 Form := First_Formal (Scope_Id);
4238 while Present (Form) loop
4240 -- We are only interested in OUT parameters that come from source
4241 -- and are never set in the source, and furthermore only in scalars
4242 -- since non-scalars generate too many false positives.
4244 if Ekind (Form) = E_Out_Parameter
4245 and then Never_Set_In_Source_Check_Spec (Form)
4246 and then Is_Scalar_Type (Etype (Form))
4247 and then No (Unset_Reference (Form))
4248 then
4249 -- Here all conditions are met, record possible unset reference
4251 Set_Unset_Reference (Form, Return_Node);
4252 end if;
4254 Next_Formal (Form);
4255 end loop;
4256 end Warn_On_Unassigned_Out_Parameter;
4258 ---------------------------------
4259 -- Warn_On_Unreferenced_Entity --
4260 ---------------------------------
4262 procedure Warn_On_Unreferenced_Entity
4263 (Spec_E : Entity_Id;
4264 Body_E : Entity_Id := Empty)
4266 E : Entity_Id := Spec_E;
4268 begin
4269 if not Referenced_Check_Spec (E)
4270 and then not Has_Pragma_Unreferenced_Check_Spec (E)
4271 and then not Warnings_Off_Check_Spec (E)
4272 and then not Has_Junk_Name (Spec_E)
4273 and then not Is_Exported (Spec_E)
4274 then
4275 case Ekind (E) is
4276 when E_Variable =>
4278 -- Case of variable that is assigned but not read. We suppress
4279 -- the message if the variable is volatile, has an address
4280 -- clause, is aliased, or is a renaming, or is imported.
4282 if Referenced_As_LHS_Check_Spec (E) then
4283 if Warn_On_Modified_Unread
4284 and then No (Address_Clause (E))
4285 and then not Is_Volatile (E)
4286 and then not Is_Imported (E)
4287 and then not Is_Aliased (E)
4288 and then No (Renamed_Object (E))
4289 then
4290 if not Has_Pragma_Unmodified_Check_Spec (E) then
4291 Error_Msg_N -- CODEFIX
4292 ("?m?variable & is assigned but never read!", E);
4293 end if;
4295 Set_Last_Assignment (E, Empty);
4296 end if;
4298 -- Normal case of neither assigned nor read (exclude variables
4299 -- referenced as out parameters, since we already generated
4300 -- appropriate warnings at the call point in this case).
4302 elsif not Referenced_As_Out_Parameter (E) then
4304 -- We suppress the message for types for which a valid
4305 -- pragma Unreferenced_Objects has been given, otherwise
4306 -- we go ahead and give the message.
4308 if not Has_Pragma_Unreferenced_Objects (Etype (E)) then
4310 -- Distinguish renamed case in message
4312 if Present (Renamed_Object (E))
4313 and then Comes_From_Source (Renamed_Object (E))
4314 then
4315 Error_Msg_N -- CODEFIX
4316 ("?u?renamed variable & is not referenced!", E);
4317 else
4318 Error_Msg_N -- CODEFIX
4319 ("?u?variable & is not referenced!", E);
4320 end if;
4321 end if;
4322 end if;
4324 when E_Constant =>
4325 if not Has_Pragma_Unreferenced_Objects (Etype (E)) then
4326 if Present (Renamed_Object (E))
4327 and then Comes_From_Source (Renamed_Object (E))
4328 then
4329 Error_Msg_N -- CODEFIX
4330 ("?u?renamed constant & is not referenced!", E);
4331 else
4332 Error_Msg_N -- CODEFIX
4333 ("?u?constant & is not referenced!", E);
4334 end if;
4335 end if;
4337 when E_In_Out_Parameter
4338 | E_In_Parameter
4340 -- Do not emit message for formals of a renaming, because they
4341 -- are never referenced explicitly.
4343 if Nkind (Original_Node (Unit_Declaration_Node (Scope (E)))) /=
4344 N_Subprogram_Renaming_Declaration
4345 then
4346 -- Suppress this message for an IN OUT parameter of a
4347 -- non-scalar type, since it is normal to have only an
4348 -- assignment in such a case.
4350 if Ekind (E) = E_In_Parameter
4351 or else not Referenced_As_LHS_Check_Spec (E)
4352 or else Is_Scalar_Type (Etype (E))
4353 then
4354 if Present (Body_E) then
4355 E := Body_E;
4356 end if;
4358 declare
4359 S : Node_Id := Scope (E);
4360 begin
4361 if Ekind (S) = E_Subprogram_Body then
4362 S := Parent (S);
4364 while Nkind (S) not in
4365 N_Expression_Function |
4366 N_Subprogram_Body |
4367 N_Subprogram_Renaming_Declaration |
4368 N_Empty
4369 loop
4370 S := Parent (S);
4371 end loop;
4373 if Present (S) then
4374 S := Corresponding_Spec (S);
4375 end if;
4376 end if;
4378 -- Do not warn for dispatching operations, because
4379 -- that causes too much noise. Also do not warn for
4380 -- trivial subprograms (e.g. stubs).
4382 if (No (S) or else not Is_Dispatching_Operation (S))
4383 and then not Is_Trivial_Subprogram (Scope (E))
4384 and then Check_Unreferenced_Formals
4385 then
4386 Error_Msg_NE -- CODEFIX
4387 ("?f?formal parameter & is not referenced!",
4388 E, Spec_E);
4389 end if;
4390 end;
4391 end if;
4392 end if;
4394 when E_Out_Parameter =>
4395 null;
4397 when E_Discriminant =>
4398 Error_Msg_N ("?u?discriminant & is not referenced!", E);
4400 when E_Named_Integer
4401 | E_Named_Real
4403 Error_Msg_N -- CODEFIX
4404 ("?u?named number & is not referenced!", E);
4406 when Formal_Object_Kind =>
4407 Error_Msg_N -- CODEFIX
4408 ("?u?formal object & is not referenced!", E);
4410 when E_Enumeration_Literal =>
4411 Error_Msg_N -- CODEFIX
4412 ("?u?literal & is not referenced!", E);
4414 when E_Function =>
4415 Error_Msg_N -- CODEFIX
4416 ("?u?function & is not referenced!", E);
4418 when E_Procedure =>
4419 Error_Msg_N -- CODEFIX
4420 ("?u?procedure & is not referenced!", E);
4422 when E_Package =>
4423 Error_Msg_N -- CODEFIX
4424 ("?u?package & is not referenced!", E);
4426 when E_Exception =>
4427 Error_Msg_N -- CODEFIX
4428 ("?u?exception & is not referenced!", E);
4430 when E_Label =>
4431 Error_Msg_N -- CODEFIX
4432 ("?u?label & is not referenced!", E);
4434 when E_Generic_Procedure =>
4435 Error_Msg_N -- CODEFIX
4436 ("?u?generic procedure & is never instantiated!", E);
4438 when E_Generic_Function =>
4439 Error_Msg_N -- CODEFIX
4440 ("?u?generic function & is never instantiated!", E);
4442 when Type_Kind =>
4443 Error_Msg_N -- CODEFIX
4444 ("?u?type & is not referenced!", E);
4446 when others =>
4447 Error_Msg_N -- CODEFIX
4448 ("?u?& is not referenced!", E);
4449 end case;
4451 -- Kill warnings on the entity on which the message has been posted
4452 -- (nothing is posted on out parameters because back end might be
4453 -- able to uncover an uninitialized path, and warn accordingly).
4455 if Ekind (E) /= E_Out_Parameter then
4456 Set_Warnings_Off (E);
4457 end if;
4458 end if;
4459 end Warn_On_Unreferenced_Entity;
4461 --------------------------------
4462 -- Warn_On_Useless_Assignment --
4463 --------------------------------
4465 procedure Warn_On_Useless_Assignment
4466 (Ent : Entity_Id;
4467 N : Node_Id := Empty)
4469 P : Node_Id;
4470 X : Node_Id;
4472 function Check_Ref (N : Node_Id) return Traverse_Result;
4473 -- Used to instantiate Traverse_Func. Returns Abandon if a reference to
4474 -- the entity in question is found.
4476 function Test_No_Refs is new Traverse_Func (Check_Ref);
4478 ---------------
4479 -- Check_Ref --
4480 ---------------
4482 function Check_Ref (N : Node_Id) return Traverse_Result is
4483 begin
4484 -- Check reference to our identifier. We use name equality here
4485 -- because the exception handlers have not yet been analyzed. This
4486 -- is not quite right, but it really does not matter that we fail
4487 -- to output the warning in some obscure cases of name clashes.
4489 if Nkind (N) = N_Identifier and then Chars (N) = Chars (Ent) then
4490 return Abandon;
4491 else
4492 return OK;
4493 end if;
4494 end Check_Ref;
4496 -- Start of processing for Warn_On_Useless_Assignment
4498 begin
4499 -- Check if this is a case we want to warn on, a scalar or access
4500 -- variable with the last assignment field set, with warnings enabled,
4501 -- and which is not imported or exported. We also check that it is OK
4502 -- to capture the value. We are not going to capture any value, but
4503 -- the warning message depends on the same kind of conditions.
4505 -- If the assignment appears as an out-parameter in a call within an
4506 -- expression function it may be detected twice: once when expression
4507 -- itself is analyzed, and once when the constructed body is analyzed.
4508 -- We don't want to emit a spurious warning in this case.
4510 if Is_Assignable (Ent)
4511 and then not Is_Return_Object (Ent)
4512 and then Present (Last_Assignment (Ent))
4513 and then Last_Assignment (Ent) /= N
4514 and then not Is_Imported (Ent)
4515 and then not Is_Exported (Ent)
4516 and then Safe_To_Capture_Value (N, Ent)
4517 and then not Has_Pragma_Unreferenced_Check_Spec (Ent)
4518 and then not Has_Junk_Name (Ent)
4519 then
4520 -- Before we issue the message, check covering exception handlers.
4521 -- Search up tree for enclosing statement sequences and handlers.
4523 P := Parent (Last_Assignment (Ent));
4524 while Present (P) loop
4526 -- Something is really wrong if we don't find a handled statement
4527 -- sequence, so just suppress the warning.
4529 if No (P) then
4530 Set_Last_Assignment (Ent, Empty);
4531 return;
4533 -- When we hit a package/subprogram body, issue warning and exit
4535 elsif Nkind (P) in N_Entry_Body
4536 | N_Package_Body
4537 | N_Subprogram_Body
4538 | N_Task_Body
4539 then
4540 -- Case of assigned value never referenced
4542 if No (N) then
4543 declare
4544 LA : constant Node_Id := Last_Assignment (Ent);
4546 begin
4547 -- Don't give this for OUT and IN OUT formals, since
4548 -- clearly caller may reference the assigned value. Also
4549 -- never give such warnings for internal variables. In
4550 -- either case, word the warning in a conditional way,
4551 -- because in the case of a component of a controlled
4552 -- type, the assigned value might be referenced in the
4553 -- Finalize operation, so we can't make a definitive
4554 -- statement that it's never referenced.
4556 if Ekind (Ent) = E_Variable
4557 and then not Is_Internal_Name (Chars (Ent))
4558 then
4559 -- Give appropriate message, distinguishing between
4560 -- assignment statements and out parameters.
4562 if Nkind (Parent (LA)) in N_Parameter_Association
4563 | N_Procedure_Call_Statement
4564 then
4565 if Warn_On_All_Unread_Out_Parameters then
4566 Error_Msg_NE
4567 ("?.o?& modified by call, but value might not "
4568 & "be referenced", LA, Ent);
4569 end if;
4570 else
4571 Error_Msg_NE -- CODEFIX
4572 ("?m?possibly useless assignment to&, value "
4573 & "might not be referenced!", LA, Ent);
4574 end if;
4575 end if;
4576 end;
4578 -- Case of assigned value overwritten
4580 else
4581 declare
4582 LA : constant Node_Id := Last_Assignment (Ent);
4584 begin
4585 Error_Msg_Sloc := Sloc (N);
4587 -- Give appropriate message, distinguishing between
4588 -- assignment statements and out parameters.
4590 if Nkind (Parent (LA)) in N_Procedure_Call_Statement
4591 | N_Parameter_Association
4592 then
4593 Error_Msg_NE
4594 ("?m?& modified by call, but value overwritten #!",
4595 LA, Ent);
4596 else
4597 Error_Msg_NE -- CODEFIX
4598 ("?m?useless assignment to&, value overwritten #!",
4599 LA, Ent);
4600 end if;
4601 end;
4602 end if;
4604 -- Clear last assignment indication and we are done
4606 Set_Last_Assignment (Ent, Empty);
4607 return;
4609 -- Enclosing handled sequence of statements
4611 elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
4613 -- Check exception handlers present
4615 if Present (Exception_Handlers (P)) then
4617 -- If we are not at the top level, we regard an inner
4618 -- exception handler as a decisive indicator that we should
4619 -- not generate the warning, since the variable in question
4620 -- may be accessed after an exception in the outer block.
4622 if Nkind (Parent (P)) not in N_Entry_Body
4623 | N_Package_Body
4624 | N_Subprogram_Body
4625 | N_Task_Body
4626 then
4627 Set_Last_Assignment (Ent, Empty);
4628 return;
4630 -- Otherwise we are at the outer level. An exception
4631 -- handler is significant only if it references the
4632 -- variable in question, or if the entity in question
4633 -- is an OUT or IN OUT parameter, in which case
4634 -- the caller can reference it after the exception
4635 -- handler completes.
4637 else
4638 if Is_Formal (Ent) then
4639 Set_Last_Assignment (Ent, Empty);
4640 return;
4642 else
4643 X := First (Exception_Handlers (P));
4644 while Present (X) loop
4645 if Test_No_Refs (X) = Abandon then
4646 Set_Last_Assignment (Ent, Empty);
4647 return;
4648 end if;
4650 Next (X);
4651 end loop;
4652 end if;
4653 end if;
4654 end if;
4655 end if;
4657 P := Parent (P);
4658 end loop;
4659 end if;
4660 end Warn_On_Useless_Assignment;
4662 ---------------------------------
4663 -- Warn_On_Useless_Assignments --
4664 ---------------------------------
4666 procedure Warn_On_Useless_Assignments (E : Entity_Id) is
4667 Ent : Entity_Id;
4669 begin
4670 if Warn_On_Modified_Unread
4671 and then In_Extended_Main_Source_Unit (E)
4672 then
4673 Ent := First_Entity (E);
4674 while Present (Ent) loop
4675 Warn_On_Useless_Assignment (Ent);
4676 Next_Entity (Ent);
4677 end loop;
4678 end if;
4679 end Warn_On_Useless_Assignments;
4681 -----------------------------
4682 -- Warnings_Off_Check_Spec --
4683 -----------------------------
4685 function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean is
4686 begin
4687 if Is_Formal (E) and then Present (Spec_Entity (E)) then
4689 -- Note: use of OR here instead of OR ELSE is deliberate, we want
4690 -- to mess with flags on both entities.
4692 return Has_Warnings_Off (E)
4694 Has_Warnings_Off (Spec_Entity (E));
4696 else
4697 return Has_Warnings_Off (E);
4698 end if;
4699 end Warnings_Off_Check_Spec;
4701 end Sem_Warn;