* tree-vect-loop-manip.c (vect_do_peeling): Do not use
[official-gcc.git] / gcc / ada / errout.adb
blob2b9664daac32f58aa6d76928fc5dca5e4aa11240
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E R R O U T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 -- Warning: Error messages can be generated during Gigi processing by direct
27 -- calls to error message routines, so it is essential that the processing
28 -- in this body be consistent with the requirements for the Gigi processing
29 -- environment, and that in particular, no disallowed table expansion is
30 -- allowed to occur.
32 with Atree; use Atree;
33 with Casing; use Casing;
34 with Csets; use Csets;
35 with Debug; use Debug;
36 with Einfo; use Einfo;
37 with Erroutc; use Erroutc;
38 with Gnatvsn; use Gnatvsn;
39 with Lib; use Lib;
40 with Opt; use Opt;
41 with Nlists; use Nlists;
42 with Output; use Output;
43 with Scans; use Scans;
44 with Sem_Aux; use Sem_Aux;
45 with Sinput; use Sinput;
46 with Sinfo; use Sinfo;
47 with Snames; use Snames;
48 with Stand; use Stand;
49 with Stylesw; use Stylesw;
50 with Uname; use Uname;
52 package body Errout is
54 Errors_Must_Be_Ignored : Boolean := False;
55 -- Set to True by procedure Set_Ignore_Errors (True), when calls to error
56 -- message procedures should be ignored (when parsing irrelevant text in
57 -- sources being preprocessed).
59 Finalize_Called : Boolean := False;
60 -- Set True if the Finalize routine has been called
62 Record_Compilation_Errors : Boolean := False;
63 -- Record that a compilation error was witnessed during a given phase of
64 -- analysis for gnat2why. This is needed as Warning_Mode is modified twice
65 -- in gnat2why, hence Erroutc.Compilation_Errors can only return a suitable
66 -- value for each phase of analysis separately. This is updated at each
67 -- call to Compilation_Errors.
69 Warn_On_Instance : Boolean;
70 -- Flag set true for warning message to be posted on instance
72 ------------------------------------
73 -- Table of Non-Instance Messages --
74 ------------------------------------
76 -- This table contains an entry for every error message processed by the
77 -- Error_Msg routine that is not posted on generic (or inlined) instance.
78 -- As explained in further detail in the Error_Msg procedure body, this
79 -- table is used to avoid posting redundant messages on instances.
81 type NIM_Record is record
82 Msg : String_Ptr;
83 Loc : Source_Ptr;
84 end record;
85 -- Type used to store text and location of one message
87 package Non_Instance_Msgs is new Table.Table (
88 Table_Component_Type => NIM_Record,
89 Table_Index_Type => Int,
90 Table_Low_Bound => 1,
91 Table_Initial => 100,
92 Table_Increment => 100,
93 Table_Name => "Non_Instance_Msgs");
95 -----------------------
96 -- Local Subprograms --
97 -----------------------
99 procedure Error_Msg_Internal
100 (Msg : String;
101 Sptr : Source_Ptr;
102 Optr : Source_Ptr;
103 Msg_Cont : Boolean;
104 Node : Node_Id);
105 -- This is the low level routine used to post messages after dealing with
106 -- the issue of messages placed on instantiations (which get broken up
107 -- into separate calls in Error_Msg). Sptr is the location on which the
108 -- flag will be placed in the output. In the case where the flag is on
109 -- the template, this points directly to the template, not to one of the
110 -- instantiation copies of the template. Optr is the original location
111 -- used to flag the error, and this may indeed point to an instantiation
112 -- copy. So typically we can see Optr pointing to the template location
113 -- in an instantiation copy when Sptr points to the source location of
114 -- the actual instantiation (i.e the line with the new). Msg_Cont is
115 -- set true if this is a continuation message. Node is the relevant
116 -- Node_Id for this message, to be used to compute the enclosing entity if
117 -- Opt.Include_Subprogram_In_Messages is set.
119 function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
120 -- Determines if warnings should be suppressed for the given node
122 function OK_Node (N : Node_Id) return Boolean;
123 -- Determines if a node is an OK node to place an error message on (return
124 -- True) or if the error message should be suppressed (return False). A
125 -- message is suppressed if the node already has an error posted on it,
126 -- or if it refers to an Etype that has an error posted on it, or if
127 -- it references an Entity that has an error posted on it.
129 procedure Output_Source_Line
130 (L : Physical_Line_Number;
131 Sfile : Source_File_Index;
132 Errs : Boolean);
133 -- Outputs text of source line L, in file S, together with preceding line
134 -- number, as described above for Output_Line_Number. The Errs parameter
135 -- indicates if there are errors attached to the line, which forces
136 -- listing on, even in the presence of pragma List (Off).
138 procedure Set_Msg_Insertion_Column;
139 -- Handle column number insertion (@ insertion character)
141 procedure Set_Msg_Insertion_Node;
142 -- Handle node (name from node) insertion (& insertion character)
144 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr);
145 -- Handle type reference (right brace insertion character). Flag is the
146 -- location of the flag, which is provided for the internal call to
147 -- Set_Msg_Insertion_Line_Number,
149 procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True);
150 -- Handle unit name insertion ($ insertion character). Depending on Boolean
151 -- parameter Suffix, (spec) or (body) is appended after the unit name.
153 procedure Set_Msg_Node (Node : Node_Id);
154 -- Add the sequence of characters for the name associated with the given
155 -- node to the current message. For N_Designator, N_Selected_Component,
156 -- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is
157 -- included as well.
159 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
160 -- Add a sequence of characters to the current message. The characters may
161 -- be one of the special insertion characters (see documentation in spec).
162 -- Flag is the location at which the error is to be posted, which is used
163 -- to determine whether or not the # insertion needs a file name. The
164 -- variables Msg_Buffer are set on return Msglen.
166 procedure Set_Posted (N : Node_Id);
167 -- Sets the Error_Posted flag on the given node, and all its parents that
168 -- are subexpressions and then on the parent non-subexpression construct
169 -- that contains the original expression. If that parent is a named
170 -- association, the flag is further propagated to its parent. This is done
171 -- in order to guard against cascaded errors. Note that this call has an
172 -- effect for a serious error only.
174 procedure Set_Qualification (N : Nat; E : Entity_Id);
175 -- Outputs up to N levels of qualification for the given entity. For
176 -- example, the entity A.B.C.D will output B.C. if N = 2.
178 function Special_Msg_Delete
179 (Msg : String;
180 N : Node_Or_Entity_Id;
181 E : Node_Or_Entity_Id) return Boolean;
182 -- This function is called from Error_Msg_NEL, passing the message Msg,
183 -- node N on which the error is to be posted, and the entity or node E
184 -- to be used for an & insertion in the message if any. The job of this
185 -- procedure is to test for certain cascaded messages that we would like
186 -- to suppress. If the message is to be suppressed then we return True.
187 -- If the message should be generated (the normal case) False is returned.
189 procedure Unwind_Internal_Type (Ent : in out Entity_Id);
190 -- This procedure is given an entity id for an internal type, i.e. a type
191 -- with an internal name. It unwinds the type to try to get to something
192 -- reasonably printable, generating prefixes like "subtype of", "access
193 -- to", etc along the way in the buffer. The value in Ent on return is the
194 -- final name to be printed. Hopefully this is not an internal name, but in
195 -- some internal name cases, it is an internal name, and has to be printed
196 -- anyway (although in this case the message has been killed if possible).
197 -- The global variable Class_Flag is set to True if the resulting entity
198 -- should have 'Class appended to its name (see Add_Class procedure), and
199 -- is otherwise unchanged.
201 function Warn_Insertion return String;
202 -- This is called for warning messages only (so Warning_Msg_Char is set)
203 -- and returns a corresponding string to use at the beginning of generated
204 -- auxiliary messages, such as "in instantiation at ...".
205 -- 'a' .. 'z' returns "?x?"
206 -- 'A' .. 'Z' returns "?X?"
207 -- '*' returns "?*?"
208 -- '$' returns "?$?info: "
209 -- ' ' returns " "
210 -- No other settings are valid
212 -----------------------
213 -- Change_Error_Text --
214 -----------------------
216 procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is
217 Save_Next : Error_Msg_Id;
218 Err_Id : Error_Msg_Id := Error_Id;
220 begin
221 Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr);
222 Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen));
224 -- If in immediate error message mode, output modified error message now
225 -- This is just a bit tricky, because we want to output just a single
226 -- message, and the messages we modified is already linked in. We solve
227 -- this by temporarily resetting its forward pointer to empty.
229 if Debug_Flag_OO then
230 Save_Next := Errors.Table (Error_Id).Next;
231 Errors.Table (Error_Id).Next := No_Error_Msg;
232 Write_Eol;
233 Output_Source_Line
234 (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);
235 Output_Error_Msgs (Err_Id);
236 Errors.Table (Error_Id).Next := Save_Next;
237 end if;
238 end Change_Error_Text;
240 ------------------------
241 -- Compilation_Errors --
242 ------------------------
244 function Compilation_Errors return Boolean is
245 begin
246 if not Finalize_Called then
247 raise Program_Error;
249 -- Record that a compilation error was witnessed during a given phase of
250 -- analysis for gnat2why. This is needed as Warning_Mode is modified
251 -- twice in gnat2why, hence Erroutc.Compilation_Errors can only return a
252 -- suitable value for each phase of analysis separately.
254 else
255 Record_Compilation_Errors :=
256 Record_Compilation_Errors or else Erroutc.Compilation_Errors;
258 return Record_Compilation_Errors;
259 end if;
260 end Compilation_Errors;
262 --------------------------------------
263 -- Delete_Warning_And_Continuations --
264 --------------------------------------
266 procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id) is
267 Id : Error_Msg_Id;
269 begin
270 pragma Assert (not Errors.Table (Msg).Msg_Cont);
272 Id := Msg;
273 loop
274 declare
275 M : Error_Msg_Object renames Errors.Table (Id);
277 begin
278 if not M.Deleted then
279 M.Deleted := True;
280 Warnings_Detected := Warnings_Detected - 1;
282 if M.Info then
283 Warning_Info_Messages := Warning_Info_Messages - 1;
284 end if;
286 if M.Warn_Err then
287 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1;
288 end if;
289 end if;
291 Id := M.Next;
292 exit when Id = No_Error_Msg;
293 exit when not Errors.Table (Id).Msg_Cont;
294 end;
295 end loop;
296 end Delete_Warning_And_Continuations;
298 ---------------
299 -- Error_Msg --
300 ---------------
302 -- Error_Msg posts a flag at the given location, except that if the
303 -- Flag_Location points within a generic template and corresponds to an
304 -- instantiation of this generic template, then the actual message will be
305 -- posted on the generic instantiation, along with additional messages
306 -- referencing the generic declaration.
308 procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
309 begin
310 Error_Msg (Msg, Flag_Location, Current_Node);
311 end Error_Msg;
313 procedure Error_Msg
314 (Msg : String;
315 Flag_Location : Source_Ptr;
316 N : Node_Id)
318 Sindex : Source_File_Index;
319 -- Source index for flag location
321 Orig_Loc : Source_Ptr;
322 -- Original location of Flag_Location (i.e. location in original
323 -- template in instantiation case, otherwise unchanged).
325 begin
326 -- Return if all errors are to be ignored
328 if Errors_Must_Be_Ignored then
329 return;
330 end if;
332 -- If we already have messages, and we are trying to place a message at
333 -- No_Location, then just ignore the attempt since we assume that what
334 -- is happening is some cascaded junk. Note that this is safe in the
335 -- sense that proceeding will surely bomb. We will also bomb if the flag
336 -- location is No_Location and we don't have any messages so far, but
337 -- that is a real bug and a legitimate bomb, so we go ahead.
339 if Flag_Location = No_Location
340 and then Total_Errors_Detected > 0
341 then
342 return;
343 end if;
345 -- Start of processing for new message
347 Sindex := Get_Source_File_Index (Flag_Location);
348 Prescan_Message (Msg);
349 Orig_Loc := Original_Location (Flag_Location);
351 -- If the current location is in an instantiation, the issue arises of
352 -- whether to post the message on the template or the instantiation.
354 -- The way we decide is to see if we have posted the same message on
355 -- the template when we compiled the template (the template is always
356 -- compiled before any instantiations). For this purpose, we use a
357 -- separate table of messages. The reason we do this is twofold:
359 -- First, the messages can get changed by various processing
360 -- including the insertion of tokens etc, making it hard to
361 -- do the comparison.
363 -- Second, we will suppress a warning on a template if it is not in
364 -- the current extended source unit. That's reasonable and means we
365 -- don't want the warning on the instantiation here either, but it
366 -- does mean that the main error table would not in any case include
367 -- the message.
369 if Flag_Location = Orig_Loc then
370 Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location));
371 Warn_On_Instance := False;
373 -- Here we have an instance message
375 else
376 -- Delete if debug flag off, and this message duplicates a message
377 -- already posted on the corresponding template
379 if not Debug_Flag_GG then
380 for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop
381 if Msg = Non_Instance_Msgs.Table (J).Msg.all
382 and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc
383 then
384 return;
385 end if;
386 end loop;
387 end if;
389 -- No duplicate, so error/warning will be posted on instance
391 Warn_On_Instance := Is_Warning_Msg;
392 end if;
394 -- Ignore warning message that is suppressed for this location. Note
395 -- that style checks are not considered warning messages for this
396 -- purpose.
398 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String
399 then
400 return;
402 -- For style messages, check too many messages so far
404 elsif Is_Style_Msg
405 and then Maximum_Messages /= 0
406 and then Warnings_Detected >= Maximum_Messages
407 then
408 return;
409 end if;
411 -- The idea at this stage is that we have two kinds of messages
413 -- First, we have those messages that are to be placed as requested at
414 -- Flag_Location. This includes messages that have nothing to do with
415 -- generics, and also messages placed on generic templates that reflect
416 -- an error in the template itself. For such messages we simply call
417 -- Error_Msg_Internal to place the message in the requested location.
419 if Instantiation (Sindex) = No_Location then
420 Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N);
421 return;
422 end if;
424 -- If we are trying to flag an error in an instantiation, we may have
425 -- a generic contract violation. What we generate in this case is:
427 -- instantiation error at ...
428 -- original error message
430 -- or
432 -- warning: in instantiation at ...
433 -- warning: original warning message
435 -- or
437 -- info: in instantiation at ...
438 -- info: original info message
440 -- All these messages are posted at the location of the top level
441 -- instantiation. If there are nested instantiations, then the
442 -- instantiation error message can be repeated, pointing to each
443 -- of the relevant instantiations.
445 -- Note: the instantiation mechanism is also shared for inlining of
446 -- subprogram bodies when front end inlining is done. In this case the
447 -- messages have the form:
449 -- in inlined body at ...
450 -- original error message
452 -- or
454 -- warning: in inlined body at ...
455 -- warning: original warning message
457 -- or
459 -- info: in inlined body at ...
460 -- info: original info message
462 -- OK, here we have an instantiation error, and we need to generate the
463 -- error on the instantiation, rather than on the template.
465 declare
466 Actual_Error_Loc : Source_Ptr;
467 -- Location of outer level instantiation in instantiation case, or
468 -- just a copy of Flag_Location in the normal case. This is the
469 -- location where all error messages will actually be posted.
471 Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
472 -- Save possible location set for caller's message. We need to use
473 -- Error_Msg_Sloc for the location of the instantiation error but we
474 -- have to preserve a possible original value.
476 X : Source_File_Index;
478 Msg_Cont_Status : Boolean;
479 -- Used to label continuation lines in instantiation case with
480 -- proper Msg_Cont status.
482 begin
483 -- Loop to find highest level instantiation, where all error
484 -- messages will be placed.
486 X := Sindex;
487 loop
488 Actual_Error_Loc := Instantiation (X);
489 X := Get_Source_File_Index (Actual_Error_Loc);
490 exit when Instantiation (X) = No_Location;
491 end loop;
493 -- Since we are generating the messages at the instantiation point in
494 -- any case, we do not want the references to the bad lines in the
495 -- instance to be annotated with the location of the instantiation.
497 Suppress_Instance_Location := True;
498 Msg_Cont_Status := False;
500 -- Loop to generate instantiation messages
502 Error_Msg_Sloc := Flag_Location;
503 X := Get_Source_File_Index (Flag_Location);
504 while Instantiation (X) /= No_Location loop
506 -- Suppress instantiation message on continuation lines
508 if Msg (Msg'First) /= '\' then
510 -- Case of inlined body
512 if Inlined_Body (X) then
513 if Is_Info_Msg then
514 Error_Msg_Internal
515 (Msg => "info: in inlined body #",
516 Sptr => Actual_Error_Loc,
517 Optr => Flag_Location,
518 Msg_Cont => Msg_Cont_Status,
519 Node => N);
521 elsif Is_Warning_Msg then
522 Error_Msg_Internal
523 (Msg => Warn_Insertion & "in inlined body #",
524 Sptr => Actual_Error_Loc,
525 Optr => Flag_Location,
526 Msg_Cont => Msg_Cont_Status,
527 Node => N);
529 elsif Is_Style_Msg then
530 Error_Msg_Internal
531 (Msg => "style: in inlined body #",
532 Sptr => Actual_Error_Loc,
533 Optr => Flag_Location,
534 Msg_Cont => Msg_Cont_Status,
535 Node => N);
537 else
538 Error_Msg_Internal
539 (Msg => "error in inlined body #",
540 Sptr => Actual_Error_Loc,
541 Optr => Flag_Location,
542 Msg_Cont => Msg_Cont_Status,
543 Node => N);
544 end if;
546 -- Case of generic instantiation
548 else
549 if Is_Info_Msg then
550 Error_Msg_Internal
551 (Msg => "info: in instantiation #",
552 Sptr => Actual_Error_Loc,
553 Optr => Flag_Location,
554 Msg_Cont => Msg_Cont_Status,
555 Node => N);
557 elsif Is_Warning_Msg then
558 Error_Msg_Internal
559 (Msg => Warn_Insertion & "in instantiation #",
560 Sptr => Actual_Error_Loc,
561 Optr => Flag_Location,
562 Msg_Cont => Msg_Cont_Status,
563 Node => N);
565 elsif Is_Style_Msg then
566 Error_Msg_Internal
567 (Msg => "style: in instantiation #",
568 Sptr => Actual_Error_Loc,
569 Optr => Flag_Location,
570 Msg_Cont => Msg_Cont_Status,
571 Node => N);
573 else
574 Error_Msg_Internal
575 (Msg => "instantiation error #",
576 Sptr => Actual_Error_Loc,
577 Optr => Flag_Location,
578 Msg_Cont => Msg_Cont_Status,
579 Node => N);
580 end if;
581 end if;
582 end if;
584 Error_Msg_Sloc := Instantiation (X);
585 X := Get_Source_File_Index (Error_Msg_Sloc);
586 Msg_Cont_Status := True;
587 end loop;
589 Suppress_Instance_Location := False;
590 Error_Msg_Sloc := Save_Error_Msg_Sloc;
592 -- Here we output the original message on the outer instantiation
594 Error_Msg_Internal
595 (Msg => Msg,
596 Sptr => Actual_Error_Loc,
597 Optr => Flag_Location,
598 Msg_Cont => Msg_Cont_Status,
599 Node => N);
600 end;
601 end Error_Msg;
603 --------------------------------
604 -- Error_Msg_Ada_2012_Feature --
605 --------------------------------
607 procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr) is
608 begin
609 if Ada_Version < Ada_2012 then
610 Error_Msg (Feature & " is an Ada 2012 feature", Loc);
612 if No (Ada_Version_Pragma) then
613 Error_Msg ("\unit must be compiled with -gnat2012 switch", Loc);
614 else
615 Error_Msg_Sloc := Sloc (Ada_Version_Pragma);
616 Error_Msg ("\incompatible with Ada version set#", Loc);
617 end if;
618 end if;
619 end Error_Msg_Ada_2012_Feature;
621 ------------------
622 -- Error_Msg_AP --
623 ------------------
625 procedure Error_Msg_AP (Msg : String) is
626 S1 : Source_Ptr;
627 C : Character;
629 begin
630 -- If we had saved the Scan_Ptr value after scanning the previous
631 -- token, then we would have exactly the right place for putting
632 -- the flag immediately at hand. However, that would add at least
633 -- two instructions to a Scan call *just* to service the possibility
634 -- of an Error_Msg_AP call. So instead we reconstruct that value.
636 -- We have two possibilities, start with Prev_Token_Ptr and skip over
637 -- the current token, which is made harder by the possibility that this
638 -- token may be in error, or start with Token_Ptr and work backwards.
639 -- We used to take the second approach, but it's hard because of
640 -- comments, and harder still because things that look like comments
641 -- can appear inside strings. So now we take the first approach.
643 -- Note: in the case where there is no previous token, Prev_Token_Ptr
644 -- is set to Source_First, which is a reasonable position for the
645 -- error flag in this situation.
647 S1 := Prev_Token_Ptr;
648 C := Source (S1);
650 -- If the previous token is a string literal, we need a special approach
651 -- since there may be white space inside the literal and we don't want
652 -- to stop on that white space.
654 -- Note: since this is an error recovery issue anyway, it is not worth
655 -- worrying about special UTF_32 line terminator characters here.
657 if Prev_Token = Tok_String_Literal then
658 loop
659 S1 := S1 + 1;
661 if Source (S1) = C then
662 S1 := S1 + 1;
663 exit when Source (S1) /= C;
664 elsif Source (S1) in Line_Terminator then
665 exit;
666 end if;
667 end loop;
669 -- Character literal also needs special handling
671 elsif Prev_Token = Tok_Char_Literal then
672 S1 := S1 + 3;
674 -- Otherwise we search forward for the end of the current token, marked
675 -- by a line terminator, white space, a comment symbol or if we bump
676 -- into the following token (i.e. the current token).
678 -- Again, it is not worth worrying about UTF_32 special line terminator
679 -- characters in this context, since this is only for error recovery.
681 else
682 while Source (S1) not in Line_Terminator
683 and then Source (S1) /= ' '
684 and then Source (S1) /= ASCII.HT
685 and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')
686 and then S1 /= Token_Ptr
687 loop
688 S1 := S1 + 1;
689 end loop;
690 end if;
692 -- S1 is now set to the location for the flag
694 Error_Msg (Msg, S1);
695 end Error_Msg_AP;
697 ------------------
698 -- Error_Msg_BC --
699 ------------------
701 procedure Error_Msg_BC (Msg : String) is
702 begin
703 -- If we are at end of file, post the flag after the previous token
705 if Token = Tok_EOF then
706 Error_Msg_AP (Msg);
708 -- If we are at start of file, post the flag at the current token
710 elsif Token_Ptr = Source_First (Current_Source_File) then
711 Error_Msg_SC (Msg);
713 -- If the character before the current token is a space or a horizontal
714 -- tab, then we place the flag on this character (in the case of a tab
715 -- we would really like to place it in the "last" character of the tab
716 -- space, but that it too much trouble to worry about).
718 elsif Source (Token_Ptr - 1) = ' '
719 or else Source (Token_Ptr - 1) = ASCII.HT
720 then
721 Error_Msg (Msg, Token_Ptr - 1);
723 -- If there is no space or tab before the current token, then there is
724 -- no room to place the flag before the token, so we place it on the
725 -- token instead (this happens for example at the start of a line).
727 else
728 Error_Msg (Msg, Token_Ptr);
729 end if;
730 end Error_Msg_BC;
732 -------------------
733 -- Error_Msg_CRT --
734 -------------------
736 procedure Error_Msg_CRT (Feature : String; N : Node_Id) is
737 CNRT : constant String := " not allowed in no run time mode";
738 CCRT : constant String := " not supported by configuration>";
740 S : String (1 .. Feature'Length + 1 + CCRT'Length);
741 L : Natural;
743 begin
744 S (1) := '|';
745 S (2 .. Feature'Length + 1) := Feature;
746 L := Feature'Length + 2;
748 if No_Run_Time_Mode then
749 S (L .. L + CNRT'Length - 1) := CNRT;
750 L := L + CNRT'Length - 1;
752 else pragma Assert (Configurable_Run_Time_Mode);
753 S (L .. L + CCRT'Length - 1) := CCRT;
754 L := L + CCRT'Length - 1;
755 end if;
757 Error_Msg_N (S (1 .. L), N);
758 Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;
759 end Error_Msg_CRT;
761 ------------------
762 -- Error_Msg_PT --
763 ------------------
765 procedure Error_Msg_PT (E : Entity_Id; Iface_Prim : Entity_Id) is
766 begin
767 Error_Msg_N
768 ("illegal overriding of subprogram inherited from interface", E);
770 Error_Msg_Sloc := Sloc (Iface_Prim);
772 if Ekind (E) = E_Function then
773 Error_Msg_N
774 ("\first formal of & declared # must be of mode `IN` "
775 & "or access-to-constant", E);
776 else
777 Error_Msg_N
778 ("\first formal of & declared # must be of mode `OUT`, `IN OUT` "
779 & "or access-to-variable", E);
780 end if;
781 end Error_Msg_PT;
783 -----------------
784 -- Error_Msg_F --
785 -----------------
787 procedure Error_Msg_F (Msg : String; N : Node_Id) is
788 begin
789 Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N)));
790 end Error_Msg_F;
792 ------------------
793 -- Error_Msg_FE --
794 ------------------
796 procedure Error_Msg_FE
797 (Msg : String;
798 N : Node_Id;
799 E : Node_Or_Entity_Id)
801 begin
802 Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N)));
803 end Error_Msg_FE;
805 ------------------------
806 -- Error_Msg_Internal --
807 ------------------------
809 procedure Error_Msg_Internal
810 (Msg : String;
811 Sptr : Source_Ptr;
812 Optr : Source_Ptr;
813 Msg_Cont : Boolean;
814 Node : Node_Id)
816 Next_Msg : Error_Msg_Id;
817 -- Pointer to next message at insertion point
819 Prev_Msg : Error_Msg_Id;
820 -- Pointer to previous message at insertion point
822 Temp_Msg : Error_Msg_Id;
824 Warn_Err : Boolean;
825 -- Set if warning to be treated as error
827 procedure Handle_Serious_Error;
828 -- Internal procedure to do all error message handling for a serious
829 -- error message, other than bumping the error counts and arranging
830 -- for the message to be output.
832 --------------------------
833 -- Handle_Serious_Error --
834 --------------------------
836 procedure Handle_Serious_Error is
837 begin
838 -- Turn off code generation if not done already
840 if Operating_Mode = Generate_Code then
841 Operating_Mode := Check_Semantics;
842 Expander_Active := False;
843 end if;
845 -- Set the fatal error flag in the unit table unless we are in
846 -- Try_Semantics mode (in which case we set ignored mode if not
847 -- currently set. This stops the semantics from being performed
848 -- if we find a serious error. This is skipped if we are currently
849 -- dealing with the configuration pragma file.
851 if Current_Source_Unit /= No_Unit then
852 declare
853 U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
854 begin
855 if Try_Semantics then
856 if Fatal_Error (U) = None then
857 Set_Fatal_Error (U, Error_Ignored);
858 end if;
859 else
860 Set_Fatal_Error (U, Error_Detected);
861 end if;
862 end;
863 end if;
864 end Handle_Serious_Error;
866 -- Start of processing for Error_Msg_Internal
868 begin
869 if Raise_Exception_On_Error /= 0 then
870 raise Error_Msg_Exception;
871 end if;
873 Continuation := Msg_Cont;
874 Continuation_New_Line := False;
875 Suppress_Message := False;
876 Kill_Message := False;
877 Set_Msg_Text (Msg, Sptr);
879 -- Kill continuation if parent message killed
881 if Continuation and Last_Killed then
882 return;
883 end if;
885 -- Return without doing anything if message is suppressed
887 if Suppress_Message
888 and then not All_Errors_Mode
889 and then not Is_Warning_Msg
890 and then not Is_Unconditional_Msg
891 then
892 if not Continuation then
893 Last_Killed := True;
894 end if;
896 return;
897 end if;
899 -- Return without doing anything if message is killed and this is not
900 -- the first error message. The philosophy is that if we get a weird
901 -- error message and we already have had a message, then we hope the
902 -- weird message is a junk cascaded message
904 if Kill_Message
905 and then not All_Errors_Mode
906 and then Total_Errors_Detected /= 0
907 then
908 if not Continuation then
909 Last_Killed := True;
910 end if;
912 return;
913 end if;
915 -- Special check for warning message to see if it should be output
917 if Is_Warning_Msg then
919 -- Immediate return if warning message and warnings are suppressed
921 if Warnings_Suppressed (Optr) /= No_String
922 or else
923 Warnings_Suppressed (Sptr) /= No_String
924 then
925 Cur_Msg := No_Error_Msg;
926 return;
927 end if;
929 -- If the flag location is in the main extended source unit then for
930 -- sure we want the warning since it definitely belongs
932 if In_Extended_Main_Source_Unit (Sptr) then
933 null;
935 -- If the main unit has not been read yet. the warning must be on
936 -- a configuration file: gnat.adc or user-defined. This means we
937 -- are not parsing the main unit yet, so skip following checks.
939 elsif No (Cunit (Main_Unit)) then
940 null;
942 -- If the flag location is not in the main extended source unit, then
943 -- we want to eliminate the warning, unless it is in the extended
944 -- main code unit and we want warnings on the instance.
946 elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then
947 null;
949 -- Keep warning if debug flag G set
951 elsif Debug_Flag_GG then
952 null;
954 -- Keep warning if message text contains !!
956 elsif Has_Double_Exclam then
957 null;
959 -- Here is where we delete a warning from a with'ed unit
961 else
962 Cur_Msg := No_Error_Msg;
964 if not Continuation then
965 Last_Killed := True;
966 end if;
968 return;
969 end if;
970 end if;
972 -- If message is to be ignored in special ignore message mode, this is
973 -- where we do this special processing, bypassing message output.
975 if Ignore_Errors_Enable > 0 then
976 if Is_Serious_Error then
977 Handle_Serious_Error;
978 end if;
980 return;
981 end if;
983 -- If error message line length set, and this is a continuation message
984 -- then all we do is to append the text to the text of the last message
985 -- with a comma space separator (eliminating a possible (style) or
986 -- info prefix).
988 if Error_Msg_Line_Length /= 0 and then Continuation then
989 Cur_Msg := Errors.Last;
991 declare
992 Oldm : String_Ptr := Errors.Table (Cur_Msg).Text;
993 Newm : String (1 .. Oldm'Last + 2 + Msglen);
994 Newl : Natural;
995 M : Natural;
997 begin
998 -- First copy old message to new one and free it
1000 Newm (Oldm'Range) := Oldm.all;
1001 Newl := Oldm'Length;
1002 Free (Oldm);
1004 -- Remove (style) or info: at start of message
1006 if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then
1007 M := 9;
1009 elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then
1010 M := 7;
1012 else
1013 M := 1;
1014 end if;
1016 -- Now deal with separation between messages. Normally this is
1017 -- simply comma space, but there are some special cases.
1019 -- If continuation new line, then put actual NL character in msg
1021 if Continuation_New_Line then
1022 Newl := Newl + 1;
1023 Newm (Newl) := ASCII.LF;
1025 -- If continuation message is enclosed in parentheses, then
1026 -- special treatment (don't need a comma, and we want to combine
1027 -- successive parenthetical remarks into a single one with
1028 -- separating commas).
1030 elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then
1032 -- Case where existing message ends in right paren, remove
1033 -- and separate parenthetical remarks with a comma.
1035 if Newm (Newl) = ')' then
1036 Newm (Newl) := ',';
1037 Msg_Buffer (M) := ' ';
1039 -- Case where we are adding new parenthetical comment
1041 else
1042 Newl := Newl + 1;
1043 Newm (Newl) := ' ';
1044 end if;
1046 -- Case where continuation not in parens and no new line
1048 else
1049 Newm (Newl + 1 .. Newl + 2) := ", ";
1050 Newl := Newl + 2;
1051 end if;
1053 -- Append new message
1055 Newm (Newl + 1 .. Newl + Msglen - M + 1) :=
1056 Msg_Buffer (M .. Msglen);
1057 Newl := Newl + Msglen - M + 1;
1058 Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl));
1060 -- Update warning msg flag and message doc char if needed
1062 if Is_Warning_Msg then
1063 if not Errors.Table (Cur_Msg).Warn then
1064 Errors.Table (Cur_Msg).Warn := True;
1065 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
1067 elsif Warning_Msg_Char /= ' ' then
1068 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char;
1069 end if;
1070 end if;
1071 end;
1073 return;
1074 end if;
1076 -- Here we build a new error object
1078 Errors.Append
1079 ((Text => new String'(Msg_Buffer (1 .. Msglen)),
1080 Next => No_Error_Msg,
1081 Prev => No_Error_Msg,
1082 Sptr => Sptr,
1083 Optr => Optr,
1084 Sfile => Get_Source_File_Index (Sptr),
1085 Line => Get_Physical_Line_Number (Sptr),
1086 Col => Get_Column_Number (Sptr),
1087 Warn => Is_Warning_Msg,
1088 Info => Is_Info_Msg,
1089 Check => Is_Check_Msg,
1090 Warn_Err => False, -- reset below
1091 Warn_Chr => Warning_Msg_Char,
1092 Style => Is_Style_Msg,
1093 Serious => Is_Serious_Error,
1094 Uncond => Is_Unconditional_Msg,
1095 Msg_Cont => Continuation,
1096 Deleted => False,
1097 Node => Node));
1098 Cur_Msg := Errors.Last;
1100 -- Test if warning to be treated as error
1102 Warn_Err :=
1103 Is_Warning_Msg
1104 and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
1105 or else
1106 Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg)));
1108 -- Propagate Warn_Err to this message and preceding continuations
1110 for J in reverse 1 .. Errors.Last loop
1111 Errors.Table (J).Warn_Err := Warn_Err;
1112 exit when not Errors.Table (J).Msg_Cont;
1113 end loop;
1115 -- If immediate errors mode set, output error message now. Also output
1116 -- now if the -d1 debug flag is set (so node number message comes out
1117 -- just before actual error message)
1119 if Debug_Flag_OO or else Debug_Flag_1 then
1120 Write_Eol;
1121 Output_Source_Line
1122 (Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Sfile, True);
1123 Temp_Msg := Cur_Msg;
1124 Output_Error_Msgs (Temp_Msg);
1126 -- If not in immediate errors mode, then we insert the message in the
1127 -- error chain for later output by Finalize. The messages are sorted
1128 -- first by unit (main unit comes first), and within a unit by source
1129 -- location (earlier flag location first in the chain).
1131 else
1132 -- First a quick check, does this belong at the very end of the chain
1133 -- of error messages. This saves a lot of time in the normal case if
1134 -- there are lots of messages.
1136 if Last_Error_Msg /= No_Error_Msg
1137 and then Errors.Table (Cur_Msg).Sfile =
1138 Errors.Table (Last_Error_Msg).Sfile
1139 and then (Sptr > Errors.Table (Last_Error_Msg).Sptr
1140 or else
1141 (Sptr = Errors.Table (Last_Error_Msg).Sptr
1142 and then
1143 Optr > Errors.Table (Last_Error_Msg).Optr))
1144 then
1145 Prev_Msg := Last_Error_Msg;
1146 Next_Msg := No_Error_Msg;
1148 -- Otherwise do a full sequential search for the insertion point
1150 else
1151 Prev_Msg := No_Error_Msg;
1152 Next_Msg := First_Error_Msg;
1153 while Next_Msg /= No_Error_Msg loop
1154 exit when
1155 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
1157 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile
1158 then
1159 exit when Sptr < Errors.Table (Next_Msg).Sptr
1160 or else (Sptr = Errors.Table (Next_Msg).Sptr
1161 and then Optr < Errors.Table (Next_Msg).Optr);
1162 end if;
1164 Prev_Msg := Next_Msg;
1165 Next_Msg := Errors.Table (Next_Msg).Next;
1166 end loop;
1167 end if;
1169 -- Now we insert the new message in the error chain.
1171 -- The possible insertion point for the new message is after Prev_Msg
1172 -- and before Next_Msg. However, this is where we do a special check
1173 -- for redundant parsing messages, defined as messages posted on the
1174 -- same line. The idea here is that probably such messages are junk
1175 -- from the parser recovering. In full errors mode, we don't do this
1176 -- deletion, but otherwise such messages are discarded at this stage.
1178 if Prev_Msg /= No_Error_Msg
1179 and then Errors.Table (Prev_Msg).Line =
1180 Errors.Table (Cur_Msg).Line
1181 and then Errors.Table (Prev_Msg).Sfile =
1182 Errors.Table (Cur_Msg).Sfile
1183 and then Compiler_State = Parsing
1184 and then not All_Errors_Mode
1185 then
1186 -- Don't delete unconditional messages and at this stage, don't
1187 -- delete continuation lines; we attempted to delete those earlier
1188 -- if the parent message was deleted.
1190 if not Errors.Table (Cur_Msg).Uncond
1191 and then not Continuation
1192 then
1193 -- Don't delete if prev msg is warning and new msg is an error.
1194 -- This is because we don't want a real error masked by a
1195 -- warning. In all other cases (that is parse errors for the
1196 -- same line that are not unconditional) we do delete the
1197 -- message. This helps to avoid junk extra messages from
1198 -- cascaded parsing errors
1200 if not (Errors.Table (Prev_Msg).Warn
1201 or else
1202 Errors.Table (Prev_Msg).Style)
1203 or else
1204 (Errors.Table (Cur_Msg).Warn
1205 or else
1206 Errors.Table (Cur_Msg).Style)
1207 then
1208 -- All tests passed, delete the message by simply returning
1209 -- without any further processing.
1211 pragma Assert (not Continuation);
1213 Last_Killed := True;
1214 return;
1215 end if;
1216 end if;
1217 end if;
1219 -- Come here if message is to be inserted in the error chain
1221 if not Continuation then
1222 Last_Killed := False;
1223 end if;
1225 if Prev_Msg = No_Error_Msg then
1226 First_Error_Msg := Cur_Msg;
1227 else
1228 Errors.Table (Prev_Msg).Next := Cur_Msg;
1229 end if;
1231 Errors.Table (Cur_Msg).Next := Next_Msg;
1233 if Next_Msg = No_Error_Msg then
1234 Last_Error_Msg := Cur_Msg;
1235 end if;
1236 end if;
1238 -- Bump appropriate statistics counts
1240 if Errors.Table (Cur_Msg).Info then
1242 -- Could be (usually is) both "info" and "warning"
1244 if Errors.Table (Cur_Msg).Warn then
1245 Warning_Info_Messages := Warning_Info_Messages + 1;
1246 Warnings_Detected := Warnings_Detected + 1;
1247 else
1248 Report_Info_Messages := Report_Info_Messages + 1;
1249 end if;
1251 elsif Errors.Table (Cur_Msg).Warn
1252 or else Errors.Table (Cur_Msg).Style
1253 then
1254 Warnings_Detected := Warnings_Detected + 1;
1256 elsif Errors.Table (Cur_Msg).Check then
1257 Check_Messages := Check_Messages + 1;
1259 else
1260 Total_Errors_Detected := Total_Errors_Detected + 1;
1262 if Errors.Table (Cur_Msg).Serious then
1263 Serious_Errors_Detected := Serious_Errors_Detected + 1;
1264 Handle_Serious_Error;
1266 -- If not serious error, set Fatal_Error to indicate ignored error
1268 else
1269 declare
1270 U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
1271 begin
1272 if Fatal_Error (U) = None then
1273 Set_Fatal_Error (U, Error_Ignored);
1274 end if;
1275 end;
1276 end if;
1277 end if;
1279 -- Record warning message issued
1281 if Errors.Table (Cur_Msg).Warn
1282 and then not Errors.Table (Cur_Msg).Msg_Cont
1283 then
1284 Warning_Msg := Cur_Msg;
1285 end if;
1287 -- If too many warnings turn off warnings
1289 if Maximum_Messages /= 0 then
1290 if Warnings_Detected = Maximum_Messages then
1291 Warning_Mode := Suppress;
1292 end if;
1294 -- If too many errors abandon compilation
1296 if Total_Errors_Detected = Maximum_Messages then
1297 raise Unrecoverable_Error;
1298 end if;
1299 end if;
1300 end Error_Msg_Internal;
1302 -----------------
1303 -- Error_Msg_N --
1304 -----------------
1306 procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
1307 begin
1308 Error_Msg_NEL (Msg, N, N, Sloc (N));
1309 end Error_Msg_N;
1311 ------------------
1312 -- Error_Msg_NE --
1313 ------------------
1315 procedure Error_Msg_NE
1316 (Msg : String;
1317 N : Node_Or_Entity_Id;
1318 E : Node_Or_Entity_Id)
1320 begin
1321 Error_Msg_NEL (Msg, N, E, Sloc (N));
1322 end Error_Msg_NE;
1324 -------------------
1325 -- Error_Msg_NEL --
1326 -------------------
1328 procedure Error_Msg_NEL
1329 (Msg : String;
1330 N : Node_Or_Entity_Id;
1331 E : Node_Or_Entity_Id;
1332 Flag_Location : Source_Ptr)
1334 begin
1335 if Special_Msg_Delete (Msg, N, E) then
1336 return;
1337 end if;
1339 Prescan_Message (Msg);
1341 -- Special handling for warning messages
1343 if Is_Warning_Msg then
1345 -- Suppress if no warnings set for either entity or node
1347 if No_Warnings (N) or else No_Warnings (E) then
1349 -- Disable any continuation messages as well
1351 Last_Killed := True;
1352 return;
1353 end if;
1355 -- Suppress if inside loop that is known to be null or is probably
1356 -- null (case where loop executes only if invalid values present).
1357 -- In either case warnings in the loop are likely to be junk.
1359 declare
1360 P : Node_Id;
1362 begin
1363 P := Parent (N);
1364 while Present (P) loop
1365 if Nkind (P) = N_Loop_Statement
1366 and then Suppress_Loop_Warnings (P)
1367 then
1368 return;
1369 end if;
1371 P := Parent (P);
1372 end loop;
1373 end;
1374 end if;
1376 -- Test for message to be output
1378 if All_Errors_Mode
1379 or else Is_Unconditional_Msg
1380 or else Is_Warning_Msg
1381 or else OK_Node (N)
1382 or else (Msg (Msg'First) = '\' and then not Last_Killed)
1383 then
1384 Debug_Output (N);
1385 Error_Msg_Node_1 := E;
1386 Error_Msg (Msg, Flag_Location, N);
1388 else
1389 Last_Killed := True;
1390 end if;
1392 Set_Posted (N);
1393 end Error_Msg_NEL;
1395 ------------------
1396 -- Error_Msg_NW --
1397 ------------------
1399 procedure Error_Msg_NW
1400 (Eflag : Boolean;
1401 Msg : String;
1402 N : Node_Or_Entity_Id)
1404 begin
1405 if Eflag
1406 and then In_Extended_Main_Source_Unit (N)
1407 and then Comes_From_Source (N)
1408 then
1409 Error_Msg_NEL (Msg, N, N, Sloc (N));
1410 end if;
1411 end Error_Msg_NW;
1413 -----------------
1414 -- Error_Msg_S --
1415 -----------------
1417 procedure Error_Msg_S (Msg : String) is
1418 begin
1419 Error_Msg (Msg, Scan_Ptr);
1420 end Error_Msg_S;
1422 ------------------
1423 -- Error_Msg_SC --
1424 ------------------
1426 procedure Error_Msg_SC (Msg : String) is
1427 begin
1428 -- If we are at end of file, post the flag after the previous token
1430 if Token = Tok_EOF then
1431 Error_Msg_AP (Msg);
1433 -- For all other cases the message is posted at the current token
1434 -- pointer position
1436 else
1437 Error_Msg (Msg, Token_Ptr);
1438 end if;
1439 end Error_Msg_SC;
1441 ------------------
1442 -- Error_Msg_SP --
1443 ------------------
1445 procedure Error_Msg_SP (Msg : String) is
1446 begin
1447 -- Note: in the case where there is no previous token, Prev_Token_Ptr
1448 -- is set to Source_First, which is a reasonable position for the
1449 -- error flag in this situation
1451 Error_Msg (Msg, Prev_Token_Ptr);
1452 end Error_Msg_SP;
1454 --------------
1455 -- Finalize --
1456 --------------
1458 procedure Finalize (Last_Call : Boolean) is
1459 Cur : Error_Msg_Id;
1460 Nxt : Error_Msg_Id;
1461 F : Error_Msg_Id;
1463 procedure Delete_Warning (E : Error_Msg_Id);
1464 -- Delete a warning msg if not already deleted and adjust warning count
1466 --------------------
1467 -- Delete_Warning --
1468 --------------------
1470 procedure Delete_Warning (E : Error_Msg_Id) is
1471 begin
1472 if not Errors.Table (E).Deleted then
1473 Errors.Table (E).Deleted := True;
1474 Warnings_Detected := Warnings_Detected - 1;
1476 if Errors.Table (E).Info then
1477 Warning_Info_Messages := Warning_Info_Messages - 1;
1478 end if;
1479 end if;
1480 end Delete_Warning;
1482 -- Start of processing for Finalize
1484 begin
1485 -- Set Prev pointers
1487 Cur := First_Error_Msg;
1488 while Cur /= No_Error_Msg loop
1489 Nxt := Errors.Table (Cur).Next;
1490 exit when Nxt = No_Error_Msg;
1491 Errors.Table (Nxt).Prev := Cur;
1492 Cur := Nxt;
1493 end loop;
1495 -- Eliminate any duplicated error messages from the list. This is
1496 -- done after the fact to avoid problems with Change_Error_Text.
1498 Cur := First_Error_Msg;
1499 while Cur /= No_Error_Msg loop
1500 Nxt := Errors.Table (Cur).Next;
1502 F := Nxt;
1503 while F /= No_Error_Msg
1504 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
1505 loop
1506 Check_Duplicate_Message (Cur, F);
1507 F := Errors.Table (F).Next;
1508 end loop;
1510 Cur := Nxt;
1511 end loop;
1513 -- Mark any messages suppressed by specific warnings as Deleted
1515 Cur := First_Error_Msg;
1516 while Cur /= No_Error_Msg loop
1517 declare
1518 CE : Error_Msg_Object renames Errors.Table (Cur);
1519 Tag : constant String := Get_Warning_Tag (Cur);
1521 begin
1522 if (CE.Warn and not CE.Deleted)
1523 and then
1524 (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /=
1525 No_String
1526 or else
1527 Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /=
1528 No_String)
1529 then
1530 Delete_Warning (Cur);
1532 -- If this is a continuation, delete previous parts of message
1534 F := Cur;
1535 while Errors.Table (F).Msg_Cont loop
1536 F := Errors.Table (F).Prev;
1537 exit when F = No_Error_Msg;
1538 Delete_Warning (F);
1539 end loop;
1541 -- Delete any following continuations
1543 F := Cur;
1544 loop
1545 F := Errors.Table (F).Next;
1546 exit when F = No_Error_Msg;
1547 exit when not Errors.Table (F).Msg_Cont;
1548 Delete_Warning (F);
1549 end loop;
1550 end if;
1551 end;
1553 Cur := Errors.Table (Cur).Next;
1554 end loop;
1556 Finalize_Called := True;
1558 -- Check consistency of specific warnings (may add warnings). We only
1559 -- do this on the last call, after all possible warnings are posted.
1561 if Last_Call then
1562 Validate_Specific_Warnings (Error_Msg'Access);
1563 end if;
1564 end Finalize;
1566 ----------------
1567 -- First_Node --
1568 ----------------
1570 function First_Node (C : Node_Id) return Node_Id is
1571 Orig : constant Node_Id := Original_Node (C);
1572 Loc : constant Source_Ptr := Sloc (Orig);
1573 Sfile : constant Source_File_Index := Get_Source_File_Index (Loc);
1574 Earliest : Node_Id;
1575 Eloc : Source_Ptr;
1577 function Test_Earlier (N : Node_Id) return Traverse_Result;
1578 -- Function applied to every node in the construct
1580 procedure Search_Tree_First is new Traverse_Proc (Test_Earlier);
1581 -- Create traversal procedure
1583 ------------------
1584 -- Test_Earlier --
1585 ------------------
1587 function Test_Earlier (N : Node_Id) return Traverse_Result is
1588 Norig : constant Node_Id := Original_Node (N);
1589 Loc : constant Source_Ptr := Sloc (Norig);
1591 begin
1592 -- Check for earlier
1594 if Loc < Eloc
1596 -- Ignore nodes with no useful location information
1598 and then Loc /= Standard_Location
1599 and then Loc /= No_Location
1601 -- Ignore nodes from a different file. This ensures against cases
1602 -- of strange foreign code somehow being present. We don't want
1603 -- wild placement of messages if that happens.
1605 and then Get_Source_File_Index (Loc) = Sfile
1606 then
1607 Earliest := Norig;
1608 Eloc := Loc;
1609 end if;
1611 return OK_Orig;
1612 end Test_Earlier;
1614 -- Start of processing for First_Node
1616 begin
1617 if Nkind (Orig) in N_Subexpr then
1618 Earliest := Orig;
1619 Eloc := Loc;
1620 Search_Tree_First (Orig);
1621 return Earliest;
1623 else
1624 return Orig;
1625 end if;
1626 end First_Node;
1628 ----------------
1629 -- First_Sloc --
1630 ----------------
1632 function First_Sloc (N : Node_Id) return Source_Ptr is
1633 SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
1634 SF : constant Source_Ptr := Source_First (SI);
1635 F : Node_Id;
1636 S : Source_Ptr;
1638 begin
1639 F := First_Node (N);
1640 S := Sloc (F);
1642 -- The following circuit is a bit subtle. When we have parenthesized
1643 -- expressions, then the Sloc will not record the location of the paren,
1644 -- but we would like to post the flag on the paren. So what we do is to
1645 -- crawl up the tree from the First_Node, adjusting the Sloc value for
1646 -- any parentheses we know are present. Yes, we know this circuit is not
1647 -- 100% reliable (e.g. because we don't record all possible paren level
1648 -- values), but this is only for an error message so it is good enough.
1650 Node_Loop : loop
1651 Paren_Loop : for J in 1 .. Paren_Count (F) loop
1653 -- We don't look more than 12 characters behind the current
1654 -- location, and in any case not past the front of the source.
1656 Search_Loop : for K in 1 .. 12 loop
1657 exit Search_Loop when S = SF;
1659 if Source_Text (SI) (S - 1) = '(' then
1660 S := S - 1;
1661 exit Search_Loop;
1663 elsif Source_Text (SI) (S - 1) <= ' ' then
1664 S := S - 1;
1666 else
1667 exit Search_Loop;
1668 end if;
1669 end loop Search_Loop;
1670 end loop Paren_Loop;
1672 exit Node_Loop when F = N;
1673 F := Parent (F);
1674 exit Node_Loop when Nkind (F) not in N_Subexpr;
1675 end loop Node_Loop;
1677 return S;
1678 end First_Sloc;
1680 -----------------------
1681 -- Get_Ignore_Errors --
1682 -----------------------
1684 function Get_Ignore_Errors return Boolean is
1685 begin
1686 return Errors_Must_Be_Ignored;
1687 end Get_Ignore_Errors;
1689 ----------------
1690 -- Initialize --
1691 ----------------
1693 procedure Initialize is
1694 begin
1695 Errors.Init;
1696 First_Error_Msg := No_Error_Msg;
1697 Last_Error_Msg := No_Error_Msg;
1698 Serious_Errors_Detected := 0;
1699 Total_Errors_Detected := 0;
1700 Cur_Msg := No_Error_Msg;
1701 List_Pragmas.Init;
1703 -- Reset counts for warnings
1705 Reset_Warnings;
1707 -- Initialize warnings tables
1709 Warnings.Init;
1710 Specific_Warnings.Init;
1711 end Initialize;
1713 -----------------
1714 -- No_Warnings --
1715 -----------------
1717 function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
1718 begin
1719 if Error_Posted (N) then
1720 return True;
1722 elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then
1723 return True;
1725 elsif Is_Entity_Name (N)
1726 and then Present (Entity (N))
1727 and then Has_Warnings_Off (Entity (N))
1728 then
1729 return True;
1731 else
1732 return False;
1733 end if;
1734 end No_Warnings;
1736 -------------
1737 -- OK_Node --
1738 -------------
1740 function OK_Node (N : Node_Id) return Boolean is
1741 K : constant Node_Kind := Nkind (N);
1743 begin
1744 if Error_Posted (N) then
1745 return False;
1747 elsif K in N_Has_Etype
1748 and then Present (Etype (N))
1749 and then Error_Posted (Etype (N))
1750 then
1751 return False;
1753 elsif (K in N_Op
1754 or else K = N_Attribute_Reference
1755 or else K = N_Character_Literal
1756 or else K = N_Expanded_Name
1757 or else K = N_Identifier
1758 or else K = N_Operator_Symbol)
1759 and then Present (Entity (N))
1760 and then Error_Posted (Entity (N))
1761 then
1762 return False;
1763 else
1764 return True;
1765 end if;
1766 end OK_Node;
1768 ---------------------
1769 -- Output_Messages --
1770 ---------------------
1772 procedure Output_Messages is
1773 E : Error_Msg_Id;
1774 Err_Flag : Boolean;
1776 procedure Write_Error_Summary;
1777 -- Write error summary
1779 procedure Write_Header (Sfile : Source_File_Index);
1780 -- Write header line (compiling or checking given file)
1782 procedure Write_Max_Errors;
1783 -- Write message if max errors reached
1785 -------------------------
1786 -- Write_Error_Summary --
1787 -------------------------
1789 procedure Write_Error_Summary is
1790 begin
1791 -- Extra blank line if error messages or source listing were output
1793 if Total_Errors_Detected + Warnings_Detected > 0 or else Full_List
1794 then
1795 Write_Eol;
1796 end if;
1798 -- Message giving number of lines read and number of errors detected.
1799 -- This normally goes to Standard_Output. The exception is when brief
1800 -- mode is not set, verbose mode (or full list mode) is set, and
1801 -- there are errors. In this case we send the message to standard
1802 -- error to make sure that *something* appears on standard error
1803 -- in an error situation.
1805 if Total_Errors_Detected + Warnings_Detected /= 0
1806 and then not Brief_Output
1807 and then (Verbose_Mode or Full_List)
1808 then
1809 Set_Standard_Error;
1810 end if;
1812 -- Message giving total number of lines. Don't give this message if
1813 -- the Main_Source line is unknown (this happens in error situations,
1814 -- e.g. when integrated preprocessing fails).
1816 if Main_Source_File > No_Source_File then
1817 Write_Str (" ");
1818 Write_Int (Num_Source_Lines (Main_Source_File));
1820 if Num_Source_Lines (Main_Source_File) = 1 then
1821 Write_Str (" line: ");
1822 else
1823 Write_Str (" lines: ");
1824 end if;
1825 end if;
1827 if Total_Errors_Detected = 0 then
1828 Write_Str ("No errors");
1830 elsif Total_Errors_Detected = 1 then
1831 Write_Str ("1 error");
1833 else
1834 Write_Int (Total_Errors_Detected);
1835 Write_Str (" errors");
1836 end if;
1838 if Warnings_Detected - Warning_Info_Messages /= 0 then
1839 Write_Str (", ");
1840 Write_Int (Warnings_Detected);
1841 Write_Str (" warning");
1843 if Warnings_Detected - Warning_Info_Messages /= 1 then
1844 Write_Char ('s');
1845 end if;
1847 if Warning_Mode = Treat_As_Error then
1848 Write_Str (" (treated as error");
1850 if Warnings_Detected /= 1 then
1851 Write_Char ('s');
1852 end if;
1854 Write_Char (')');
1856 elsif Warnings_Treated_As_Errors /= 0 then
1857 Write_Str (" (");
1858 Write_Int (Warnings_Treated_As_Errors);
1859 Write_Str (" treated as errors)");
1860 end if;
1861 end if;
1863 if Warning_Info_Messages + Report_Info_Messages /= 0 then
1864 Write_Str (", ");
1865 Write_Int (Warning_Info_Messages + Report_Info_Messages);
1866 Write_Str (" info message");
1868 if Warning_Info_Messages + Report_Info_Messages > 1 then
1869 Write_Char ('s');
1870 end if;
1871 end if;
1873 Write_Eol;
1874 Set_Standard_Output;
1875 end Write_Error_Summary;
1877 ------------------
1878 -- Write_Header --
1879 ------------------
1881 procedure Write_Header (Sfile : Source_File_Index) is
1882 begin
1883 if Verbose_Mode or Full_List then
1884 if Original_Operating_Mode = Generate_Code then
1885 Write_Str ("Compiling: ");
1886 else
1887 Write_Str ("Checking: ");
1888 end if;
1890 Write_Name (Full_File_Name (Sfile));
1892 if not Debug_Flag_7 then
1893 Write_Eol;
1894 Write_Str ("Source file time stamp: ");
1895 Write_Time_Stamp (Sfile);
1896 Write_Eol;
1897 Write_Str ("Compiled at: " & Compilation_Time);
1898 end if;
1900 Write_Eol;
1901 end if;
1902 end Write_Header;
1904 ----------------------
1905 -- Write_Max_Errors --
1906 ----------------------
1908 procedure Write_Max_Errors is
1909 begin
1910 if Maximum_Messages /= 0 then
1911 if Warnings_Detected >= Maximum_Messages then
1912 Set_Standard_Error;
1913 Write_Line ("maximum number of warnings output");
1914 Write_Line ("any further warnings suppressed");
1915 Set_Standard_Output;
1916 end if;
1918 -- If too many errors print message
1920 if Total_Errors_Detected >= Maximum_Messages then
1921 Set_Standard_Error;
1922 Write_Line ("fatal error: maximum number of errors detected");
1923 Set_Standard_Output;
1924 end if;
1925 end if;
1926 end Write_Max_Errors;
1928 -- Start of processing for Output_Messages
1930 begin
1931 -- Error if Finalize has not been called
1933 if not Finalize_Called then
1934 raise Program_Error;
1935 end if;
1937 -- Reset current error source file if the main unit has a pragma
1938 -- Source_Reference. This ensures outputting the proper name of
1939 -- the source file in this situation.
1941 if Main_Source_File <= No_Source_File
1942 or else Num_SRef_Pragmas (Main_Source_File) /= 0
1943 then
1944 Current_Error_Source_File := No_Source_File;
1945 end if;
1947 -- Brief Error mode
1949 if Brief_Output or (not Full_List and not Verbose_Mode) then
1950 Set_Standard_Error;
1952 E := First_Error_Msg;
1953 while E /= No_Error_Msg loop
1954 if not Errors.Table (E).Deleted and then not Debug_Flag_KK then
1955 if Full_Path_Name_For_Brief_Errors then
1956 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
1957 else
1958 Write_Name (Reference_Name (Errors.Table (E).Sfile));
1959 end if;
1961 Write_Char (':');
1962 Write_Int (Int (Physical_To_Logical
1963 (Errors.Table (E).Line,
1964 Errors.Table (E).Sfile)));
1965 Write_Char (':');
1967 if Errors.Table (E).Col < 10 then
1968 Write_Char ('0');
1969 end if;
1971 Write_Int (Int (Errors.Table (E).Col));
1972 Write_Str (": ");
1973 Output_Msg_Text (E);
1974 Write_Eol;
1975 end if;
1977 E := Errors.Table (E).Next;
1978 end loop;
1980 Set_Standard_Output;
1981 end if;
1983 -- Full source listing case
1985 if Full_List then
1986 List_Pragmas_Index := 1;
1987 List_Pragmas_Mode := True;
1988 E := First_Error_Msg;
1990 -- Normal case, to stdout (copyright notice already output)
1992 if Full_List_File_Name = null then
1993 if not Debug_Flag_7 then
1994 Write_Eol;
1995 end if;
1997 -- Output to file
1999 else
2000 Create_List_File_Access.all (Full_List_File_Name.all);
2001 Set_Special_Output (Write_List_Info_Access.all'Access);
2003 -- Write copyright notice to file
2005 if not Debug_Flag_7 then
2006 Write_Str ("GNAT ");
2007 Write_Str (Gnat_Version_String);
2008 Write_Eol;
2009 Write_Str ("Copyright 1992-" &
2010 Current_Year &
2011 ", Free Software Foundation, Inc.");
2012 Write_Eol;
2013 end if;
2014 end if;
2016 -- First list extended main source file units with errors
2018 for U in Main_Unit .. Last_Unit loop
2019 if In_Extended_Main_Source_Unit (Cunit_Entity (U))
2021 -- If debug flag d.m is set, only the main source is listed
2023 and then (U = Main_Unit or else not Debug_Flag_Dot_M)
2025 -- If the unit of the entity does not come from source, it is
2026 -- an implicit subprogram declaration for a child subprogram.
2027 -- Do not emit errors for it, they are listed with the body.
2029 and then
2030 (No (Cunit_Entity (U))
2031 or else Comes_From_Source (Cunit_Entity (U))
2032 or else not Is_Subprogram (Cunit_Entity (U)))
2034 -- If the compilation unit associated with this unit does not
2035 -- come from source, it means it is an instantiation that should
2036 -- not be included in the source listing.
2038 and then Comes_From_Source (Cunit (U))
2039 then
2040 declare
2041 Sfile : constant Source_File_Index := Source_Index (U);
2043 begin
2044 Write_Eol;
2046 -- Only write the header if Sfile is known
2048 if Sfile > No_Source_File then
2049 Write_Header (Sfile);
2050 Write_Eol;
2051 end if;
2053 -- Normally, we don't want an "error messages from file"
2054 -- message when listing the entire file, so we set the
2055 -- current source file as the current error source file.
2056 -- However, the old style of doing things was to list this
2057 -- message if pragma Source_Reference is present, even for
2058 -- the main unit. Since the purpose of the -gnatd.m switch
2059 -- is to duplicate the old behavior, we skip the reset if
2060 -- this debug flag is set.
2062 if not Debug_Flag_Dot_M then
2063 Current_Error_Source_File := Sfile;
2064 end if;
2066 -- Only output the listing if Sfile is known, to avoid
2067 -- crashing the compiler.
2069 if Sfile > No_Source_File then
2070 for N in 1 .. Last_Source_Line (Sfile) loop
2071 while E /= No_Error_Msg
2072 and then Errors.Table (E).Deleted
2073 loop
2074 E := Errors.Table (E).Next;
2075 end loop;
2077 Err_Flag :=
2078 E /= No_Error_Msg
2079 and then Errors.Table (E).Line = N
2080 and then Errors.Table (E).Sfile = Sfile;
2082 Output_Source_Line (N, Sfile, Err_Flag);
2084 if Err_Flag then
2085 Output_Error_Msgs (E);
2087 if not Debug_Flag_2 then
2088 Write_Eol;
2089 end if;
2090 end if;
2091 end loop;
2092 end if;
2093 end;
2094 end if;
2095 end loop;
2097 -- Then output errors, if any, for subsidiary units not in the
2098 -- main extended unit.
2100 -- Note: if debug flag d.m set, include errors for any units other
2101 -- than the main unit in the extended source unit (e.g. spec and
2102 -- subunits for a body).
2104 while E /= No_Error_Msg
2105 and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr)
2106 or else
2107 (Debug_Flag_Dot_M
2108 and then Get_Source_Unit
2109 (Errors.Table (E).Sptr) /= Main_Unit))
2110 loop
2111 if Errors.Table (E).Deleted then
2112 E := Errors.Table (E).Next;
2114 else
2115 Write_Eol;
2116 Output_Source_Line
2117 (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
2118 Output_Error_Msgs (E);
2119 end if;
2120 end loop;
2122 -- If output to file, write extra copy of error summary to the
2123 -- output file, and then close it.
2125 if Full_List_File_Name /= null then
2126 Write_Error_Summary;
2127 Write_Max_Errors;
2128 Close_List_File_Access.all;
2129 Cancel_Special_Output;
2130 end if;
2131 end if;
2133 -- Verbose mode (error lines only with error flags). Normally this is
2134 -- ignored in full list mode, unless we are listing to a file, in which
2135 -- case we still generate -gnatv output to standard output.
2137 if Verbose_Mode
2138 and then (not Full_List or else Full_List_File_Name /= null)
2139 then
2140 Write_Eol;
2142 -- Output the header only when Main_Source_File is known
2144 if Main_Source_File > No_Source_File then
2145 Write_Header (Main_Source_File);
2146 end if;
2148 E := First_Error_Msg;
2150 -- Loop through error lines
2152 while E /= No_Error_Msg loop
2153 if Errors.Table (E).Deleted then
2154 E := Errors.Table (E).Next;
2155 else
2156 Write_Eol;
2157 Output_Source_Line
2158 (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
2159 Output_Error_Msgs (E);
2160 end if;
2161 end loop;
2162 end if;
2164 -- Output error summary if verbose or full list mode
2166 if Verbose_Mode or else Full_List then
2167 Write_Error_Summary;
2168 end if;
2170 Write_Max_Errors;
2172 -- Even though Warning_Info_Messages are a subclass of warnings, they
2173 -- must not be treated as errors when -gnatwe is in effect.
2175 if Warning_Mode = Treat_As_Error then
2176 Total_Errors_Detected :=
2177 Total_Errors_Detected + Warnings_Detected - Warning_Info_Messages;
2178 Warnings_Detected := Warning_Info_Messages;
2179 end if;
2180 end Output_Messages;
2182 ------------------------
2183 -- Output_Source_Line --
2184 ------------------------
2186 procedure Output_Source_Line
2187 (L : Physical_Line_Number;
2188 Sfile : Source_File_Index;
2189 Errs : Boolean)
2191 S : Source_Ptr;
2192 C : Character;
2194 Line_Number_Output : Boolean := False;
2195 -- Set True once line number is output
2197 Empty_Line : Boolean := True;
2198 -- Set False if line includes at least one character
2200 begin
2201 if Sfile /= Current_Error_Source_File then
2202 Write_Str ("==============Error messages for ");
2204 case Sinput.File_Type (Sfile) is
2205 when Sinput.Src =>
2206 Write_Str ("source");
2208 when Sinput.Config =>
2209 Write_Str ("configuration pragmas");
2211 when Sinput.Def =>
2212 Write_Str ("symbol definition");
2214 when Sinput.Preproc =>
2215 Write_Str ("preprocessing data");
2216 end case;
2218 Write_Str (" file: ");
2219 Write_Name (Full_File_Name (Sfile));
2220 Write_Eol;
2222 if Num_SRef_Pragmas (Sfile) > 0 then
2223 Write_Str ("--------------Line numbers from file: ");
2224 Write_Name (Full_Ref_Name (Sfile));
2225 Write_Str (" (starting at line ");
2226 Write_Int (Int (First_Mapped_Line (Sfile)));
2227 Write_Char (')');
2228 Write_Eol;
2229 end if;
2231 Current_Error_Source_File := Sfile;
2232 end if;
2234 if Errs or List_Pragmas_Mode then
2235 Output_Line_Number (Physical_To_Logical (L, Sfile));
2236 Line_Number_Output := True;
2237 end if;
2239 S := Line_Start (L, Sfile);
2241 loop
2242 C := Source_Text (Sfile) (S);
2243 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
2245 -- Deal with matching entry in List_Pragmas table
2247 if Full_List
2248 and then List_Pragmas_Index <= List_Pragmas.Last
2249 and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc
2250 then
2251 case List_Pragmas.Table (List_Pragmas_Index).Ptyp is
2252 when Page =>
2253 Write_Char (C);
2255 -- Ignore if on line with errors so that error flags
2256 -- get properly listed with the error line .
2258 if not Errs then
2259 Write_Char (ASCII.FF);
2260 end if;
2262 when List_On =>
2263 List_Pragmas_Mode := True;
2265 if not Line_Number_Output then
2266 Output_Line_Number (Physical_To_Logical (L, Sfile));
2267 Line_Number_Output := True;
2268 end if;
2270 Write_Char (C);
2272 when List_Off =>
2273 Write_Char (C);
2274 List_Pragmas_Mode := False;
2275 end case;
2277 List_Pragmas_Index := List_Pragmas_Index + 1;
2279 -- Normal case (no matching entry in List_Pragmas table)
2281 else
2282 if Errs or List_Pragmas_Mode then
2283 Write_Char (C);
2284 end if;
2285 end if;
2287 Empty_Line := False;
2288 S := S + 1;
2289 end loop;
2291 -- If we have output a source line, then add the line terminator, with
2292 -- training spaces preserved (so we output the line exactly as input).
2294 if Line_Number_Output then
2295 if Empty_Line then
2296 Write_Eol;
2297 else
2298 Write_Eol_Keep_Blanks;
2299 end if;
2300 end if;
2301 end Output_Source_Line;
2303 -----------------------------
2304 -- Remove_Warning_Messages --
2305 -----------------------------
2307 procedure Remove_Warning_Messages (N : Node_Id) is
2309 function Check_For_Warning (N : Node_Id) return Traverse_Result;
2310 -- This function checks one node for a possible warning message
2312 function Check_All_Warnings is new Traverse_Func (Check_For_Warning);
2313 -- This defines the traversal operation
2315 -----------------------
2316 -- Check_For_Warning --
2317 -----------------------
2319 function Check_For_Warning (N : Node_Id) return Traverse_Result is
2320 Loc : constant Source_Ptr := Sloc (N);
2321 E : Error_Msg_Id;
2323 function To_Be_Removed (E : Error_Msg_Id) return Boolean;
2324 -- Returns True for a message that is to be removed. Also adjusts
2325 -- warning count appropriately.
2327 -------------------
2328 -- To_Be_Removed --
2329 -------------------
2331 function To_Be_Removed (E : Error_Msg_Id) return Boolean is
2332 begin
2333 if E /= No_Error_Msg
2335 -- Don't remove if location does not match
2337 and then Errors.Table (E).Optr = Loc
2339 -- Don't remove if not warning/info message. Note that we do
2340 -- not remove style messages here. They are warning messages
2341 -- but not ones we want removed in this context.
2343 and then Errors.Table (E).Warn
2345 -- Don't remove unconditional messages
2347 and then not Errors.Table (E).Uncond
2348 then
2349 Warnings_Detected := Warnings_Detected - 1;
2351 if Errors.Table (E).Info then
2352 Warning_Info_Messages := Warning_Info_Messages - 1;
2353 end if;
2355 return True;
2357 -- No removal required
2359 else
2360 return False;
2361 end if;
2362 end To_Be_Removed;
2364 -- Start of processing for Check_For_Warnings
2366 begin
2367 while To_Be_Removed (First_Error_Msg) loop
2368 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
2369 end loop;
2371 if First_Error_Msg = No_Error_Msg then
2372 Last_Error_Msg := No_Error_Msg;
2373 end if;
2375 E := First_Error_Msg;
2376 while E /= No_Error_Msg loop
2377 while To_Be_Removed (Errors.Table (E).Next) loop
2378 Errors.Table (E).Next :=
2379 Errors.Table (Errors.Table (E).Next).Next;
2381 if Errors.Table (E).Next = No_Error_Msg then
2382 Last_Error_Msg := E;
2383 end if;
2384 end loop;
2386 E := Errors.Table (E).Next;
2387 end loop;
2389 if Nkind (N) = N_Raise_Constraint_Error
2390 and then Original_Node (N) /= N
2391 and then No (Condition (N))
2392 then
2393 -- Warnings may have been posted on subexpressions of the original
2394 -- tree. We place the original node back on the tree to remove
2395 -- those warnings, whose sloc do not match those of any node in
2396 -- the current tree. Given that we are in unreachable code, this
2397 -- modification to the tree is harmless.
2399 declare
2400 Status : Traverse_Final_Result;
2402 begin
2403 if Is_List_Member (N) then
2404 Set_Condition (N, Original_Node (N));
2405 Status := Check_All_Warnings (Condition (N));
2406 else
2407 Rewrite (N, Original_Node (N));
2408 Status := Check_All_Warnings (N);
2409 end if;
2411 return Status;
2412 end;
2414 else
2415 return OK;
2416 end if;
2417 end Check_For_Warning;
2419 -- Start of processing for Remove_Warning_Messages
2421 begin
2422 if Warnings_Detected /= 0 then
2423 declare
2424 Discard : Traverse_Final_Result;
2425 pragma Warnings (Off, Discard);
2427 begin
2428 Discard := Check_All_Warnings (N);
2429 end;
2430 end if;
2431 end Remove_Warning_Messages;
2433 procedure Remove_Warning_Messages (L : List_Id) is
2434 Stat : Node_Id;
2435 begin
2436 if Is_Non_Empty_List (L) then
2437 Stat := First (L);
2438 while Present (Stat) loop
2439 Remove_Warning_Messages (Stat);
2440 Next (Stat);
2441 end loop;
2442 end if;
2443 end Remove_Warning_Messages;
2445 --------------------
2446 -- Reset_Warnings --
2447 --------------------
2449 procedure Reset_Warnings is
2450 begin
2451 Warnings_Treated_As_Errors := 0;
2452 Warnings_Detected := 0;
2453 Warning_Info_Messages := 0;
2454 Warnings_As_Errors_Count := 0;
2455 end Reset_Warnings;
2457 ----------------------
2458 -- Adjust_Name_Case --
2459 ----------------------
2461 procedure Adjust_Name_Case
2462 (Buf : in out Bounded_String;
2463 Loc : Source_Ptr)
2465 begin
2466 -- We have an all lower case name from Namet, and now we want to set
2467 -- the appropriate case. If possible we copy the actual casing from
2468 -- the source. If not we use standard identifier casing.
2470 declare
2471 Src_Ind : constant Source_File_Index := Get_Source_File_Index (Loc);
2472 Sbuffer : Source_Buffer_Ptr;
2473 Ref_Ptr : Integer;
2474 Src_Ptr : Source_Ptr;
2476 begin
2477 Ref_Ptr := 1;
2478 Src_Ptr := Loc;
2480 -- For standard locations, always use mixed case
2482 if Loc <= No_Location then
2483 Set_Casing (Mixed_Case);
2485 else
2486 -- Determine if the reference we are dealing with corresponds to
2487 -- text at the point of the error reference. This will often be
2488 -- the case for simple identifier references, and is the case
2489 -- where we can copy the casing from the source.
2491 Sbuffer := Source_Text (Src_Ind);
2493 while Ref_Ptr <= Buf.Length loop
2494 exit when
2495 Fold_Lower (Sbuffer (Src_Ptr)) /=
2496 Fold_Lower (Buf.Chars (Ref_Ptr));
2497 Ref_Ptr := Ref_Ptr + 1;
2498 Src_Ptr := Src_Ptr + 1;
2499 end loop;
2501 -- If we get through the loop without a mismatch, then output the
2502 -- name the way it is cased in the source program
2504 if Ref_Ptr > Buf.Length then
2505 Src_Ptr := Loc;
2507 for J in 1 .. Buf.Length loop
2508 Buf.Chars (J) := Sbuffer (Src_Ptr);
2509 Src_Ptr := Src_Ptr + 1;
2510 end loop;
2512 -- Otherwise set the casing using the default identifier casing
2514 else
2515 Set_Casing (Buf, Identifier_Casing (Src_Ind));
2516 end if;
2517 end if;
2518 end;
2519 end Adjust_Name_Case;
2521 procedure Adjust_Name_Case (Loc : Source_Ptr) is
2522 begin
2523 Adjust_Name_Case (Global_Name_Buffer, Loc);
2524 end Adjust_Name_Case;
2526 ---------------------------
2527 -- Set_Identifier_Casing --
2528 ---------------------------
2530 procedure Set_Identifier_Casing
2531 (Identifier_Name : System.Address;
2532 File_Name : System.Address)
2534 Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name);
2535 File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name);
2536 Flen : Natural;
2538 Desired_Case : Casing_Type := Mixed_Case;
2539 -- Casing required for result. Default value of Mixed_Case is used if
2540 -- for some reason we cannot find the right file name in the table.
2542 begin
2543 -- Get length of file name
2545 Flen := 0;
2546 while File (Flen + 1) /= ASCII.NUL loop
2547 Flen := Flen + 1;
2548 end loop;
2550 -- Loop through file names to find matching one. This is a bit slow, but
2551 -- we only do it in error situations so it is not so terrible. Note that
2552 -- if the loop does not exit, then the desired case will be left set to
2553 -- Mixed_Case, this can happen if the name was not in canonical form.
2555 for J in 1 .. Last_Source_File loop
2556 Get_Name_String (Full_Debug_Name (J));
2558 if Name_Len = Flen
2559 and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen))
2560 then
2561 Desired_Case := Identifier_Casing (J);
2562 exit;
2563 end if;
2564 end loop;
2566 -- Copy identifier as given to Name_Buffer
2568 for J in Name_Buffer'Range loop
2569 Name_Buffer (J) := Ident (J);
2571 if Name_Buffer (J) = ASCII.NUL then
2572 Name_Len := J - 1;
2573 exit;
2574 end if;
2575 end loop;
2577 Set_Casing (Desired_Case);
2578 end Set_Identifier_Casing;
2580 -----------------------
2581 -- Set_Ignore_Errors --
2582 -----------------------
2584 procedure Set_Ignore_Errors (To : Boolean) is
2585 begin
2586 Errors_Must_Be_Ignored := To;
2587 end Set_Ignore_Errors;
2589 ------------------------------
2590 -- Set_Msg_Insertion_Column --
2591 ------------------------------
2593 procedure Set_Msg_Insertion_Column is
2594 begin
2595 if RM_Column_Check then
2596 Set_Msg_Str (" in column ");
2597 Set_Msg_Int (Int (Error_Msg_Col) + 1);
2598 end if;
2599 end Set_Msg_Insertion_Column;
2601 ----------------------------
2602 -- Set_Msg_Insertion_Node --
2603 ----------------------------
2605 procedure Set_Msg_Insertion_Node is
2606 K : Node_Kind;
2608 begin
2609 Suppress_Message :=
2610 Error_Msg_Node_1 = Error
2611 or else Error_Msg_Node_1 = Any_Type;
2613 if Error_Msg_Node_1 = Empty then
2614 Set_Msg_Blank_Conditional;
2615 Set_Msg_Str ("<empty>");
2617 elsif Error_Msg_Node_1 = Error then
2618 Set_Msg_Blank;
2619 Set_Msg_Str ("<error>");
2621 elsif Error_Msg_Node_1 = Standard_Void_Type then
2622 Set_Msg_Blank;
2623 Set_Msg_Str ("procedure name");
2625 elsif Nkind (Error_Msg_Node_1) in N_Entity
2626 and then Ekind (Error_Msg_Node_1) = E_Anonymous_Access_Subprogram_Type
2627 then
2628 Set_Msg_Blank;
2629 Set_Msg_Str ("access to subprogram");
2631 else
2632 Set_Msg_Blank_Conditional;
2634 -- Output name
2636 K := Nkind (Error_Msg_Node_1);
2638 -- If we have operator case, skip quotes since name of operator
2639 -- itself will supply the required quotations. An operator can be an
2640 -- applied use in an expression or an explicit operator symbol, or an
2641 -- identifier whose name indicates it is an operator.
2643 if K in N_Op
2644 or else K = N_Operator_Symbol
2645 or else K = N_Defining_Operator_Symbol
2646 or else ((K = N_Identifier or else K = N_Defining_Identifier)
2647 and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
2648 then
2649 Set_Msg_Node (Error_Msg_Node_1);
2651 -- Normal case, not an operator, surround with quotes
2653 else
2654 Set_Msg_Quote;
2655 Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1);
2656 Set_Msg_Node (Error_Msg_Node_1);
2657 Set_Msg_Quote;
2658 end if;
2659 end if;
2661 -- The following assignment ensures that a second ampersand insertion
2662 -- character will correspond to the Error_Msg_Node_2 parameter. We
2663 -- suppress possible validity checks in case operating in -gnatVa mode,
2664 -- and Error_Msg_Node_2 is not needed and has not been set.
2666 declare
2667 pragma Suppress (Range_Check);
2668 begin
2669 Error_Msg_Node_1 := Error_Msg_Node_2;
2670 end;
2671 end Set_Msg_Insertion_Node;
2673 --------------------------------------
2674 -- Set_Msg_Insertion_Type_Reference --
2675 --------------------------------------
2677 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is
2678 Ent : Entity_Id;
2680 begin
2681 Set_Msg_Blank;
2683 if Error_Msg_Node_1 = Standard_Void_Type then
2684 Set_Msg_Str ("package or procedure name");
2685 return;
2687 elsif Error_Msg_Node_1 = Standard_Exception_Type then
2688 Set_Msg_Str ("exception name");
2689 return;
2691 elsif Error_Msg_Node_1 = Any_Access
2692 or else Error_Msg_Node_1 = Any_Array
2693 or else Error_Msg_Node_1 = Any_Boolean
2694 or else Error_Msg_Node_1 = Any_Character
2695 or else Error_Msg_Node_1 = Any_Composite
2696 or else Error_Msg_Node_1 = Any_Discrete
2697 or else Error_Msg_Node_1 = Any_Fixed
2698 or else Error_Msg_Node_1 = Any_Integer
2699 or else Error_Msg_Node_1 = Any_Modular
2700 or else Error_Msg_Node_1 = Any_Numeric
2701 or else Error_Msg_Node_1 = Any_Real
2702 or else Error_Msg_Node_1 = Any_Scalar
2703 or else Error_Msg_Node_1 = Any_String
2704 then
2705 Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1));
2706 Set_Msg_Name_Buffer;
2707 return;
2709 elsif Error_Msg_Node_1 = Universal_Real then
2710 Set_Msg_Str ("type universal real");
2711 return;
2713 elsif Error_Msg_Node_1 = Universal_Integer then
2714 Set_Msg_Str ("type universal integer");
2715 return;
2717 elsif Error_Msg_Node_1 = Universal_Fixed then
2718 Set_Msg_Str ("type universal fixed");
2719 return;
2720 end if;
2722 -- Special case of anonymous array
2724 if Nkind (Error_Msg_Node_1) in N_Entity
2725 and then Is_Array_Type (Error_Msg_Node_1)
2726 and then Present (Related_Array_Object (Error_Msg_Node_1))
2727 then
2728 Set_Msg_Str ("type of ");
2729 Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1));
2730 Set_Msg_Str (" declared");
2731 Set_Msg_Insertion_Line_Number
2732 (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag);
2733 return;
2734 end if;
2736 -- If we fall through, it is not a special case, so first output
2737 -- the name of the type, preceded by private for a private type
2739 if Is_Private_Type (Error_Msg_Node_1) then
2740 Set_Msg_Str ("private type ");
2741 else
2742 Set_Msg_Str ("type ");
2743 end if;
2745 Ent := Error_Msg_Node_1;
2747 if Is_Internal_Name (Chars (Ent)) then
2748 Unwind_Internal_Type (Ent);
2749 end if;
2751 -- Types in Standard are displayed as "Standard.name"
2753 if Sloc (Ent) <= Standard_Location then
2754 Set_Msg_Quote;
2755 Set_Msg_Str ("Standard.");
2756 Set_Msg_Node (Ent);
2757 Add_Class;
2758 Set_Msg_Quote;
2760 -- Types in other language defined units are displayed as
2761 -- "package-name.type-name"
2763 elsif Is_Predefined_Unit (Get_Source_Unit (Ent)) then
2764 Get_Unqualified_Decoded_Name_String
2765 (Unit_Name (Get_Source_Unit (Ent)));
2766 Name_Len := Name_Len - 2;
2767 Set_Msg_Blank_Conditional;
2768 Set_Msg_Quote;
2769 Set_Casing (Mixed_Case);
2770 Set_Msg_Name_Buffer;
2771 Set_Msg_Char ('.');
2772 Set_Casing (Mixed_Case);
2773 Set_Msg_Node (Ent);
2774 Add_Class;
2775 Set_Msg_Quote;
2777 -- All other types display as "type name" defined at line xxx
2778 -- possibly qualified if qualification is requested.
2780 else
2781 Set_Msg_Quote;
2782 Set_Qualification (Error_Msg_Qual_Level, Ent);
2783 Set_Msg_Node (Ent);
2784 Add_Class;
2786 -- If we did not print a name (e.g. in the case of an anonymous
2787 -- subprogram type), there is no name to print, so remove quotes.
2789 if Buffer_Ends_With ('"') then
2790 Buffer_Remove ('"');
2791 else
2792 Set_Msg_Quote;
2793 end if;
2794 end if;
2796 -- If the original type did not come from a predefined file, add the
2797 -- location where the type was defined.
2799 if Sloc (Error_Msg_Node_1) > Standard_Location
2800 and then
2801 not Is_Predefined_Unit (Get_Source_Unit (Error_Msg_Node_1))
2802 then
2803 Get_Name_String (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)));
2804 Set_Msg_Str (" defined");
2805 Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag);
2807 -- If it did come from a predefined file, deal with the case where
2808 -- this was a file with a generic instantiation from elsewhere.
2810 else
2811 if Sloc (Error_Msg_Node_1) > Standard_Location then
2812 declare
2813 Iloc : constant Source_Ptr :=
2814 Instantiation_Location (Sloc (Error_Msg_Node_1));
2816 begin
2817 if Iloc /= No_Location
2818 and then not Suppress_Instance_Location
2819 then
2820 Set_Msg_Str (" from instance");
2821 Set_Msg_Insertion_Line_Number (Iloc, Flag);
2822 end if;
2823 end;
2824 end if;
2825 end if;
2826 end Set_Msg_Insertion_Type_Reference;
2828 ---------------------------------
2829 -- Set_Msg_Insertion_Unit_Name --
2830 ---------------------------------
2832 procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is
2833 begin
2834 if Error_Msg_Unit_1 = No_Unit_Name then
2835 null;
2837 elsif Error_Msg_Unit_1 = Error_Unit_Name then
2838 Set_Msg_Blank;
2839 Set_Msg_Str ("<error>");
2841 else
2842 Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
2843 Set_Msg_Blank;
2844 Set_Msg_Quote;
2845 Set_Msg_Name_Buffer;
2846 Set_Msg_Quote;
2847 end if;
2849 -- The following assignment ensures that a second percent insertion
2850 -- character will correspond to the Error_Msg_Unit_2 parameter. We
2851 -- suppress possible validity checks in case operating in -gnatVa mode,
2852 -- and Error_Msg_Unit_2 is not needed and has not been set.
2854 declare
2855 pragma Suppress (Range_Check);
2856 begin
2857 Error_Msg_Unit_1 := Error_Msg_Unit_2;
2858 end;
2859 end Set_Msg_Insertion_Unit_Name;
2861 ------------------
2862 -- Set_Msg_Node --
2863 ------------------
2865 procedure Set_Msg_Node (Node : Node_Id) is
2866 Loc : Source_Ptr;
2867 Ent : Entity_Id;
2868 Nam : Name_Id;
2870 begin
2871 case Nkind (Node) is
2872 when N_Designator =>
2873 Set_Msg_Node (Name (Node));
2874 Set_Msg_Char ('.');
2875 Set_Msg_Node (Identifier (Node));
2876 return;
2878 when N_Defining_Program_Unit_Name =>
2879 Set_Msg_Node (Name (Node));
2880 Set_Msg_Char ('.');
2881 Set_Msg_Node (Defining_Identifier (Node));
2882 return;
2884 when N_Expanded_Name
2885 | N_Selected_Component
2887 Set_Msg_Node (Prefix (Node));
2888 Set_Msg_Char ('.');
2889 Set_Msg_Node (Selector_Name (Node));
2890 return;
2892 when others =>
2893 null;
2894 end case;
2896 -- The only remaining possibilities are identifiers, defining
2897 -- identifiers, pragmas, and pragma argument associations.
2899 if Nkind (Node) = N_Pragma then
2900 Nam := Pragma_Name (Node);
2901 Loc := Sloc (Node);
2903 -- The other cases have Chars fields
2905 -- First deal with internal names, which generally represent something
2906 -- gone wrong. First attempt: if this is a rewritten node that rewrites
2907 -- something with a Chars field that is not an internal name, use that.
2909 elsif Is_Internal_Name (Chars (Node))
2910 and then Nkind (Original_Node (Node)) in N_Has_Chars
2911 and then not Is_Internal_Name (Chars (Original_Node (Node)))
2912 then
2913 Nam := Chars (Original_Node (Node));
2914 Loc := Sloc (Original_Node (Node));
2916 -- Another shot for internal names, in the case of internal type names,
2917 -- we try to find a reasonable representation for the external name.
2919 elsif Is_Internal_Name (Chars (Node))
2920 and then
2921 ((Is_Entity_Name (Node)
2922 and then Present (Entity (Node))
2923 and then Is_Type (Entity (Node)))
2924 or else
2925 (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
2926 then
2927 if Nkind (Node) = N_Identifier then
2928 Ent := Entity (Node);
2929 else
2930 Ent := Node;
2931 end if;
2933 Loc := Sloc (Ent);
2935 -- If the type is the designated type of an access_to_subprogram,
2936 -- then there is no name to provide in the call.
2938 if Ekind (Ent) = E_Subprogram_Type then
2939 return;
2941 -- Otherwise, we will be able to find some kind of name to output
2943 else
2944 Unwind_Internal_Type (Ent);
2945 Nam := Chars (Ent);
2946 end if;
2948 -- If not internal name, or if we could not find a reasonable possible
2949 -- substitution for the internal name, just use name in Chars field.
2951 else
2952 Nam := Chars (Node);
2953 Loc := Sloc (Node);
2954 end if;
2956 -- At this stage, the name to output is in Nam
2958 Get_Unqualified_Decoded_Name_String (Nam);
2960 -- Remove trailing upper case letters from the name (useful for
2961 -- dealing with some cases of internal names).
2963 while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop
2964 Name_Len := Name_Len - 1;
2965 end loop;
2967 -- If we have any of the names from standard that start with the
2968 -- characters "any " (e.g. Any_Type), then kill the message since
2969 -- almost certainly it is a junk cascaded message.
2971 if Name_Len > 4
2972 and then Name_Buffer (1 .. 4) = "any "
2973 then
2974 Kill_Message := True;
2975 end if;
2977 -- If we still have an internal name, kill the message (will only
2978 -- work if we already had errors!)
2980 if Is_Internal_Name then
2981 Kill_Message := True;
2982 end if;
2983 -- Remaining step is to adjust casing and possibly add 'Class
2985 Adjust_Name_Case (Global_Name_Buffer, Loc);
2986 Set_Msg_Name_Buffer;
2987 Add_Class;
2988 end Set_Msg_Node;
2990 ------------------
2991 -- Set_Msg_Text --
2992 ------------------
2994 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
2995 C : Character; -- Current character
2996 P : Natural; -- Current index;
2998 procedure Skip_Msg_Insertion_Warning (C : Character);
2999 -- Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same
3000 -- sequences using < instead of ?). The caller has already bumped
3001 -- the pointer past the initial ? or < and C is set to this initial
3002 -- character (? or <). This procedure skips past the rest of the
3003 -- sequence. We do not need to set Msg_Insertion_Char, since this
3004 -- was already done during the message prescan.
3006 --------------------------------
3007 -- Skip_Msg_Insertion_Warning --
3008 --------------------------------
3010 procedure Skip_Msg_Insertion_Warning (C : Character) is
3011 begin
3012 if P <= Text'Last and then Text (P) = C then
3013 P := P + 1;
3015 elsif P + 1 <= Text'Last
3016 and then (Text (P) in 'a' .. 'z'
3017 or else
3018 Text (P) in 'A' .. 'Z'
3019 or else
3020 Text (P) = '*'
3021 or else
3022 Text (P) = '$')
3023 and then Text (P + 1) = C
3024 then
3025 P := P + 2;
3026 end if;
3027 end Skip_Msg_Insertion_Warning;
3029 -- Start of processing for Set_Msg_Text
3031 begin
3032 Manual_Quote_Mode := False;
3033 Msglen := 0;
3034 Flag_Source := Get_Source_File_Index (Flag);
3036 -- Skip info: at start, we have recorded this in Is_Info_Msg, and this
3037 -- will be used (Info field in error message object) to put back the
3038 -- string when it is printed. We need to do this, or we get confused
3039 -- with instantiation continuations.
3041 if Text'Length > 6
3042 and then Text (Text'First .. Text'First + 5) = "info: "
3043 then
3044 P := Text'First + 6;
3045 else
3046 P := Text'First;
3047 end if;
3049 -- Loop through characters of message
3051 while P <= Text'Last loop
3052 C := Text (P);
3053 P := P + 1;
3055 -- Check for insertion character or sequence
3057 case C is
3058 when '%' =>
3059 if P <= Text'Last and then Text (P) = '%' then
3060 P := P + 1;
3061 Set_Msg_Insertion_Name_Literal;
3062 else
3063 Set_Msg_Insertion_Name;
3064 end if;
3066 when '$' =>
3067 if P <= Text'Last and then Text (P) = '$' then
3068 P := P + 1;
3069 Set_Msg_Insertion_Unit_Name (Suffix => False);
3070 else
3071 Set_Msg_Insertion_Unit_Name;
3072 end if;
3074 when '{' =>
3075 Set_Msg_Insertion_File_Name;
3077 when '}' =>
3078 Set_Msg_Insertion_Type_Reference (Flag);
3080 when '*' =>
3081 Set_Msg_Insertion_Reserved_Name;
3083 when '&' =>
3084 Set_Msg_Insertion_Node;
3086 when '#' =>
3087 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
3089 when '\' =>
3090 Continuation := True;
3092 if P <= Text'Last and then Text (P) = '\' then
3093 Continuation_New_Line := True;
3094 P := P + 1;
3095 end if;
3097 when '@' =>
3098 Set_Msg_Insertion_Column;
3100 when '>' =>
3101 Set_Msg_Insertion_Run_Time_Name;
3103 when '^' =>
3104 Set_Msg_Insertion_Uint;
3106 when '`' =>
3107 Manual_Quote_Mode := not Manual_Quote_Mode;
3108 Set_Msg_Char ('"');
3110 when '!' =>
3111 null; -- already dealt with
3113 when '?' =>
3114 Skip_Msg_Insertion_Warning ('?');
3116 when '<' =>
3117 Skip_Msg_Insertion_Warning ('<');
3119 when '|' =>
3120 null; -- already dealt with
3122 when ''' =>
3123 Set_Msg_Char (Text (P));
3124 P := P + 1;
3126 when '~' =>
3127 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
3129 -- Upper case letter
3131 when 'A' .. 'Z' =>
3133 -- Start of reserved word if two or more
3135 if P <= Text'Last and then Text (P) in 'A' .. 'Z' then
3136 P := P - 1;
3137 Set_Msg_Insertion_Reserved_Word (Text, P);
3139 -- Single upper case letter is just inserted
3141 else
3142 Set_Msg_Char (C);
3143 end if;
3145 -- '[' (will be/would have been raised at run time)
3147 when '[' =>
3149 -- Switch the message from a warning to an error if the flag
3150 -- -gnatwE is specified to treat run-time exception warnings
3151 -- as errors.
3153 if Is_Warning_Msg
3154 and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors
3155 then
3156 Is_Warning_Msg := False;
3157 end if;
3159 if Is_Warning_Msg then
3160 Set_Msg_Str ("will be raised at run time");
3161 else
3162 Set_Msg_Str ("would have been raised at run time");
3163 end if;
3165 -- ']' (may be/might have been raised at run time)
3167 when ']' =>
3168 if Is_Warning_Msg then
3169 Set_Msg_Str ("may be raised at run time");
3170 else
3171 Set_Msg_Str ("might have been raised at run time");
3172 end if;
3174 -- Normal character with no special treatment
3176 when others =>
3177 Set_Msg_Char (C);
3178 end case;
3179 end loop;
3180 end Set_Msg_Text;
3182 ----------------
3183 -- Set_Posted --
3184 ----------------
3186 procedure Set_Posted (N : Node_Id) is
3187 P : Node_Id;
3189 begin
3190 if Is_Serious_Error then
3192 -- We always set Error_Posted on the node itself
3194 Set_Error_Posted (N);
3196 -- If it is a subexpression, then set Error_Posted on parents up to
3197 -- and including the first non-subexpression construct. This helps
3198 -- avoid cascaded error messages within a single expression.
3200 P := N;
3201 loop
3202 P := Parent (P);
3203 exit when No (P);
3204 Set_Error_Posted (P);
3205 exit when Nkind (P) not in N_Subexpr;
3206 end loop;
3208 if Nkind_In (P, N_Pragma_Argument_Association,
3209 N_Component_Association,
3210 N_Discriminant_Association,
3211 N_Generic_Association,
3212 N_Parameter_Association)
3213 then
3214 Set_Error_Posted (Parent (P));
3215 end if;
3217 -- A special check, if we just posted an error on an attribute
3218 -- definition clause, then also set the entity involved as posted.
3219 -- For example, this stops complaining about the alignment after
3220 -- complaining about the size, which is likely to be useless.
3222 if Nkind (P) = N_Attribute_Definition_Clause then
3223 if Is_Entity_Name (Name (P)) then
3224 Set_Error_Posted (Entity (Name (P)));
3225 end if;
3226 end if;
3227 end if;
3228 end Set_Posted;
3230 -----------------------
3231 -- Set_Qualification --
3232 -----------------------
3234 procedure Set_Qualification (N : Nat; E : Entity_Id) is
3235 begin
3236 if N /= 0 and then Scope (E) /= Standard_Standard then
3237 Set_Qualification (N - 1, Scope (E));
3238 Set_Msg_Node (Scope (E));
3239 Set_Msg_Char ('.');
3240 end if;
3241 end Set_Qualification;
3243 ------------------------
3244 -- Special_Msg_Delete --
3245 ------------------------
3247 -- Is it really right to have all this specialized knowledge in errout?
3249 function Special_Msg_Delete
3250 (Msg : String;
3251 N : Node_Or_Entity_Id;
3252 E : Node_Or_Entity_Id) return Boolean
3254 begin
3255 -- Never delete messages in -gnatdO mode
3257 if Debug_Flag_OO then
3258 return False;
3260 -- Processing for "atomic access cannot be guaranteed"
3262 elsif Msg = "atomic access to & cannot be guaranteed" then
3264 -- When an atomic object refers to a non-atomic type in the same
3265 -- scope, we implicitly make the type atomic. In the non-error case
3266 -- this is surely safe (and in fact prevents an error from occurring
3267 -- if the type is not atomic by default). But if the object cannot be
3268 -- made atomic, then we introduce an extra junk message by this
3269 -- manipulation, which we get rid of here.
3271 -- We identify this case by the fact that it references a type for
3272 -- which Is_Atomic is set, but there is no Atomic pragma setting it.
3274 if Is_Type (E)
3275 and then Is_Atomic (E)
3276 and then No (Get_Rep_Pragma (E, Name_Atomic))
3277 then
3278 return True;
3279 end if;
3281 -- Similar processing for "volatile full access cannot be guaranteed"
3283 elsif Msg = "volatile full access to & cannot be guaranteed" then
3284 if Is_Type (E)
3285 and then Is_Volatile_Full_Access (E)
3286 and then No (Get_Rep_Pragma (E, Name_Volatile_Full_Access))
3287 then
3288 return True;
3289 end if;
3291 -- Processing for "Size too small" messages
3293 elsif Msg = "size for& too small, minimum allowed is ^" then
3295 -- Suppress "size too small" errors in CodePeer mode, since code may
3296 -- be analyzed in a different configuration than the one used for
3297 -- compilation. Even when the configurations match, this message
3298 -- may be issued on correct code, because pragma Pack is ignored
3299 -- in CodePeer mode.
3301 if CodePeer_Mode then
3302 return True;
3304 -- When a size is wrong for a frozen type there is no explicit size
3305 -- clause, and other errors have occurred, suppress the message,
3306 -- since it is likely that this size error is a cascaded result of
3307 -- other errors. The reason we eliminate unfrozen types is that
3308 -- messages issued before the freeze type are for sure OK.
3310 elsif Is_Frozen (E)
3311 and then Serious_Errors_Detected > 0
3312 and then Nkind (N) /= N_Component_Clause
3313 and then Nkind (Parent (N)) /= N_Component_Clause
3314 and then
3315 No (Get_Attribute_Definition_Clause (E, Attribute_Size))
3316 and then
3317 No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
3318 and then
3319 No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
3320 then
3321 return True;
3322 end if;
3323 end if;
3325 -- All special tests complete, so go ahead with message
3327 return False;
3328 end Special_Msg_Delete;
3330 -----------------
3331 -- SPARK_Msg_N --
3332 -----------------
3334 procedure SPARK_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
3335 begin
3336 if SPARK_Mode /= Off then
3337 Error_Msg_N (Msg, N);
3338 end if;
3339 end SPARK_Msg_N;
3341 ------------------
3342 -- SPARK_Msg_NE --
3343 ------------------
3345 procedure SPARK_Msg_NE
3346 (Msg : String;
3347 N : Node_Or_Entity_Id;
3348 E : Node_Or_Entity_Id)
3350 begin
3351 if SPARK_Mode /= Off then
3352 Error_Msg_NE (Msg, N, E);
3353 end if;
3354 end SPARK_Msg_NE;
3356 --------------------------
3357 -- Unwind_Internal_Type --
3358 --------------------------
3360 procedure Unwind_Internal_Type (Ent : in out Entity_Id) is
3361 Derived : Boolean := False;
3362 Mchar : Character;
3363 Old_Ent : Entity_Id;
3365 begin
3366 -- Undo placement of a quote, since we will put it back later
3368 Mchar := Msg_Buffer (Msglen);
3370 if Mchar = '"' then
3371 Msglen := Msglen - 1;
3372 end if;
3374 -- The loop here deals with recursive types, we are trying to find a
3375 -- related entity that is not an implicit type. Note that the check with
3376 -- Old_Ent stops us from getting "stuck". Also, we don't output the
3377 -- "type derived from" message more than once in the case where we climb
3378 -- up multiple levels.
3380 Find : loop
3381 Old_Ent := Ent;
3383 -- Implicit access type, use directly designated type In Ada 2005,
3384 -- the designated type may be an anonymous access to subprogram, in
3385 -- which case we can only point to its definition.
3387 if Is_Access_Type (Ent) then
3388 if Ekind (Ent) = E_Access_Subprogram_Type
3389 or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type
3390 or else Is_Access_Protected_Subprogram_Type (Ent)
3391 then
3392 Ent := Directly_Designated_Type (Ent);
3394 if not Comes_From_Source (Ent) then
3395 if Buffer_Ends_With ("type ") then
3396 Buffer_Remove ("type ");
3397 end if;
3398 end if;
3400 if Ekind (Ent) = E_Function then
3401 Set_Msg_Str ("access to function ");
3402 elsif Ekind (Ent) = E_Procedure then
3403 Set_Msg_Str ("access to procedure ");
3404 else
3405 Set_Msg_Str ("access to subprogram");
3406 end if;
3408 exit Find;
3410 -- Type is access to object, named or anonymous
3412 else
3413 Set_Msg_Str ("access to ");
3414 Ent := Directly_Designated_Type (Ent);
3415 end if;
3417 -- Classwide type
3419 elsif Is_Class_Wide_Type (Ent) then
3420 Class_Flag := True;
3421 Ent := Root_Type (Ent);
3423 -- Use base type if this is a subtype
3425 elsif Ent /= Base_Type (Ent) then
3426 Buffer_Remove ("type ");
3428 -- Avoid duplication "subtype of subtype of", and also replace
3429 -- "derived from subtype of" simply by "derived from"
3431 if not Buffer_Ends_With ("subtype of ")
3432 and then not Buffer_Ends_With ("derived from ")
3433 then
3434 Set_Msg_Str ("subtype of ");
3435 end if;
3437 Ent := Base_Type (Ent);
3439 -- If this is a base type with a first named subtype, use the first
3440 -- named subtype instead. This is not quite accurate in all cases,
3441 -- but it makes too much noise to be accurate and add 'Base in all
3442 -- cases. Note that we only do this is the first named subtype is not
3443 -- itself an internal name. This avoids the obvious loop (subtype ->
3444 -- basetype -> subtype) which would otherwise occur).
3446 else
3447 declare
3448 FST : constant Entity_Id := First_Subtype (Ent);
3450 begin
3451 if not Is_Internal_Name (Chars (FST)) then
3452 Ent := FST;
3453 exit Find;
3455 -- Otherwise use root type
3457 else
3458 if not Derived then
3459 Buffer_Remove ("type ");
3461 -- Test for "subtype of type derived from" which seems
3462 -- excessive and is replaced by "type derived from".
3464 Buffer_Remove ("subtype of");
3466 -- Avoid duplicated "type derived from type derived from"
3468 if not Buffer_Ends_With ("type derived from ") then
3469 Set_Msg_Str ("type derived from ");
3470 end if;
3472 Derived := True;
3473 end if;
3474 end if;
3475 end;
3477 Ent := Etype (Ent);
3478 end if;
3480 -- If we are stuck in a loop, get out and settle for the internal
3481 -- name after all. In this case we set to kill the message if it is
3482 -- not the first error message (we really try hard not to show the
3483 -- dirty laundry of the implementation to the poor user).
3485 if Ent = Old_Ent then
3486 Kill_Message := True;
3487 exit Find;
3488 end if;
3490 -- Get out if we finally found a non-internal name to use
3492 exit Find when not Is_Internal_Name (Chars (Ent));
3493 end loop Find;
3495 if Mchar = '"' then
3496 Set_Msg_Char ('"');
3497 end if;
3498 end Unwind_Internal_Type;
3500 --------------------
3501 -- Warn_Insertion --
3502 --------------------
3504 function Warn_Insertion return String is
3505 begin
3506 case Warning_Msg_Char is
3507 when '?' =>
3508 return "??";
3510 when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
3511 return '?' & Warning_Msg_Char & '?';
3513 when ' ' =>
3514 return "?";
3516 when others =>
3517 raise Program_Error;
3518 end case;
3519 end Warn_Insertion;
3521 end Errout;