1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
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
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;
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
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,
92 Table_Increment => 100,
93 Table_Name => "Non_Instance_Msgs");
95 -----------------------
96 -- Local Subprograms --
97 -----------------------
99 procedure Error_Msg_Internal
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;
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
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
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?"
208 -- '$' returns "?$?info: "
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;
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;
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;
238 end Change_Error_Text;
240 ------------------------
241 -- Compilation_Errors --
242 ------------------------
244 function Compilation_Errors return Boolean is
246 if not Finalize_Called then
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.
255 Record_Compilation_Errors :=
256 Record_Compilation_Errors or else Erroutc.Compilation_Errors;
258 return Record_Compilation_Errors;
260 end Compilation_Errors;
262 --------------------------------------
263 -- Delete_Warning_And_Continuations --
264 --------------------------------------
266 procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id) is
270 pragma Assert (not Errors.Table (Msg).Msg_Cont);
275 M : Error_Msg_Object renames Errors.Table (Id);
278 if not M.Deleted then
280 Warnings_Detected := Warnings_Detected - 1;
283 Warning_Info_Messages := Warning_Info_Messages - 1;
287 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1;
292 exit when Id = No_Error_Msg;
293 exit when not Errors.Table (Id).Msg_Cont;
296 end Delete_Warning_And_Continuations;
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
310 Error_Msg (Msg, Flag_Location, Current_Node);
315 Flag_Location : Source_Ptr;
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).
326 -- Return if all errors are to be ignored
328 if Errors_Must_Be_Ignored then
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
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
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
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
389 -- No duplicate, so error/warning will be posted on instance
391 Warn_On_Instance := Is_Warning_Msg;
394 -- Ignore warning message that is suppressed for this location. Note
395 -- that style checks are not considered warning messages for this
398 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String
402 -- For style messages, check too many messages so far
405 and then Maximum_Messages /= 0
406 and then Warnings_Detected >= Maximum_Messages
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);
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
432 -- warning: in instantiation at ...
433 -- warning: original warning message
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
454 -- warning: in inlined body at ...
455 -- warning: original warning message
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.
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.
483 -- Loop to find highest level instantiation, where all error
484 -- messages will be placed.
488 Actual_Error_Loc := Instantiation (X);
489 X := Get_Source_File_Index (Actual_Error_Loc);
490 exit when Instantiation (X) = No_Location;
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
515 (Msg => "info: in inlined body #",
516 Sptr => Actual_Error_Loc,
517 Optr => Flag_Location,
518 Msg_Cont => Msg_Cont_Status,
521 elsif Is_Warning_Msg then
523 (Msg => Warn_Insertion & "in inlined body #",
524 Sptr => Actual_Error_Loc,
525 Optr => Flag_Location,
526 Msg_Cont => Msg_Cont_Status,
529 elsif Is_Style_Msg then
531 (Msg => "style: in inlined body #",
532 Sptr => Actual_Error_Loc,
533 Optr => Flag_Location,
534 Msg_Cont => Msg_Cont_Status,
539 (Msg => "error in inlined body #",
540 Sptr => Actual_Error_Loc,
541 Optr => Flag_Location,
542 Msg_Cont => Msg_Cont_Status,
546 -- Case of generic instantiation
551 (Msg => "info: in instantiation #",
552 Sptr => Actual_Error_Loc,
553 Optr => Flag_Location,
554 Msg_Cont => Msg_Cont_Status,
557 elsif Is_Warning_Msg then
559 (Msg => Warn_Insertion & "in instantiation #",
560 Sptr => Actual_Error_Loc,
561 Optr => Flag_Location,
562 Msg_Cont => Msg_Cont_Status,
565 elsif Is_Style_Msg then
567 (Msg => "style: in instantiation #",
568 Sptr => Actual_Error_Loc,
569 Optr => Flag_Location,
570 Msg_Cont => Msg_Cont_Status,
575 (Msg => "instantiation error #",
576 Sptr => Actual_Error_Loc,
577 Optr => Flag_Location,
578 Msg_Cont => Msg_Cont_Status,
584 Error_Msg_Sloc := Instantiation (X);
585 X := Get_Source_File_Index (Error_Msg_Sloc);
586 Msg_Cont_Status := True;
589 Suppress_Instance_Location := False;
590 Error_Msg_Sloc := Save_Error_Msg_Sloc;
592 -- Here we output the original message on the outer instantiation
596 Sptr => Actual_Error_Loc,
597 Optr => Flag_Location,
598 Msg_Cont => Msg_Cont_Status,
603 --------------------------------
604 -- Error_Msg_Ada_2012_Feature --
605 --------------------------------
607 procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr) is
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);
615 Error_Msg_Sloc := Sloc (Ada_Version_Pragma);
616 Error_Msg ("\incompatible with Ada version set#", Loc);
619 end Error_Msg_Ada_2012_Feature;
625 procedure Error_Msg_AP (Msg : String) is
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;
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
661 if Source (S1) = C then
663 exit when Source (S1) /= C;
664 elsif Source (S1) in Line_Terminator then
669 -- Character literal also needs special handling
671 elsif Prev_Token = Tok_Char_Literal then
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.
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
692 -- S1 is now set to the location for the flag
701 procedure Error_Msg_BC (Msg : String) is
703 -- If we are at end of file, post the flag after the previous token
705 if Token = Tok_EOF then
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
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
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).
728 Error_Msg (Msg, Token_Ptr);
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);
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;
757 Error_Msg_N (S (1 .. L), N);
758 Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;
765 procedure Error_Msg_PT (E : Entity_Id; Iface_Prim : Entity_Id) is
768 ("illegal overriding of subprogram inherited from interface", E);
770 Error_Msg_Sloc := Sloc (Iface_Prim);
772 if Ekind (E) = E_Function then
774 ("\first formal of & declared # must be of mode `IN` "
775 & "or access-to-constant", E);
778 ("\first formal of & declared # must be of mode `OUT`, `IN OUT` "
779 & "or access-to-variable", E);
787 procedure Error_Msg_F (Msg : String; N : Node_Id) is
789 Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N)));
796 procedure Error_Msg_FE
799 E : Node_Or_Entity_Id)
802 Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N)));
805 ------------------------
806 -- Error_Msg_Internal --
807 ------------------------
809 procedure Error_Msg_Internal
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;
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
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;
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
853 U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
855 if Try_Semantics then
856 if Fatal_Error (U) = None then
857 Set_Fatal_Error (U, Error_Ignored);
860 Set_Fatal_Error (U, Error_Detected);
864 end Handle_Serious_Error;
866 -- Start of processing for Error_Msg_Internal
869 if Raise_Exception_On_Error /= 0 then
870 raise Error_Msg_Exception;
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
885 -- Return without doing anything if message is suppressed
888 and then not All_Errors_Mode
889 and then not Is_Warning_Msg
890 and then not Is_Unconditional_Msg
892 if not Continuation then
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
905 and then not All_Errors_Mode
906 and then Total_Errors_Detected /= 0
908 if not Continuation then
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
923 Warnings_Suppressed (Sptr) /= No_String
925 Cur_Msg := No_Error_Msg;
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
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
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
949 -- Keep warning if debug flag G set
951 elsif Debug_Flag_GG then
954 -- Keep warning if message text contains !!
956 elsif Has_Double_Exclam then
959 -- Here is where we delete a warning from a with'ed unit
962 Cur_Msg := No_Error_Msg;
964 if not Continuation then
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;
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
988 if Error_Msg_Line_Length /= 0 and then Continuation then
989 Cur_Msg := Errors.Last;
992 Oldm : String_Ptr := Errors.Table (Cur_Msg).Text;
993 Newm : String (1 .. Oldm'Last + 2 + Msglen);
998 -- First copy old message to new one and free it
1000 Newm (Oldm'Range) := Oldm.all;
1001 Newl := Oldm'Length;
1004 -- Remove (style) or info: at start of message
1006 if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then
1009 elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then
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
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
1037 Msg_Buffer (M) := ' ';
1039 -- Case where we are adding new parenthetical comment
1046 -- Case where continuation not in parens and no new line
1049 Newm (Newl + 1 .. Newl + 2) := ", ";
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;
1076 -- Here we build a new error object
1079 ((Text => new String'(Msg_Buffer (1 .. Msglen)),
1080 Next => No_Error_Msg,
1081 Prev => No_Error_Msg,
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,
1098 Cur_Msg := Errors.Last;
1100 -- Test if warning to be treated as error
1104 and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen))
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;
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
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).
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
1141 (Sptr = Errors.Table (Last_Error_Msg).Sptr
1143 Optr > Errors.Table (Last_Error_Msg).Optr))
1145 Prev_Msg := Last_Error_Msg;
1146 Next_Msg := No_Error_Msg;
1148 -- Otherwise do a full sequential search for the insertion point
1151 Prev_Msg := No_Error_Msg;
1152 Next_Msg := First_Error_Msg;
1153 while Next_Msg /= No_Error_Msg loop
1155 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
1157 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile
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);
1164 Prev_Msg := Next_Msg;
1165 Next_Msg := Errors.Table (Next_Msg).Next;
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
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
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
1202 Errors.Table (Prev_Msg).Style)
1204 (Errors.Table (Cur_Msg).Warn
1206 Errors.Table (Cur_Msg).Style)
1208 -- All tests passed, delete the message by simply returning
1209 -- without any further processing.
1211 pragma Assert (not Continuation);
1213 Last_Killed := True;
1219 -- Come here if message is to be inserted in the error chain
1221 if not Continuation then
1222 Last_Killed := False;
1225 if Prev_Msg = No_Error_Msg then
1226 First_Error_Msg := Cur_Msg;
1228 Errors.Table (Prev_Msg).Next := Cur_Msg;
1231 Errors.Table (Cur_Msg).Next := Next_Msg;
1233 if Next_Msg = No_Error_Msg then
1234 Last_Error_Msg := Cur_Msg;
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;
1248 Report_Info_Messages := Report_Info_Messages + 1;
1251 elsif Errors.Table (Cur_Msg).Warn
1252 or else Errors.Table (Cur_Msg).Style
1254 Warnings_Detected := Warnings_Detected + 1;
1256 elsif Errors.Table (Cur_Msg).Check then
1257 Check_Messages := Check_Messages + 1;
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
1270 U : constant Unit_Number_Type := Get_Source_Unit (Sptr);
1272 if Fatal_Error (U) = None then
1273 Set_Fatal_Error (U, Error_Ignored);
1279 -- Record warning message issued
1281 if Errors.Table (Cur_Msg).Warn
1282 and then not Errors.Table (Cur_Msg).Msg_Cont
1284 Warning_Msg := Cur_Msg;
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;
1294 -- If too many errors abandon compilation
1296 if Total_Errors_Detected = Maximum_Messages then
1297 raise Unrecoverable_Error;
1300 end Error_Msg_Internal;
1306 procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
1308 Error_Msg_NEL (Msg, N, N, Sloc (N));
1315 procedure Error_Msg_NE
1317 N : Node_Or_Entity_Id;
1318 E : Node_Or_Entity_Id)
1321 Error_Msg_NEL (Msg, N, E, Sloc (N));
1328 procedure Error_Msg_NEL
1330 N : Node_Or_Entity_Id;
1331 E : Node_Or_Entity_Id;
1332 Flag_Location : Source_Ptr)
1335 if Special_Msg_Delete (Msg, N, E) then
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;
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.
1364 while Present (P) loop
1365 if Nkind (P) = N_Loop_Statement
1366 and then Suppress_Loop_Warnings (P)
1376 -- Test for message to be output
1379 or else Is_Unconditional_Msg
1380 or else Is_Warning_Msg
1382 or else (Msg (Msg'First) = '\' and then not Last_Killed)
1385 Error_Msg_Node_1 := E;
1386 Error_Msg (Msg, Flag_Location, N);
1389 Last_Killed := True;
1399 procedure Error_Msg_NW
1402 N : Node_Or_Entity_Id)
1406 and then In_Extended_Main_Source_Unit (N)
1407 and then Comes_From_Source (N)
1409 Error_Msg_NEL (Msg, N, N, Sloc (N));
1417 procedure Error_Msg_S (Msg : String) is
1419 Error_Msg (Msg, Scan_Ptr);
1426 procedure Error_Msg_SC (Msg : String) is
1428 -- If we are at end of file, post the flag after the previous token
1430 if Token = Tok_EOF then
1433 -- For all other cases the message is posted at the current token
1437 Error_Msg (Msg, Token_Ptr);
1445 procedure Error_Msg_SP (Msg : String) is
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);
1458 procedure Finalize (Last_Call : Boolean) is
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
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;
1482 -- Start of processing for Finalize
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;
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;
1503 while F /= No_Error_Msg
1504 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
1506 Check_Duplicate_Message (Cur, F);
1507 F := Errors.Table (F).Next;
1513 -- Mark any messages suppressed by specific warnings as Deleted
1515 Cur := First_Error_Msg;
1516 while Cur /= No_Error_Msg loop
1518 CE : Error_Msg_Object renames Errors.Table (Cur);
1519 Tag : constant String := Get_Warning_Tag (Cur);
1522 if (CE.Warn and not CE.Deleted)
1524 (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /=
1527 Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /=
1530 Delete_Warning (Cur);
1532 -- If this is a continuation, delete previous parts of message
1535 while Errors.Table (F).Msg_Cont loop
1536 F := Errors.Table (F).Prev;
1537 exit when F = No_Error_Msg;
1541 -- Delete any following continuations
1545 F := Errors.Table (F).Next;
1546 exit when F = No_Error_Msg;
1547 exit when not Errors.Table (F).Msg_Cont;
1553 Cur := Errors.Table (Cur).Next;
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.
1562 Validate_Specific_Warnings (Error_Msg'Access);
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);
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
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);
1592 -- Check for earlier
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
1614 -- Start of processing for First_Node
1617 if Nkind (Orig) in N_Subexpr then
1620 Search_Tree_First (Orig);
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);
1639 F := First_Node (N);
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.
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
1663 elsif Source_Text (SI) (S - 1) <= ' ' then
1669 end loop Search_Loop;
1670 end loop Paren_Loop;
1672 exit Node_Loop when F = N;
1674 exit Node_Loop when Nkind (F) not in N_Subexpr;
1680 -----------------------
1681 -- Get_Ignore_Errors --
1682 -----------------------
1684 function Get_Ignore_Errors return Boolean is
1686 return Errors_Must_Be_Ignored;
1687 end Get_Ignore_Errors;
1693 procedure Initialize is
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;
1703 -- Reset counts for warnings
1707 -- Initialize warnings tables
1710 Specific_Warnings.Init;
1717 function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
1719 if Error_Posted (N) then
1722 elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then
1725 elsif Is_Entity_Name (N)
1726 and then Present (Entity (N))
1727 and then Has_Warnings_Off (Entity (N))
1740 function OK_Node (N : Node_Id) return Boolean is
1741 K : constant Node_Kind := Nkind (N);
1744 if Error_Posted (N) then
1747 elsif K in N_Has_Etype
1748 and then Present (Etype (N))
1749 and then Error_Posted (Etype (N))
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))
1768 ---------------------
1769 -- Output_Messages --
1770 ---------------------
1772 procedure Output_Messages is
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
1791 -- Extra blank line if error messages or source listing were output
1793 if Total_Errors_Detected + Warnings_Detected > 0 or else Full_List
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)
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
1818 Write_Int (Num_Source_Lines (Main_Source_File));
1820 if Num_Source_Lines (Main_Source_File) = 1 then
1821 Write_Str (" line: ");
1823 Write_Str (" lines: ");
1827 if Total_Errors_Detected = 0 then
1828 Write_Str ("No errors");
1830 elsif Total_Errors_Detected = 1 then
1831 Write_Str ("1 error");
1834 Write_Int (Total_Errors_Detected);
1835 Write_Str (" errors");
1838 if Warnings_Detected - Warning_Info_Messages /= 0 then
1840 Write_Int (Warnings_Detected);
1841 Write_Str (" warning");
1843 if Warnings_Detected - Warning_Info_Messages /= 1 then
1847 if Warning_Mode = Treat_As_Error then
1848 Write_Str (" (treated as error");
1850 if Warnings_Detected /= 1 then
1856 elsif Warnings_Treated_As_Errors /= 0 then
1858 Write_Int (Warnings_Treated_As_Errors);
1859 Write_Str (" treated as errors)");
1863 if Warning_Info_Messages + Report_Info_Messages /= 0 then
1865 Write_Int (Warning_Info_Messages + Report_Info_Messages);
1866 Write_Str (" info message");
1868 if Warning_Info_Messages + Report_Info_Messages > 1 then
1874 Set_Standard_Output;
1875 end Write_Error_Summary;
1881 procedure Write_Header (Sfile : Source_File_Index) is
1883 if Verbose_Mode or Full_List then
1884 if Original_Operating_Mode = Generate_Code then
1885 Write_Str ("Compiling: ");
1887 Write_Str ("Checking: ");
1890 Write_Name (Full_File_Name (Sfile));
1892 if not Debug_Flag_7 then
1894 Write_Str ("Source file time stamp: ");
1895 Write_Time_Stamp (Sfile);
1897 Write_Str ("Compiled at: " & Compilation_Time);
1904 ----------------------
1905 -- Write_Max_Errors --
1906 ----------------------
1908 procedure Write_Max_Errors is
1910 if Maximum_Messages /= 0 then
1911 if Warnings_Detected >= Maximum_Messages then
1913 Write_Line ("maximum number of warnings output");
1914 Write_Line ("any further warnings suppressed");
1915 Set_Standard_Output;
1918 -- If too many errors print message
1920 if Total_Errors_Detected >= Maximum_Messages then
1922 Write_Line ("fatal error: maximum number of errors detected");
1923 Set_Standard_Output;
1926 end Write_Max_Errors;
1928 -- Start of processing for Output_Messages
1931 -- Error if Finalize has not been called
1933 if not Finalize_Called then
1934 raise Program_Error;
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
1944 Current_Error_Source_File := No_Source_File;
1949 if Brief_Output or (not Full_List and not Verbose_Mode) then
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));
1958 Write_Name (Reference_Name (Errors.Table (E).Sfile));
1962 Write_Int (Int (Physical_To_Logical
1963 (Errors.Table (E).Line,
1964 Errors.Table (E).Sfile)));
1967 if Errors.Table (E).Col < 10 then
1971 Write_Int (Int (Errors.Table (E).Col));
1973 Output_Msg_Text (E);
1977 E := Errors.Table (E).Next;
1980 Set_Standard_Output;
1983 -- Full source listing case
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
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);
2009 Write_Str ("Copyright 1992-" &
2011 ", Free Software Foundation, Inc.");
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.
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))
2041 Sfile : constant Source_File_Index := Source_Index (U);
2046 -- Only write the header if Sfile is known
2048 if Sfile > No_Source_File then
2049 Write_Header (Sfile);
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;
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
2074 E := Errors.Table (E).Next;
2079 and then Errors.Table (E).Line = N
2080 and then Errors.Table (E).Sfile = Sfile;
2082 Output_Source_Line (N, Sfile, Err_Flag);
2085 Output_Error_Msgs (E);
2087 if not Debug_Flag_2 then
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)
2108 and then Get_Source_Unit
2109 (Errors.Table (E).Sptr) /= Main_Unit))
2111 if Errors.Table (E).Deleted then
2112 E := Errors.Table (E).Next;
2117 (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
2118 Output_Error_Msgs (E);
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;
2128 Close_List_File_Access.all;
2129 Cancel_Special_Output;
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.
2138 and then (not Full_List or else Full_List_File_Name /= null)
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);
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;
2158 (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
2159 Output_Error_Msgs (E);
2164 -- Output error summary if verbose or full list mode
2166 if Verbose_Mode or else Full_List then
2167 Write_Error_Summary;
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;
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;
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
2201 if Sfile /= Current_Error_Source_File then
2202 Write_Str ("==============Error messages for ");
2204 case Sinput.File_Type (Sfile) is
2206 Write_Str ("source");
2208 when Sinput.Config =>
2209 Write_Str ("configuration pragmas");
2212 Write_Str ("symbol definition");
2214 when Sinput.Preproc =>
2215 Write_Str ("preprocessing data");
2218 Write_Str (" file: ");
2219 Write_Name (Full_File_Name (Sfile));
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)));
2231 Current_Error_Source_File := Sfile;
2234 if Errs or List_Pragmas_Mode then
2235 Output_Line_Number (Physical_To_Logical (L, Sfile));
2236 Line_Number_Output := True;
2239 S := Line_Start (L, Sfile);
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
2248 and then List_Pragmas_Index <= List_Pragmas.Last
2249 and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc
2251 case List_Pragmas.Table (List_Pragmas_Index).Ptyp is
2255 -- Ignore if on line with errors so that error flags
2256 -- get properly listed with the error line .
2259 Write_Char (ASCII.FF);
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;
2274 List_Pragmas_Mode := False;
2277 List_Pragmas_Index := List_Pragmas_Index + 1;
2279 -- Normal case (no matching entry in List_Pragmas table)
2282 if Errs or List_Pragmas_Mode then
2287 Empty_Line := False;
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
2298 Write_Eol_Keep_Blanks;
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);
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.
2331 function To_Be_Removed (E : Error_Msg_Id) return Boolean is
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
2349 Warnings_Detected := Warnings_Detected - 1;
2351 if Errors.Table (E).Info then
2352 Warning_Info_Messages := Warning_Info_Messages - 1;
2357 -- No removal required
2364 -- Start of processing for Check_For_Warnings
2367 while To_Be_Removed (First_Error_Msg) loop
2368 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
2371 if First_Error_Msg = No_Error_Msg then
2372 Last_Error_Msg := No_Error_Msg;
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;
2386 E := Errors.Table (E).Next;
2389 if Nkind (N) = N_Raise_Constraint_Error
2390 and then Is_Rewrite_Substitution (N)
2391 and then No (Condition (N))
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.
2400 Status : Traverse_Final_Result;
2403 if Is_List_Member (N) then
2404 Set_Condition (N, Original_Node (N));
2405 Status := Check_All_Warnings (Condition (N));
2407 Rewrite (N, Original_Node (N));
2408 Status := Check_All_Warnings (N);
2417 end Check_For_Warning;
2419 -- Start of processing for Remove_Warning_Messages
2422 if Warnings_Detected /= 0 then
2424 Discard : Traverse_Final_Result;
2425 pragma Warnings (Off, Discard);
2428 Discard := Check_All_Warnings (N);
2431 end Remove_Warning_Messages;
2433 procedure Remove_Warning_Messages (L : List_Id) is
2436 if Is_Non_Empty_List (L) then
2438 while Present (Stat) loop
2439 Remove_Warning_Messages (Stat);
2443 end Remove_Warning_Messages;
2445 --------------------
2446 -- Reset_Warnings --
2447 --------------------
2449 procedure Reset_Warnings is
2451 Warnings_Treated_As_Errors := 0;
2452 Warnings_Detected := 0;
2453 Warning_Info_Messages := 0;
2454 Warnings_As_Errors_Count := 0;
2457 ----------------------
2458 -- Adjust_Name_Case --
2459 ----------------------
2461 procedure Adjust_Name_Case
2462 (Buf : in out Bounded_String;
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.
2471 Src_Ind : constant Source_File_Index := Get_Source_File_Index (Loc);
2472 Sbuffer : Source_Buffer_Ptr;
2474 Src_Ptr : Source_Ptr;
2480 -- For standard locations, always use mixed case
2482 if Loc <= No_Location then
2483 Set_Casing (Mixed_Case);
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
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;
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
2507 for J in 1 .. Buf.Length loop
2508 Buf.Chars (J) := Sbuffer (Src_Ptr);
2509 Src_Ptr := Src_Ptr + 1;
2512 -- Otherwise set the casing using the default identifier casing
2515 Set_Casing (Buf, Identifier_Casing (Src_Ind));
2519 end Adjust_Name_Case;
2521 procedure Adjust_Name_Case (Loc : Source_Ptr) is
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);
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.
2543 -- Get length of file name
2546 while File (Flen + 1) /= ASCII.NUL 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));
2559 and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen))
2561 Desired_Case := Identifier_Casing (J);
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
2577 Set_Casing (Desired_Case);
2578 end Set_Identifier_Casing;
2580 -----------------------
2581 -- Set_Ignore_Errors --
2582 -----------------------
2584 procedure Set_Ignore_Errors (To : Boolean) is
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
2595 if RM_Column_Check then
2596 Set_Msg_Str (" in column ");
2597 Set_Msg_Int (Int (Error_Msg_Col) + 1);
2599 end Set_Msg_Insertion_Column;
2601 ----------------------------
2602 -- Set_Msg_Insertion_Node --
2603 ----------------------------
2605 procedure Set_Msg_Insertion_Node is
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
2619 Set_Msg_Str ("<error>");
2621 elsif Error_Msg_Node_1 = Standard_Void_Type then
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
2629 Set_Msg_Str ("access to subprogram");
2632 Set_Msg_Blank_Conditional;
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.
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)))
2649 Set_Msg_Node (Error_Msg_Node_1);
2651 -- Normal case, not an operator, surround with quotes
2655 Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1);
2656 Set_Msg_Node (Error_Msg_Node_1);
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.
2667 pragma Suppress (Range_Check);
2669 Error_Msg_Node_1 := Error_Msg_Node_2;
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
2683 if Error_Msg_Node_1 = Standard_Void_Type then
2684 Set_Msg_Str ("package or procedure name");
2687 elsif Error_Msg_Node_1 = Standard_Exception_Type then
2688 Set_Msg_Str ("exception name");
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
2705 Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1));
2706 Set_Msg_Name_Buffer;
2709 elsif Error_Msg_Node_1 = Universal_Real then
2710 Set_Msg_Str ("type universal real");
2713 elsif Error_Msg_Node_1 = Universal_Integer then
2714 Set_Msg_Str ("type universal integer");
2717 elsif Error_Msg_Node_1 = Universal_Fixed then
2718 Set_Msg_Str ("type universal fixed");
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))
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);
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 ");
2742 Set_Msg_Str ("type ");
2745 Ent := Error_Msg_Node_1;
2747 if Is_Internal_Name (Chars (Ent)) then
2748 Unwind_Internal_Type (Ent);
2751 -- Types in Standard are displayed as "Standard.name"
2753 if Sloc (Ent) <= Standard_Location then
2755 Set_Msg_Str ("Standard.");
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;
2769 Set_Casing (Mixed_Case);
2770 Set_Msg_Name_Buffer;
2772 Set_Casing (Mixed_Case);
2777 -- All other types display as "type name" defined at line xxx
2778 -- possibly qualified if qualification is requested.
2782 Set_Qualification (Error_Msg_Qual_Level, Ent);
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 ('"');
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
2801 not Is_Predefined_Unit (Get_Source_Unit (Error_Msg_Node_1))
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.
2811 if Sloc (Error_Msg_Node_1) > Standard_Location then
2813 Iloc : constant Source_Ptr :=
2814 Instantiation_Location (Sloc (Error_Msg_Node_1));
2817 if Iloc /= No_Location
2818 and then not Suppress_Instance_Location
2820 Set_Msg_Str (" from instance");
2821 Set_Msg_Insertion_Line_Number (Iloc, Flag);
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
2834 if Error_Msg_Unit_1 = No_Unit_Name then
2837 elsif Error_Msg_Unit_1 = Error_Unit_Name then
2839 Set_Msg_Str ("<error>");
2842 Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
2845 Set_Msg_Name_Buffer;
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.
2855 pragma Suppress (Range_Check);
2857 Error_Msg_Unit_1 := Error_Msg_Unit_2;
2859 end Set_Msg_Insertion_Unit_Name;
2865 procedure Set_Msg_Node (Node : Node_Id) is
2871 case Nkind (Node) is
2872 when N_Designator =>
2873 Set_Msg_Node (Name (Node));
2875 Set_Msg_Node (Identifier (Node));
2878 when N_Defining_Program_Unit_Name =>
2879 Set_Msg_Node (Name (Node));
2881 Set_Msg_Node (Defining_Identifier (Node));
2884 when N_Expanded_Name
2885 | N_Selected_Component
2887 Set_Msg_Node (Prefix (Node));
2889 Set_Msg_Node (Selector_Name (Node));
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);
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)))
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))
2921 ((Is_Entity_Name (Node)
2922 and then Present (Entity (Node))
2923 and then Is_Type (Entity (Node)))
2925 (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
2927 if Nkind (Node) = N_Identifier then
2928 Ent := Entity (Node);
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
2941 -- Otherwise, we will be able to find some kind of name to output
2944 Unwind_Internal_Type (Ent);
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.
2952 Nam := Chars (Node);
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;
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.
2972 and then Name_Buffer (1 .. 4) = "any "
2974 Kill_Message := True;
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;
2983 -- Remaining step is to adjust casing and possibly add 'Class
2985 Adjust_Name_Case (Global_Name_Buffer, Loc);
2986 Set_Msg_Name_Buffer;
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
3012 if P <= Text'Last and then Text (P) = C then
3015 elsif P + 1 <= Text'Last
3016 and then (Text (P) in 'a' .. 'z'
3018 Text (P) in 'A' .. 'Z'
3023 and then Text (P + 1) = C
3027 end Skip_Msg_Insertion_Warning;
3029 -- Start of processing for Set_Msg_Text
3032 Manual_Quote_Mode := False;
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.
3042 and then Text (Text'First .. Text'First + 5) = "info: "
3044 P := Text'First + 6;
3049 -- Loop through characters of message
3051 while P <= Text'Last loop
3055 -- Check for insertion character or sequence
3059 if P <= Text'Last and then Text (P) = '%' then
3061 Set_Msg_Insertion_Name_Literal;
3063 Set_Msg_Insertion_Name;
3067 if P <= Text'Last and then Text (P) = '$' then
3069 Set_Msg_Insertion_Unit_Name (Suffix => False);
3071 Set_Msg_Insertion_Unit_Name;
3075 Set_Msg_Insertion_File_Name;
3078 Set_Msg_Insertion_Type_Reference (Flag);
3081 Set_Msg_Insertion_Reserved_Name;
3084 Set_Msg_Insertion_Node;
3087 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
3090 Continuation := True;
3092 if P <= Text'Last and then Text (P) = '\' then
3093 Continuation_New_Line := True;
3098 Set_Msg_Insertion_Column;
3101 Set_Msg_Insertion_Run_Time_Name;
3104 Set_Msg_Insertion_Uint;
3107 Manual_Quote_Mode := not Manual_Quote_Mode;
3111 null; -- already dealt with
3114 Skip_Msg_Insertion_Warning ('?');
3117 Skip_Msg_Insertion_Warning ('<');
3120 null; -- already dealt with
3123 Set_Msg_Char (Text (P));
3127 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
3129 -- Upper case letter
3133 -- Start of reserved word if two or more
3135 if P <= Text'Last and then Text (P) in 'A' .. 'Z' then
3137 Set_Msg_Insertion_Reserved_Word (Text, P);
3139 -- Single upper case letter is just inserted
3145 -- '[' (will be/would have been raised at run time)
3149 -- Switch the message from a warning to an error if the flag
3150 -- -gnatwE is specified to treat run-time exception warnings
3154 and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors
3156 Is_Warning_Msg := False;
3159 if Is_Warning_Msg then
3160 Set_Msg_Str ("will be raised at run time");
3162 Set_Msg_Str ("would have been raised at run time");
3165 -- ']' (may be/might have been raised at run time)
3168 if Is_Warning_Msg then
3169 Set_Msg_Str ("may be raised at run time");
3171 Set_Msg_Str ("might have been raised at run time");
3174 -- Normal character with no special treatment
3186 procedure Set_Posted (N : Node_Id) is
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.
3204 Set_Error_Posted (P);
3205 exit when Nkind (P) not in N_Subexpr;
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)
3214 Set_Error_Posted (Parent (P));
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)));
3230 -----------------------
3231 -- Set_Qualification --
3232 -----------------------
3234 procedure Set_Qualification (N : Nat; E : Entity_Id) is
3236 if N /= 0 and then Scope (E) /= Standard_Standard then
3237 Set_Qualification (N - 1, Scope (E));
3238 Set_Msg_Node (Scope (E));
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
3251 N : Node_Or_Entity_Id;
3252 E : Node_Or_Entity_Id) return Boolean
3255 -- Never delete messages in -gnatdO mode
3257 if Debug_Flag_OO then
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.
3275 and then Is_Atomic (E)
3276 and then No (Get_Rep_Pragma (E, Name_Atomic))
3281 -- Similar processing for "volatile full access cannot be guaranteed"
3283 elsif Msg = "volatile full access to & cannot be guaranteed" then
3285 and then Is_Volatile_Full_Access (E)
3286 and then No (Get_Rep_Pragma (E, Name_Volatile_Full_Access))
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
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.
3311 and then Serious_Errors_Detected > 0
3312 and then Nkind (N) /= N_Component_Clause
3313 and then Nkind (Parent (N)) /= N_Component_Clause
3315 No (Get_Attribute_Definition_Clause (E, Attribute_Size))
3317 No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
3319 No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
3325 -- All special tests complete, so go ahead with message
3328 end Special_Msg_Delete;
3334 procedure SPARK_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
3336 if SPARK_Mode /= Off then
3337 Error_Msg_N (Msg, N);
3345 procedure SPARK_Msg_NE
3347 N : Node_Or_Entity_Id;
3348 E : Node_Or_Entity_Id)
3351 if SPARK_Mode /= Off then
3352 Error_Msg_NE (Msg, N, E);
3356 --------------------------
3357 -- Unwind_Internal_Type --
3358 --------------------------
3360 procedure Unwind_Internal_Type (Ent : in out Entity_Id) is
3361 Derived : Boolean := False;
3363 Old_Ent : Entity_Id;
3366 -- Undo placement of a quote, since we will put it back later
3368 Mchar := Msg_Buffer (Msglen);
3371 Msglen := Msglen - 1;
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.
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)
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 ");
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 ");
3405 Set_Msg_Str ("access to subprogram");
3410 -- Type is access to object, named or anonymous
3413 Set_Msg_Str ("access to ");
3414 Ent := Directly_Designated_Type (Ent);
3419 elsif Is_Class_Wide_Type (Ent) then
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 ")
3434 Set_Msg_Str ("subtype of ");
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).
3448 FST : constant Entity_Id := First_Subtype (Ent);
3451 if not Is_Internal_Name (Chars (FST)) then
3455 -- Otherwise use root type
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 ");
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;
3490 -- Get out if we finally found a non-internal name to use
3492 exit Find when not Is_Internal_Name (Chars (Ent));
3498 end Unwind_Internal_Type;
3500 --------------------
3501 -- Warn_Insertion --
3502 --------------------
3504 function Warn_Insertion return String is
3506 case Warning_Msg_Char is
3510 when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
3511 return '?' & Warning_Msg_Char & '?';
3517 raise Program_Error;