| blob | 7935a63473ff80ad1a5347f8d85b47a9da1188a4 |
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-2002 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
21 -- --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 -- --
25 ------------------------------------------------------------------------------
27 -- Warning! Error messages can be generated during Gigi processing by direct
28 -- calls to error message routines, so it is essential that the processing
29 -- in this body be consistent with the requirements for the Gigi processing
30 -- environment, and that in particular, no disallowed table expansion is
31 -- allowed to occur.
57 -- This flag is set True when outputting a reference to a class-wide
58 -- type, and is used by Add_Class to insert 'Class at the proper point
61 -- Indicates if current message is a continuation. Initialized from the
62 -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \
63 -- insertion character is encountered.
66 -- Id of most recently posted error message
69 -- Source file index for source file where error is being posted
72 -- Set by Set_Msg_Text to indicate if current message is warning message
75 -- Set by Set_Msg_Text to indicate if current message is serious error
78 -- Set by Set_Msg_Text to indicate if current message is unconditional
81 -- A flag used to kill weird messages (e.g. those containing uninterpreted
82 -- implicit type references) if we have already seen at least one message
83 -- already. The idea is that we hope the weird message is a junk cascaded
84 -- message that should be suppressed.
87 -- Set True if the most recently posted non-continuation message was
88 -- killed. This is used to determine the processing of any continuation
89 -- messages that follow.
92 -- Index into List_Pragmas table
95 -- Starts True, gets set False by pragma List (Off), True by List (On)
98 -- Set True in manual quotation mode
101 -- Maximum length of error message. The addition of Max_Line_Length
102 -- ensures that two insertion tokens of maximum length can be accomodated.
105 -- Buffer used to prepare error messages
108 -- Number of characters currently stored in the message buffer
111 -- A flag used to suppress certain obviously redundant messages (i.e.
112 -- those referring to a node whose type is Any_Type). This suppression
113 -- is effective only if All_Errors_Mode is off.
116 -- Normally, if a # location in a message references a location within
117 -- a generic template, then a note is added giving the location of the
118 -- instantiation. If this variable is set True, then this note is not
119 -- output. This is used for internal processing for the case of an
120 -- illegal instantiation. See Error_Msg routine for further details.
122 -----------------------------------
123 -- Error Message Data Structures --
124 -----------------------------------
126 -- The error messages are stored as a linked list of error message objects
127 -- sorted into ascending order by the source location (Sloc). Each object
128 -- records the text of the message and its source location.
130 -- The following record type and table are used to represent error
131 -- messages, with one entry in the table being allocated for each message.
135 -- Text of error message, fully expanded with all insertions
138 -- Pointer to next message in error chain
141 -- Source table index of source file. In the case of an error that
142 -- refers to a template, always references the original template
143 -- not an instantiation copy.
146 -- Flag pointer. In the case of an error that refers to a template,
147 -- always references the original template, not an instantiation copy.
148 -- This value is the actual place in the source that the error message
149 -- will be posted.
152 -- Flag location used in the call to post the error. This is normally
153 -- the same as Sptr, except in the case of instantiations, where it
154 -- is the original flag location value. This may refer to an instance
155 -- when the actual message (and hence Sptr) references the template.
158 -- Line number for error message
161 -- Column number for error message
164 -- True if warning message (i.e. insertion character ? appeared)
167 -- True if serious error message (not a warning and no | character)
170 -- True if unconditional message (i.e. insertion character ! appeared)
173 -- This is used for logical messages that are composed of multiple
174 -- individual messages. For messages that are not part of such a
175 -- group, or that are the first message in such a group. Msg_Cont
176 -- is set to False. For subsequent messages in a group, Msg_Cont
177 -- is set to True. This is used to make sure that such a group of
178 -- messages is either suppressed or retained as a group (e.g. in
179 -- the circuit that deletes identical messages).
182 -- If this flag is set, the message is not printed. This is used
183 -- in the circuit for deleting duplicate/redundant error messages.
195 -- The list of error messages
197 --------------------------
198 -- Warning Mode Control --
199 --------------------------
201 -- Pragma Warnings allows warnings to be turned off for a specified
202 -- region of code, and the following tabl is the data structure used
203 -- to keep track of these regions.
205 -- It contains pairs of source locations, the first being the start
206 -- location for a warnings off region, and the second being the end
207 -- location. When a pragma Warnings (Off) is encountered, a new entry
208 -- is established extending from the location of the pragma to the
209 -- end of the current source file. A subsequent pragma Warnings (On)
210 -- adjusts the end point of this entry appropriately.
212 -- If all warnings are suppressed by comamnd switch, then there is a
213 -- dummy entry (put there by Errout.Initialize) at the start of the
214 -- table which covers all possible Source_Ptr values. Note that the
215 -- source pointer values in this table always reference the original
216 -- template, not an instantiation copy, in the generic case.
231 -----------------------
232 -- Local Subprograms --
233 -----------------------
236 -- Add 'Class to buffer for class wide type case (Class_Flag set)
239 -- Tests if message buffer ends with given string preceded by a space
242 -- Removes given string from end of buffer if it is present
243 -- at end of buffer, and preceded by a space.
246 -- Called from Error_Msg_N and Error_Msg_NE to generate line of debug
247 -- output giving node number (of node N) if the debug X switch is set.
250 -- This function is passed the Id values of two error messages. If
251 -- either M1 or M2 is a continuation message, or is already deleted,
252 -- the call is ignored. Otherwise a check is made to see if M1 and M2
253 -- are duplicated or redundant. If so, the message to be deleted and
254 -- all its continuations are marked with the Deleted flag set to True.
256 procedure Error_Msg_Internal
260 -- This is like Error_Msg, except that Flag_Location is known not to be
261 -- a location within a instantiation of a generic template. The outer
262 -- level routine, Error_Msg, takes care of dealing with the generic case.
263 -- Msg_Cont is set True to indicate that the message is a continuation of
264 -- a previous message. This means that it must have the same Flag_Location
265 -- as the previous message.
268 -- Given a message id, move to next message id, but skip any deleted
269 -- messages, so that this results in E on output being the first non-
270 -- deleted message following the input value of E, or No_Error_Msg if
271 -- the input value of E was either already No_Error_Msg, or was the
272 -- last non-deleted message.
275 -- Determines if warnings should be suppressed for the given node
278 -- Determines if a node is an OK node to place an error message on (return
279 -- True) or if the error message should be suppressed (return False). A
280 -- message is suppressed if the node already has an error posted on it,
281 -- or if it refers to an Etype that has an error posted on it, or if
282 -- it references an Entity that has an error posted on it.
285 -- Output source line, error flag, and text of stored error message and
286 -- all subsequent messages for the same line and unit. On return E is
287 -- set to be one higher than the last message output.
290 -- Output a line number as six digits (with leading zeroes suppressed),
291 -- followed by a period and a blank (note that this is 8 characters which
292 -- means that tabs in the source line will not get messed up). Line numbers
293 -- that match or are less than the last Source_Reference pragma are listed
294 -- as all blanks, avoiding output of junk line numbers.
297 -- Outputs characters of text in the text of the error message E, excluding
298 -- any final exclamation point. Note that no end of line is output, the
299 -- caller is responsible for adding the end of line.
301 procedure Output_Source_Line
305 -- Outputs text of source line L, in file S, together with preceding line
306 -- number, as described above for Output_Line_Number. The Errs parameter
307 -- indicates if there are errors attached to the line, which forces
308 -- listing on, even in the presence of pragma List (Off).
311 -- See if two messages have the same text. Returns true if the text
312 -- of the two messages is identical, or if one of them is the same
313 -- as the other with an appended "instance at xxx" tag.
316 -- Sets a single blank in the message if the preceding character is a
317 -- non-blank character other than a left parenthesis. Has no effect if
318 -- manual quote mode is turned on.
321 -- Sets a single blank in the message if the preceding character is a
322 -- non-blank character other than a left parenthesis or quote. Has no
323 -- effect if manual quote mode is turned on.
326 -- Add a single character to the current message. This routine does not
327 -- check for special insertion characters (they are just treated as text
328 -- characters if they occur).
331 -- Handle column number insertion (@ insertion character)
334 -- Handle name insertion (% insertion character)
337 -- Handle line number insertion (# insertion character). Loc is the
338 -- location to be referenced, and Flag is the location at which the
339 -- flag is posted (used to determine whether to add "in file xxx")
342 -- Handle node (name from node) insertion (& insertion character)
345 -- Handle insertion of reserved word name (* insertion character).
347 procedure Set_Msg_Insertion_Reserved_Word
350 -- Handle reserved word insertion (upper case letters). The Text argument
351 -- is the current error message input text, and J is an index which on
352 -- entry points to the first character of the reserved word, and on exit
353 -- points past the last character of the reserved word.
356 -- Handle type reference (right brace insertion character). Flag is the
357 -- location of the flag, which is provided for the internal call to
358 -- Set_Msg_Insertion_Line_Number,
361 -- Handle Uint insertion (^ insertion character)
364 -- Handle unit name insertion ($ insertion character)
367 -- Handle file name insertion (left brace insertion character)
370 -- Set the decimal representation of the argument in the error message
371 -- buffer with no leading zeroes output.
374 -- Output name from Name_Buffer, with surrounding quotes unless manual
375 -- quotation mode is in effect.
378 -- Add the sequence of characters for the name associated with the
379 -- given node to the current message.
382 -- Set quote if in normal quote mode, nothing if in manual quote mode
385 -- Add a sequence of characters to the current message. This routine does
386 -- not check for special insertion characters (they are just treated as
387 -- text characters if they occur).
390 -- Add a sequence of characters to the current message. The characters may
391 -- be one of the special insertion characters (see documentation in spec).
392 -- Flag is the location at which the error is to be posted, which is used
393 -- to determine whether or not the # insertion needs a file name. The
394 -- variables Msg_Buffer, Msglen, Is_Warning_Msg, and Is_Unconditional_Msg
395 -- are set on return.
398 -- Sets the Error_Posted flag on the given node, and all its parents
399 -- that are subexpressions and then on the parent non-subexpression
400 -- construct that contains the original expression (this reduces the
401 -- number of cascaded messages)
404 -- Outputs up to N levels of qualification for the given entity. For
405 -- example, the entity A.B.C.D will output B.C. if N = 2.
407 function Special_Msg_Delete
412 -- This function is called from Error_Msg_NEL, passing the message Msg,
413 -- node N on which the error is to be posted, and the entity or node E
414 -- to be used for an & insertion in the message if any. The job of this
415 -- procedure is to test for certain cascaded messages that we would like
416 -- to suppress. If the message is to be suppressed then we return True.
417 -- If the message should be generated (the normal case) False is returned.
420 -- Sets Is_Warning_Msg true if Msg is a warning message (contains a
421 -- question mark character), and False otherwise.
424 -- This procedure is given an entity id for an internal type, i.e.
425 -- a type with an internal name. It unwinds the type to try to get
426 -- to something reasonably printable, generating prefixes like
427 -- "subtype of", "access to", etc along the way in the buffer. The
428 -- value in Ent on return is the final name to be printed. Hopefully
429 -- this is not an internal name, but in some internal name cases, it
430 -- is an internal name, and has to be printed anyway (although in this
431 -- case the message has been killed if possible). The global variable
432 -- Class_Flag is set to True if the resulting entity should have
433 -- 'Class appended to its name (see Add_Class procedure), and is
434 -- otherwise unchanged.
437 -- Determines if given location is covered by a warnings off suppression
438 -- range in the warnings table (or is suppressed by compilation option,
439 -- which generates a warning range for the whole source file).
441 ---------------
442 -- Add_Class --
443 ---------------
446 begin
452 Set_Msg_Name_Buffer;
456 ----------------------
457 -- Buffer_Ends_With --
458 ----------------------
463 begin
464 return
465 Msglen > Len
470 -------------------
471 -- Buffer_Remove --
472 -------------------
475 begin
481 -----------------------
482 -- Change_Error_Text --
483 -----------------------
489 begin
493 -- If in immediate error message mode, output modified error message now
494 -- This is just a bit tricky, because we want to output just a single
495 -- message, and the messages we modified is already linked in. We solve
496 -- this by temporarily resetting its forward pointer to empty.
498 if Debug_Flag_OO then
499 Save_Next := Errors.Table (Error_Id).Next;
500 Errors.Table (Error_Id).Next := No_Error_Msg;
501 Write_Eol;
502 Output_Source_Line
503 (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);
504 Output_Error_Msgs (Err_Id);
505 Errors.Table (Error_Id).Next := Save_Next;
506 end if;
507 end Change_Error_Text;
509 -----------------------------
510 -- Check_Duplicate_Message --
511 -----------------------------
513 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
514 L1, L2 : Error_Msg_Id;
515 N1, N2 : Error_Msg_Id;
517 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
518 -- Called to delete message Delete, keeping message Keep. Marks
519 -- all messages of Delete with deleted flag set to True, and also
520 -- makes sure that for the error messages that are retained the
521 -- preferred message is the one retained (we prefer the shorter
522 -- one in the case where one has an Instance tag). Note that we
523 -- always know that Keep has at least as many continuations as
524 -- Delete (since we always delete the shorter sequence).
526 ----------------
527 -- Delete_Msg --
528 ----------------
530 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
531 D, K : Error_Msg_Id;
533 begin
534 D := Delete;
535 K := Keep;
537 loop
538 Errors.Table (D).Deleted := True;
540 -- Adjust error message count
542 if Errors.Table (D).Warn then
543 Warnings_Detected := Warnings_Detected - 1;
544 else
545 Total_Errors_Detected := Total_Errors_Detected - 1;
547 if Errors.Table (D).Serious then
548 Serious_Errors_Detected := Serious_Errors_Detected - 1;
549 end if;
550 end if;
552 -- Substitute shorter of the two error messages
554 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
555 Errors.Table (K).Text := Errors.Table (D).Text;
556 end if;
558 D := Errors.Table (D).Next;
559 K := Errors.Table (K).Next;
561 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
562 return;
563 end if;
564 end loop;
565 end Delete_Msg;
567 -- Start of processing for Check_Duplicate_Message
569 begin
570 -- Both messages must be non-continuation messages and not deleted
572 if Errors.Table (M1).Msg_Cont
573 or else Errors.Table (M2).Msg_Cont
574 or else Errors.Table (M1).Deleted
575 or else Errors.Table (M2).Deleted
576 then
577 return;
578 end if;
580 -- Definitely not equal if message text does not match
582 if not Same_Error (M1, M2) then
583 return;
584 end if;
586 -- Same text. See if all continuations are also identical
588 L1 := M1;
589 L2 := M2;
591 loop
592 N1 := Errors.Table (L1).Next;
593 N2 := Errors.Table (L2).Next;
595 -- If M1 continuations have run out, we delete M1, either the
596 -- messages have the same number of continuations, or M2 has
597 -- more and we prefer the one with more anyway.
599 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
600 Delete_Msg (M1, M2);
601 return;
603 -- If M2 continuatins have run out, we delete M2
605 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
606 Delete_Msg (M2, M1);
607 return;
609 -- Otherwise see if continuations are the same, if not, keep both
610 -- sequences, a curious case, but better to keep everything!
612 elsif not Same_Error (N1, N2) then
613 return;
615 -- If continuations are the same, continue scan
617 else
618 L1 := N1;
619 L2 := N2;
620 end if;
621 end loop;
622 end Check_Duplicate_Message;
624 ------------------------
625 -- Compilation_Errors --
626 ------------------------
628 function Compilation_Errors return Boolean is
629 begin
630 return Total_Errors_Detected /= 0
631 or else (Warnings_Detected /= 0
632 and then Warning_Mode = Treat_As_Error);
633 end Compilation_Errors;
635 ------------------
636 -- Debug_Output --
637 ------------------
639 procedure Debug_Output (N : Node_Id) is
640 begin
641 if Debug_Flag_1 then
642 Write_Str ("*** following error message posted on node id = #");
643 Write_Int (Int (N));
644 Write_Str (" ***");
645 Write_Eol;
646 end if;
647 end Debug_Output;
649 ----------
650 -- dmsg --
651 ----------
653 procedure dmsg (Id : Error_Msg_Id) is
654 E : Error_Msg_Object renames Errors.Table (Id);
656 begin
657 w ("Dumping error message, Id = ", Int (Id));
658 w (" Text = ", E.Text.all);
659 w (" Next = ", Int (E.Next));
660 w (" Sfile = ", Int (E.Sfile));
662 Write_Str
663 (" Sptr = ");
664 Write_Location (E.Sptr);
665 Write_Eol;
667 Write_Str
668 (" Fptr = ");
669 Write_Location (E.Fptr);
670 Write_Eol;
672 w (" Line = ", Int (E.Line));
673 w (" Col = ", Int (E.Col));
674 w (" Warn = ", E.Warn);
675 w (" Serious = ", E.Serious);
676 w (" Uncond = ", E.Uncond);
677 w (" Msg_Cont = ", E.Msg_Cont);
678 w (" Deleted = ", E.Deleted);
680 Write_Eol;
681 end dmsg;
683 ---------------
684 -- Error_Msg --
685 ---------------
687 -- Error_Msg posts a flag at the given location, except that if the
688 -- Flag_Location points within a generic template and corresponds
689 -- to an instantiation of this generic template, then the actual
690 -- message will be posted on the generic instantiation, along with
691 -- additional messages referencing the generic declaration.
693 procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
694 Sindex : Source_File_Index;
695 -- Source index for flag location
697 Orig_Loc : Source_Ptr;
698 -- Original location of Flag_Location (i.e. location in original
699 -- template in instantiation case, otherwise unchanged).
701 begin
702 -- If we already have messages, and we are trying to place a message
703 -- at No_Location or in package Standard, then just ignore the attempt
704 -- since we assume that what is happening is some cascaded junk. Note
705 -- that this is safe in the sense that proceeding will surely bomb.
707 if Flag_Location < First_Source_Ptr
708 and then Total_Errors_Detected > 0
709 then
710 return;
711 end if;
713 Sindex := Get_Source_File_Index (Flag_Location);
714 Test_Warning_Msg (Msg);
716 -- It is a fatal error to issue an error message when scanning from
717 -- the internal source buffer (see Sinput for further documentation)
719 pragma Assert (Source /= Internal_Source_Ptr);
721 -- Ignore warning message that is suppressed
723 Orig_Loc := Original_Location (Flag_Location);
725 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
726 return;
727 end if;
729 -- The idea at this stage is that we have two kinds of messages.
731 -- First, we have those that are to be placed as requested at
732 -- Flag_Location. This includes messages that have nothing to
733 -- do with generics, and also messages placed on generic templates
734 -- that reflect an error in the template itself. For such messages
735 -- we simply call Error_Msg_Internal to place the message in the
736 -- requested location.
738 if Instantiation (Sindex) = No_Location then
739 Error_Msg_Internal (Msg, Flag_Location, False);
740 return;
741 end if;
743 -- If we are trying to flag an error in an instantiation, we may have
744 -- a generic contract violation. What we generate in this case is:
746 -- instantiation error at ...
747 -- original error message
749 -- or
751 -- warning: in instantiation at
752 -- warning: original warning message
754 -- All these messages are posted at the location of the top level
755 -- instantiation. If there are nested instantiations, then the
756 -- instantiation error message can be repeated, pointing to each
757 -- of the relevant instantiations.
759 -- However, before we do this, we need to worry about the case where
760 -- indeed we are in an instantiation, but the message is a warning
761 -- message. In this case, it almost certainly a warning for the
762 -- template itself and so it is posted on the template. At least
763 -- this is the default mode, it can be cancelled (resulting the
764 -- warning being placed on the instance as in the error case) by
765 -- setting the global Warn_On_Instance True.
767 if (not Warn_On_Instance) and then Is_Warning_Msg then
768 Error_Msg_Internal (Msg, Flag_Location, False);
769 return;
770 end if;
772 -- Second, we need to worry about the case where there was a real error
773 -- in the template, and we are getting a repeat of this error in the
774 -- instantiation. We don't want to complain about the instantiation
775 -- in this case, since we have already flagged the template.
777 -- To deal with this case, just see if we have posted a message at
778 -- the template location already. If so, assume that the current
779 -- message is redundant. There could be cases in which this is not
780 -- a correct assumption, but it is not terrible to lose a message
781 -- about an incorrect instantiation given that we have already
782 -- flagged a message on the template.
784 for Err in Errors.First .. Errors.Last loop
785 if Errors.Table (Err).Sptr = Orig_Loc then
787 -- If the current message is a real error, as opposed to a
788 -- warning, then we don't want to let a warning on the
789 -- template inhibit a real error on the instantiation.
791 if Is_Warning_Msg
792 or else not Errors.Table (Err).Warn
793 then
794 return;
795 end if;
796 end if;
797 end loop;
799 -- OK, this is the case where we have an instantiation error, and
800 -- we need to generate the error on the instantiation, rather than
801 -- on the template. First, see if we have posted this exact error
802 -- before, and if so suppress it. It is not so easy to use the main
803 -- list of errors for this, since they have already been split up
804 -- according to the processing below. Consequently we use an auxiliary
805 -- data structure that just records these types of messages (it will
806 -- never have very many entries).
808 declare
809 Actual_Error_Loc : Source_Ptr;
810 -- Location of outer level instantiation in instantiation case, or
811 -- just a copy of Flag_Location in the normal case. This is the
812 -- location where all error messages will actually be posted.
814 Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
815 -- Save possible location set for caller's message. We need to
816 -- use Error_Msg_Sloc for the location of the instantiation error
817 -- but we have to preserve a possible original value.
819 X : Source_File_Index;
821 Msg_Cont_Status : Boolean;
822 -- Used to label continuation lines in instantiation case with
823 -- proper Msg_Cont status.
825 begin
826 -- Loop to find highest level instantiation, where all error
827 -- messages will be placed.
829 X := Sindex;
830 loop
831 Actual_Error_Loc := Instantiation (X);
832 X := Get_Source_File_Index (Actual_Error_Loc);
833 exit when Instantiation (X) = No_Location;
834 end loop;
836 -- Since we are generating the messages at the instantiation
837 -- point in any case, we do not want the references to the
838 -- bad lines in the instance to be annotated with the location
839 -- of the instantiation.
841 Suppress_Instance_Location := True;
842 Msg_Cont_Status := False;
844 -- Loop to generate instantiation messages
846 Error_Msg_Sloc := Flag_Location;
847 X := Get_Source_File_Index (Flag_Location);
849 while Instantiation (X) /= No_Location loop
851 -- Suppress instantiation message on continuation lines
854 if Is_Warning_Msg then
855 Error_Msg_Internal
856 ("?in instantiation #",
857 Actual_Error_Loc, Msg_Cont_Status);
859 else
860 Error_Msg_Internal
861 ("instantiation error #",
862 Actual_Error_Loc, Msg_Cont_Status);
863 end if;
864 end if;
866 Error_Msg_Sloc := Instantiation (X);
867 X := Get_Source_File_Index (Error_Msg_Sloc);
868 Msg_Cont_Status := True;
869 end loop;
871 Suppress_Instance_Location := False;
872 Error_Msg_Sloc := Save_Error_Msg_Sloc;
874 -- Here we output the original message on the outer instantiation
876 Error_Msg_Internal (Msg, Actual_Error_Loc, Msg_Cont_Status);
877 end;
878 end Error_Msg;
880 ------------------
881 -- Error_Msg_AP --
882 ------------------
884 procedure Error_Msg_AP (Msg : String) is
885 S1 : Source_Ptr;
886 C : Character;
888 begin
889 -- If we had saved the Scan_Ptr value after scanning the previous
890 -- token, then we would have exactly the right place for putting
891 -- the flag immediately at hand. However, that would add at least
892 -- two instructions to a Scan call *just* to service the possibility
893 -- of an Error_Msg_AP call. So instead we reconstruct that value.
895 -- We have two possibilities, start with Prev_Token_Ptr and skip over
896 -- the current token, which is made harder by the possibility that this
897 -- token may be in error, or start with Token_Ptr and work backwards.
898 -- We used to take the second approach, but it's hard because of
899 -- comments, and harder still because things that look like comments
900 -- can appear inside strings. So now we take the first approach.
902 -- Note: in the case where there is no previous token, Prev_Token_Ptr
903 -- is set to Source_First, which is a reasonable position for the
904 -- error flag in this situation.
906 S1 := Prev_Token_Ptr;
907 C := Source (S1);
909 -- If the previous token is a string literal, we need a special approach
910 -- since there may be white space inside the literal and we don't want
911 -- to stop on that white space.
913 if Prev_Token = Tok_String_Literal then
914 loop
915 S1 := S1 + 1;
917 if Source (S1) = C then
918 S1 := S1 + 1;
919 exit when Source (S1) /= C;
920 elsif Source (S1) in Line_Terminator then
921 exit;
922 end if;
923 end loop;
925 -- Character literal also needs special handling
927 elsif Prev_Token = Tok_Char_Literal then
928 S1 := S1 + 3;
930 -- Otherwise we search forward for the end of the current token, marked
931 -- by a line terminator, white space, a comment symbol or if we bump
932 -- into the following token (i.e. the current token)
934 else
935 while Source (S1) not in Line_Terminator
937 and then Source (S1) /= ASCII.HT
939 and then S1 /= Token_Ptr
940 loop
941 S1 := S1 + 1;
942 end loop;
943 end if;
945 -- S1 is now set to the location for the flag
947 Error_Msg (Msg, S1);
949 end Error_Msg_AP;
951 ------------------
952 -- Error_Msg_BC --
953 ------------------
955 procedure Error_Msg_BC (Msg : String) is
956 begin
957 -- If we are at end of file, post the flag after the previous token
959 if Token = Tok_EOF then
960 Error_Msg_AP (Msg);
962 -- If we are at start of file, post the flag at the current token
964 elsif Token_Ptr = Source_First (Current_Source_File) then
965 Error_Msg_SC (Msg);
967 -- If the character before the current token is a space or a horizontal
968 -- tab, then we place the flag on this character (in the case of a tab
969 -- we would really like to place it in the "last" character of the tab
970 -- space, but that it too much trouble to worry about).
973 or else Source (Token_Ptr - 1) = ASCII.HT
974 then
975 Error_Msg (Msg, Token_Ptr - 1);
977 -- If there is no space or tab before the current token, then there is
978 -- no room to place the flag before the token, so we place it on the
979 -- token instead (this happens for example at the start of a line).
981 else
982 Error_Msg (Msg, Token_Ptr);
983 end if;
984 end Error_Msg_BC;
986 ------------------------
987 -- Error_Msg_Internal --
988 ------------------------
990 procedure Error_Msg_Internal
991 (Msg : String;
992 Flag_Location : Source_Ptr;
993 Msg_Cont : Boolean)
994 is
995 Next_Msg : Error_Msg_Id;
996 -- Pointer to next message at insertion point
998 Prev_Msg : Error_Msg_Id;
999 -- Pointer to previous message at insertion point
1001 Temp_Msg : Error_Msg_Id;
1003 Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location);
1005 procedure Handle_Serious_Error;
1006 -- Internal procedure to do all error message handling for a serious
1007 -- error message, other than bumping the error counts and arranging
1008 -- for the message to be output.
1010 --------------------------
1011 -- Handle_Serious_Error --
1012 --------------------------
1014 procedure Handle_Serious_Error is
1015 begin
1016 -- Turn off code generation if not done already
1018 if Operating_Mode = Generate_Code then
1019 Operating_Mode := Check_Semantics;
1020 Expander_Active := False;
1021 end if;
1023 -- Set the fatal error flag in the unit table unless we are
1024 -- in Try_Semantics mode. This stops the semantics from being
1025 -- performed if we find a serious error. This is skipped if we
1026 -- are currently dealing with the configuration pragma file.
1028 if not Try_Semantics
1029 and then Current_Source_Unit /= No_Unit
1030 then
1031 Set_Fatal_Error (Get_Source_Unit (Orig_Loc));
1032 end if;
1033 end Handle_Serious_Error;
1035 -- Start of processing for Error_Msg_Internal
1037 begin
1038 if Raise_Exception_On_Error /= 0 then
1039 raise Error_Msg_Exception;
1040 end if;
1042 Continuation := Msg_Cont;
1043 Suppress_Message := False;
1044 Kill_Message := False;
1045 Set_Msg_Text (Msg, Orig_Loc);
1047 -- Kill continuation if parent message killed
1049 if Continuation and Last_Killed then
1050 return;
1051 end if;
1053 -- Return without doing anything if message is suppressed
1055 if Suppress_Message
1056 and not All_Errors_Mode
1058 then
1059 if not Continuation then
1060 Last_Killed := True;
1061 end if;
1063 return;
1064 end if;
1066 -- Return without doing anything if message is killed and this
1067 -- is not the first error message. The philosophy is that if we
1068 -- get a weird error message and we already have had a message,
1069 -- then we hope the weird message is a junk cascaded message
1071 if Kill_Message
1072 and then not All_Errors_Mode
1073 and then Total_Errors_Detected /= 0
1074 then
1075 if not Continuation then
1076 Last_Killed := True;
1077 end if;
1079 return;
1080 end if;
1082 -- Immediate return if warning message and warnings are suppressed
1084 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
1085 Cur_Msg := No_Error_Msg;
1086 return;
1087 end if;
1089 -- If message is to be ignored in special ignore message mode, this is
1090 -- where we do this special processing, bypassing message output.
1092 if Ignore_Errors_Enable > 0 then
1093 if Is_Serious_Error then
1094 Handle_Serious_Error;
1095 end if;
1097 return;
1098 end if;
1100 -- Otherwise build error message object for new message
1102 Errors.Increment_Last;
1103 Cur_Msg := Errors.Last;
1117 -- If immediate errors mode set, output error message now. Also output
1118 -- now if the -d1 debug flag is set (so node number message comes out
1119 -- just before actual error message)
1122 Write_Eol;
1128 -- If not in immediate errors mode, then we insert the message in the
1129 -- error chain for later output by Finalize. The messages are sorted
1130 -- first by unit (main unit comes first), and within a unit by source
1131 -- location (earlier flag location first in the chain).
1133 else
1138 exit when
1143 then
1151 -- Now we insert the new message in the error chain. The insertion
1152 -- point for the message is after Prev_Msg and before Next_Msg.
1154 -- The possible insertion point for the new message is after Prev_Msg
1155 -- and before Next_Msg. However, this is where we do a special check
1156 -- for redundant parsing messages, defined as messages posted on the
1157 -- same line. The idea here is that probably such messages are junk
1158 -- from the parser recovering. In full errors mode, we don't do this
1159 -- deletion, but otherwise such messages are discarded at this stage.
1167 and then not All_Errors_Mode
1168 then
1169 -- Don't delete unconditional messages and at this stage,
1170 -- don't delete continuation lines (we attempted to delete
1171 -- those earlier if the parent message was deleted.
1174 and then not Continuation
1175 then
1177 -- Don't delete if prev msg is warning and new msg is
1178 -- an error. This is because we don't want a real error
1179 -- masked by a warning. In all other cases (that is parse
1180 -- errors for the same line that are not unconditional)
1181 -- we do delete the message. This helps to avoid
1182 -- junk extra messages from cascaded parsing errors
1186 then
1187 -- All tests passed, delete the message by simply
1188 -- returning without any further processing.
1199 -- Come here if message is to be inserted in the error chain
1207 else
1214 -- Bump appropriate statistics count
1218 else
1223 Handle_Serious_Error;
1227 -- Terminate if max errors reached
1235 -----------------
1236 -- Error_Msg_N --
1237 -----------------
1240 begin
1244 ------------------
1245 -- Error_Msg_NE --
1246 ------------------
1248 procedure Error_Msg_NE
1252 is
1253 begin
1257 -------------------
1258 -- Error_Msg_NEL --
1259 -------------------
1261 procedure Error_Msg_NEL
1266 is
1267 begin
1280 if All_Errors_Mode
1284 then
1289 else
1298 -----------------
1299 -- Error_Msg_S --
1300 -----------------
1303 begin
1307 ------------------
1308 -- Error_Msg_SC --
1309 ------------------
1312 begin
1313 -- If we are at end of file, post the flag after the previous token
1318 -- For all other cases the message is posted at the current token
1319 -- pointer position
1321 else
1326 ------------------
1327 -- Error_Msg_SP --
1328 ------------------
1331 begin
1332 -- Note: in the case where there is no previous token, Prev_Token_Ptr
1333 -- is set to Source_First, which is a reasonable position for the
1334 -- error flag in this situation
1339 --------------
1340 -- Finalize --
1341 --------------
1349 begin
1350 -- Reset current error source file if the main unit has a pragma
1351 -- Source_Reference. This ensures outputting the proper name of
1352 -- the source file in this situation.
1358 -- Eliminate any duplicated error messages from the list. This is
1359 -- done after the fact to avoid problems with Change_Error_Text.
1368 loop
1376 -- Brief Error mode
1380 Set_Standard_Error;
1398 Write_Eol;
1404 Set_Standard_Output;
1407 -- Full source listing case
1413 Write_Eol;
1415 -- First list initial main source file with its error messages
1418 Err_Flag :=
1419 E /= No_Error_Msg
1429 Write_Eol;
1435 -- Then output errors, if any, for subsidiary units
1439 loop
1440 Write_Eol;
1441 Output_Source_Line
1447 -- Verbose mode (error lines only with error flags)
1452 -- Loop through error lines
1455 Write_Eol;
1456 Output_Source_Line
1462 -- Output error summary if verbose or full list mode
1466 -- Extra blank line if error messages or source listing were output
1469 or else Full_List
1470 then
1471 Write_Eol;
1474 -- Message giving number of lines read and number of errors detected.
1475 -- This normally goes to Standard_Output. The exception is when brief
1476 -- mode is not set, verbose mode (or full list mode) is set, and
1477 -- there are errors. In this case we send the message to standard
1478 -- error to make sure that *something* appears on standard error in
1479 -- an error situation.
1481 -- Formerly, only the "# errors" suffix was sent to stderr, whereas
1482 -- "# lines:" appeared on stdout. This caused problems on VMS when
1483 -- the stdout buffer was flushed, giving an extra line feed after
1484 -- the prefix.
1487 and then not Brief_Output
1489 then
1490 Set_Standard_Error;
1493 -- Message giving total number of lines
1500 else
1510 else
1535 Write_Eol;
1536 Set_Standard_Output;
1541 then
1542 Set_Standard_Error;
1544 Write_Eol;
1545 Set_Standard_Output;
1555 ------------------
1556 -- Get_Location --
1557 ------------------
1560 begin
1564 ----------------
1565 -- Get_Msg_Id --
1566 ----------------
1569 begin
1573 ----------------
1574 -- Initialize --
1575 ----------------
1578 begin
1587 -- Initialize warnings table, if all warnings are suppressed, supply
1588 -- an initial dummy entry covering all possible source locations.
1600 -----------------
1601 -- No_Warnings --
1602 -----------------
1605 begin
1615 then
1618 else
1623 -------------
1624 -- OK_Node --
1625 -------------
1630 begin
1637 then
1648 then
1650 else
1655 -----------------------
1656 -- Output_Error_Msgs --
1657 -----------------------
1667 begin
1670 -- Skip deleted messages at start
1676 -- Figure out if we will place more than one error flag on this line
1682 loop
1690 -- Output the error flags. The circuit here makes sure that the tab
1691 -- characters in the original line are properly accounted for. The
1692 -- eight blanks at the start are to match the line number.
1699 -- Loop through error messages for this line to place flags
1705 loop
1706 -- Loop to output blanks till current flag position
1711 else
1718 -- Output flag (unless already output, this happens if more
1719 -- than one error message occurs at the same flag position).
1724 then
1726 else
1737 Write_Eol;
1740 -- Now output the error messages
1747 loop
1759 Write_Eol;
1766 ------------------------
1767 -- Output_Line_Number --
1768 ------------------------
1776 begin
1780 else
1793 else
1796 else
1808 ---------------------
1809 -- Output_Msg_Text --
1810 ---------------------
1813 begin
1817 then
1828 ------------------------
1829 -- Output_Source_Line --
1830 ------------------------
1832 procedure Output_Source_Line
1836 is
1841 -- Set True once line number is output
1843 begin
1847 Write_Eol;
1853 -- Write starting line, except do not write it if we had more
1854 -- than one source reference pragma, since in this case there
1855 -- is no very useful number to write.
1860 Write_Eol;
1873 loop
1877 -- Deal with matching entry in List_Pragmas table
1879 if Full_List
1882 then
1887 -- Ignore if on line with errors so that error flags
1888 -- get properly listed with the error line .
1911 -- Normal case (no matching entry in List_Pragmas table)
1913 else
1923 Write_Eol;
1927 --------------------
1928 -- Purge_Messages --
1929 --------------------
1935 -- Returns True for a message that is to be purged. Also adjusts
1936 -- error counts appropriately.
1939 begin
1943 then
1946 else
1956 else
1961 -- Start of processing for Purge_Messages
1963 begin
1979 -----------------------------
1980 -- Remove_Warning_Messages --
1981 -----------------------------
1986 -- This function checks one node for a possible warning message.
1990 -- This defines the traversal operation
1992 -----------------------
1993 -- Check_For_Warning --
1994 -----------------------
2001 -- Returns True for a message that is to be removed. Also adjusts
2002 -- warning count appropriately.
2004 -------------------
2005 -- To_Be_Removed --
2006 -------------------
2009 begin
2013 then
2016 else
2021 -- Start of processing for Check_For_Warnings
2023 begin
2041 then
2042 -- Warnings may have been posted on subexpressions of
2043 -- the original tree. We place the original node back
2044 -- on the tree to remove those warnings, whose sloc
2045 -- do not match those of any node in the current tree.
2046 -- Given that we are in unreachable code, this modification
2047 -- to the tree is harmless.
2049 declare
2052 begin
2056 else
2064 else
2069 -- Start of processing for Remove_Warning_Messages
2071 begin
2073 declare
2075 begin
2081 ----------------
2082 -- Same_Error --
2083 ----------------
2092 begin
2093 return
2095 or else
2097 and then
2099 and then
2101 or else
2103 and then
2105 and then
2109 -------------------
2110 -- Set_Msg_Blank --
2111 -------------------
2114 begin
2118 and then not Manual_Quote_Mode
2119 then
2124 -------------------------------
2125 -- Set_Msg_Blank_Conditional --
2126 -------------------------------
2129 begin
2134 and then not Manual_Quote_Mode
2135 then
2140 ------------------
2141 -- Set_Msg_Char --
2142 ------------------
2145 begin
2147 -- The check for message buffer overflow is needed to deal with cases
2148 -- where insertions get too long (in particular a child unit name can
2149 -- be very long).
2157 ------------------------------
2158 -- Set_Msg_Insertion_Column --
2159 ------------------------------
2162 begin
2169 ---------------------------------
2170 -- Set_Msg_Insertion_File_Name --
2171 ---------------------------------
2174 begin
2179 Set_Msg_Blank;
2182 else
2183 Set_Msg_Blank;
2185 Set_Msg_Quote;
2186 Set_Msg_Name_Buffer;
2187 Set_Msg_Quote;
2190 -- The following assignments ensure that the second and third percent
2191 -- insertion characters will correspond to the Error_Msg_Name_2 and
2192 -- Error_Msg_Name_3 as required.
2199 -----------------------------------
2200 -- Set_Msg_Insertion_Line_Number --
2201 -----------------------------------
2207 begin
2208 Set_Msg_Blank;
2220 else
2221 -- Add "at file-name:" if reference is to other than the source
2222 -- file in which the error message is placed. Note that we check
2223 -- full file names, rather than just the source indexes, to
2224 -- deal with generic instantiations from the current file.
2231 Get_Name_String
2233 Set_Msg_Name_Buffer;
2236 -- If in current file, add text "at line "
2238 else
2242 -- Output line number for reference
2246 -- Deal with the instantiation case. We may have a reference to,
2247 -- e.g. a type, that is declared within a generic template, and
2248 -- what we are really referring to is the occurrence in an instance.
2249 -- In this case, the line number of the instantiation is also of
2250 -- interest, and we add a notation:
2252 -- , instance at xxx
2254 -- where xxx is a line number output using this same routine (and
2255 -- the recursion can go further if the instantiation is itself in
2256 -- a generic template).
2258 -- The flag location passed to us in this situation is indeed the
2259 -- line number within the template, but as described in Sinput.L
2260 -- (file sinput-l.ads, section "Handling Generic Instantiations")
2261 -- we can retrieve the location of the instantiation itself from
2262 -- this flag location value.
2264 -- Note: this processing is suppressed if Suppress_Instance_Location
2265 -- is set True. This is used to prevent redundant annotations of the
2266 -- location of the instantiation in the case where we are placing
2267 -- the messages on the instantiation in any case.
2270 and then not Suppress_Instance_Location
2271 then
2278 ----------------------------
2279 -- Set_Msg_Insertion_Name --
2280 ----------------------------
2283 begin
2288 Set_Msg_Blank;
2291 else
2292 Set_Msg_Blank_Conditional;
2295 -- Remove %s or %b at end. These come from unit names. If the
2296 -- caller wanted the (unit) or (body), then they would have used
2297 -- the $ insertion character. Certainly no error message should
2298 -- ever have %b or %s explicitly occurring.
2303 or else
2305 then
2309 -- Remove upper case letter at end, again, we should not be getting
2310 -- such names, and what we hope is that the remainder makes sense.
2314 then
2318 -- If operator name or character literal name, just print it as is
2319 -- Also print as is if it ends in a right paren (case of x'val(nnn))
2324 then
2325 Set_Msg_Name_Buffer;
2327 -- Else output with surrounding quotes in proper casing mode
2329 else
2331 Set_Msg_Quote;
2332 Set_Msg_Name_Buffer;
2333 Set_Msg_Quote;
2337 -- The following assignments ensure that the second and third percent
2338 -- insertion characters will correspond to the Error_Msg_Name_2 and
2339 -- Error_Msg_Name_3 as required.
2346 ----------------------------
2347 -- Set_Msg_Insertion_Node --
2348 ----------------------------
2351 begin
2352 Suppress_Message :=
2353 Error_Msg_Node_1 = Error
2357 Set_Msg_Blank_Conditional;
2361 Set_Msg_Blank;
2365 Set_Msg_Blank;
2368 else
2369 Set_Msg_Blank_Conditional;
2371 -- Skip quotes for operator case
2376 else
2377 Set_Msg_Quote;
2380 Set_Msg_Quote;
2384 -- The following assignment ensures that a second ampersand insertion
2385 -- character will correspond to the Error_Msg_Node_2 parameter.
2391 -------------------------------------
2392 -- Set_Msg_Insertion_Reserved_Name --
2393 -------------------------------------
2396 begin
2397 Set_Msg_Blank_Conditional;
2399 Set_Msg_Quote;
2401 Set_Msg_Name_Buffer;
2402 Set_Msg_Quote;
2405 -------------------------------------
2406 -- Set_Msg_Insertion_Reserved_Word --
2407 -------------------------------------
2409 procedure Set_Msg_Insertion_Reserved_Word
2412 is
2413 begin
2414 Set_Msg_Blank_Conditional;
2424 Set_Msg_Quote;
2425 Set_Msg_Name_Buffer;
2426 Set_Msg_Quote;
2429 --------------------------------------
2430 -- Set_Msg_Insertion_Type_Reference --
2431 --------------------------------------
2436 begin
2437 Set_Msg_Blank;
2460 then
2462 Set_Msg_Name_Buffer;
2478 -- Special case of anonymous array
2483 then
2487 Set_Msg_Insertion_Line_Number
2492 -- If we fall through, it is not a special case, so first output
2493 -- the name of the type, preceded by private for a private type
2497 else
2507 -- Types in Standard are displayed as "Standard.name"
2510 Set_Msg_Quote;
2513 Add_Class;
2514 Set_Msg_Quote;
2516 -- Types in other language defined units are displayed as
2517 -- "package-name.type-name"
2519 elsif
2521 then
2522 Get_Unqualified_Decoded_Name_String
2525 Set_Msg_Quote;
2527 Set_Msg_Name_Buffer;
2531 Add_Class;
2532 Set_Msg_Quote;
2534 -- All other types display as "type name" defined at line xxx
2535 -- possibly qualified if qualification is requested.
2537 else
2538 Set_Msg_Quote;
2541 Add_Class;
2542 Set_Msg_Quote;
2545 -- If the original type did not come from a predefined
2546 -- file, add the location where the type was defined.
2549 and then
2550 not Is_Predefined_File_Name
2552 then
2556 -- If it did come from a predefined file, deal with the case where
2557 -- this was a file with a generic instantiation from elsewhere.
2559 else
2561 declare
2565 begin
2567 and then not Suppress_Instance_Location
2568 then
2578 ----------------------------
2579 -- Set_Msg_Insertion_Uint --
2580 ----------------------------
2583 begin
2584 Set_Msg_Blank;
2591 -- The following assignment ensures that a second carret insertion
2592 -- character will correspond to the Error_Msg_Uint_2 parameter.
2597 ---------------------------------
2598 -- Set_Msg_Insertion_Unit_Name --
2599 ---------------------------------
2602 begin
2607 Set_Msg_Blank;
2610 else
2612 Set_Msg_Blank;
2613 Set_Msg_Quote;
2614 Set_Msg_Name_Buffer;
2615 Set_Msg_Quote;
2618 -- The following assignment ensures that a second percent insertion
2619 -- character will correspond to the Error_Msg_Unit_2 parameter.
2625 -----------------
2626 -- Set_Msg_Int --
2627 -----------------
2630 begin
2638 -------------------------
2639 -- Set_Msg_Name_Buffer --
2640 -------------------------
2643 begin
2649 ------------------
2650 -- Set_Msg_Node --
2651 ------------------
2657 begin
2677 -- The only remaining possibilities are identifiers, defining
2678 -- identifiers, pragmas, and pragma argument associations, i.e.
2679 -- nodes that have a Chars field.
2681 -- Internal names generally represent something gone wrong. An exception
2682 -- is the case of internal type names, where we try to find a reasonable
2683 -- external representation for the external name
2686 and then
2690 or else
2692 then
2695 else
2702 else
2706 -- At this stage, the name to output is in Nam
2710 -- Remove trailing upper case letters from the name (useful for
2711 -- dealing with some cases of internal names.
2717 -- If we have any of the names from standard that start with the
2718 -- characters "any " (e.g. Any_Type), then kill the message since
2719 -- almost certainly it is a junk cascaded message.
2723 then
2727 -- Now we have to set the proper case. If we have a source location
2728 -- then do a check to see if the name in the source is the same name
2729 -- as the name in the Names table, except for possible differences
2730 -- in case, which is the case when we can copy from the source.
2732 declare
2738 begin
2742 -- Determine if the reference we are dealing with corresponds
2743 -- to text at the point of the error reference. This will often
2744 -- be the case for simple identifier references, and is the case
2745 -- where we can copy the spelling from the source.
2749 then
2753 exit when
2761 -- If we get through the loop without a mismatch, then output
2762 -- the name the way it is spelled in the source program
2772 -- Otherwise set the casing using the default identifier casing
2774 else
2779 Set_Msg_Name_Buffer;
2780 Add_Class;
2782 -- Add 'Class if class wide type
2788 Set_Msg_Name_Buffer;
2792 -------------------
2793 -- Set_Msg_Quote --
2794 -------------------
2797 begin
2803 -----------------
2804 -- Set_Msg_Str --
2805 -----------------
2808 begin
2814 ------------------
2815 -- Set_Msg_Text --
2816 ------------------
2822 begin
2833 -- Check for insertion character
2836 Set_Msg_Insertion_Name;
2839 Set_Msg_Insertion_Unit_Name;
2842 Set_Msg_Insertion_File_Name;
2848 Set_Msg_Insertion_Reserved_Name;
2851 Set_Msg_Insertion_Node;
2860 Set_Msg_Insertion_Column;
2863 Set_Msg_Insertion_Uint;
2882 -- Upper case letter (start of reserved word if 2 or more)
2887 then
2891 -- Normal character with no special treatment
2893 else
2900 ------------------------------
2901 -- Set_Next_Non_Deleted_Msg --
2902 ------------------------------
2905 begin
2909 else
2910 loop
2917 ----------------
2918 -- Set_Posted --
2919 ----------------
2924 begin
2925 -- We always set Error_Posted on the node itself
2929 -- If it is a subexpression, then set Error_Posted on parents
2930 -- up to and including the first non-subexpression construct. This
2931 -- helps avoid cascaded error messages within a single expression.
2934 loop
2941 -- A special check, if we just posted an error on an attribute
2942 -- definition clause, then also set the entity involved as posted.
2943 -- For example, this stops complaining about the alignment after
2944 -- complaining about the size, which is likely to be useless.
2953 -----------------------
2954 -- Set_Qualification --
2955 -----------------------
2958 begin
2966 ---------------------------
2967 -- Set_Warnings_Mode_Off --
2968 ---------------------------
2971 begin
2972 -- Don't bother with entries from instantiation copies, since we
2973 -- will already have a copy in the template, which is what matters
2979 -- If last entry in table already covers us, this is a redundant
2980 -- pragma Warnings (Off) and can be ignored. This also handles the
2981 -- case where all warnings are suppressed by command line switch.
2986 then
2989 -- Otherwise establish a new entry, extending from the location of
2990 -- the pragma to the end of the current source file. This ending
2991 -- point will be adjusted by a subsequent pragma Warnings (On).
2993 else
3001 --------------------------
3002 -- Set_Warnings_Mode_On --
3003 --------------------------
3006 begin
3007 -- Don't bother with entries from instantiation copies, since we
3008 -- will already have a copy in the template, which is what matters
3014 -- Nothing to do unless command line switch to suppress all warnings
3015 -- is off, and the last entry in the warnings table covers this
3016 -- pragma Warnings (On), in which case adjust the end point.
3022 then
3027 ------------------------
3028 -- Special_Msg_Delete --
3029 ------------------------
3031 function Special_Msg_Delete
3036 is
3037 begin
3038 -- Never delete messages in -gnatdO mode
3043 -- When an atomic object refers to a non-atomic type in the same
3044 -- scope, we implicitly make the type atomic. In the non-error
3045 -- case this is surely safe (and in fact prevents an error from
3046 -- occurring if the type is not atomic by default). But if the
3047 -- object cannot be made atomic, then we introduce an extra junk
3048 -- message by this manipulation, which we get rid of here.
3050 -- We identify this case by the fact that it references a type for
3051 -- which Is_Atomic is set, but there is no Atomic pragma setting it.
3057 then
3060 -- When a size is wrong for a frozen type there is no explicit
3061 -- size clause, and other errors have occurred, suppress the
3062 -- message, since it is likely that this size error is a cascaded
3063 -- result of other errors. The reason we eliminate unfrozen types
3064 -- is that messages issued before the freeze type are for sure OK.
3071 and then
3073 and then
3075 and then
3077 then
3080 -- All special tests complete, so go ahead with message
3082 else
3087 ------------------------------
3088 -- Test_Warning_Serious_Msg --
3089 ------------------------------
3092 begin
3097 else
3104 then
3109 then
3119 --------------------------
3120 -- Unwind_Internal_Type --
3121 --------------------------
3128 begin
3129 -- Undo placement of a quote, since we will put it back later
3137 -- The loop here deals with recursive types, we are trying to
3138 -- find a related entity that is not an implicit type. Note
3139 -- that the check with Old_Ent stops us from getting "stuck".
3140 -- Also, we don't output the "type derived from" message more
3141 -- than once in the case where we climb up multiple levels.
3143 loop
3146 -- Implicit access type, use directly designated type
3152 -- Classwide type
3158 -- Use base type if this is a subtype
3163 -- Avoid duplication "subtype of subtype of", and also replace
3164 -- "derived from subtype of" simply by "derived from"
3168 then
3174 -- If this is a base type with a first named subtype, use the
3175 -- first named subtype instead. This is not quite accurate in
3176 -- all cases, but it makes too much noise to be accurate and
3177 -- add 'Base in all cases. Note that we only do this is the
3178 -- first named subtype is not itself an internal name. This
3179 -- avoids the obvious loop (subtype->basetype->subtype) which
3180 -- would otherwise occur!)
3184 and then
3185 not Is_Internal_Name
3187 then
3190 -- Otherwise use root type
3192 else
3196 -- Test for "subtype of type derived from" which seems
3197 -- excessive and is replaced by simply "type derived from"
3201 -- Avoid duplication "type derived from type derived from"
3213 -- If we are stuck in a loop, get out and settle for the internal
3214 -- name after all. In this case we set to kill the message if it
3215 -- is not the first error message (we really try hard not to show
3216 -- the dirty laundry of the implementation to the poor user!)
3223 -- Get out if we finally found a non-internal name to use
3234 -------------------------
3235 -- Warnings_Suppressed --
3236 -------------------------
3239 begin
3243 then