| blob | 6aa3f22b8e5a0bcbea4af777abe3defb1299c1f4 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E R R O U T --
6 -- --
7 -- B o d y --
8 -- --
9 -- --
10 -- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
11 -- --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
22 -- --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 -- --
26 ------------------------------------------------------------------------------
28 -- Warning! Error messages can be generated during Gigi processing by direct
29 -- calls to error message routines, so it is essential that the processing
30 -- in this body be consistent with the requirements for the Gigi processing
31 -- environment, and that in particular, no disallowed table expansion is
32 -- allowed to occur.
58 -- This flag is set True when outputting a reference to a class-wide
59 -- type, and is used by Add_Class to insert 'Class at the proper point
62 -- Indicates if current message is a continuation. Initialized from the
63 -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \
64 -- insertion character is encountered.
67 -- Id of most recently posted error message
70 -- Source file index for source file where error is being posted
73 -- Set by Set_Msg_Text to indicate if current message is warning message
76 -- Set by Set_Msg_Text to indicate if current message is serious error
79 -- Set by Set_Msg_Text to indicate if current message is unconditional
82 -- A flag used to kill weird messages (e.g. those containing uninterpreted
83 -- implicit type references) if we have already seen at least one message
84 -- already. The idea is that we hope the weird message is a junk cascaded
85 -- message that should be suppressed.
88 -- Set True if the most recently posted non-continuation message was
89 -- killed. This is used to determine the processing of any continuation
90 -- messages that follow.
93 -- Index into List_Pragmas table
96 -- Starts True, gets set False by pragma List (Off), True by List (On)
99 -- Set True in manual quotation mode
102 -- Maximum length of error message. The addition of Max_Line_Length
103 -- ensures that two insertion tokens of maximum length can be accomodated.
106 -- Buffer used to prepare error messages
109 -- Number of characters currently stored in the message buffer
112 -- A flag used to suppress certain obviously redundant messages (i.e.
113 -- those referring to a node whose type is Any_Type). This suppression
114 -- is effective only if All_Errors_Mode is off.
117 -- Normally, if a # location in a message references a location within
118 -- a generic template, then a note is added giving the location of the
119 -- instantiation. If this variable is set True, then this note is not
120 -- output. This is used for internal processing for the case of an
121 -- illegal instantiation. See Error_Msg routine for further details.
123 -----------------------------------
124 -- Error Message Data Structures --
125 -----------------------------------
127 -- The error messages are stored as a linked list of error message objects
128 -- sorted into ascending order by the source location (Sloc). Each object
129 -- records the text of the message and its source location.
131 -- The following record type and table are used to represent error
132 -- messages, with one entry in the table being allocated for each message.
136 -- Text of error message, fully expanded with all insertions
139 -- Pointer to next message in error chain
142 -- Source table index of source file. In the case of an error that
143 -- refers to a template, always references the original template
144 -- not an instantiation copy.
147 -- Flag pointer. In the case of an error that refers to a template,
148 -- always references the original template, not an instantiation copy.
149 -- This value is the actual place in the source that the error message
150 -- will be posted.
153 -- Flag location used in the call to post the error. This is normally
154 -- the same as Sptr, except in the case of instantiations, where it
155 -- is the original flag location value. This may refer to an instance
156 -- when the actual message (and hence Sptr) references the template.
159 -- Line number for error message
162 -- Column number for error message
165 -- True if warning message (i.e. insertion character ? appeared)
168 -- True if serious error message (not a warning and no | character)
171 -- True if unconditional message (i.e. insertion character ! appeared)
174 -- This is used for logical messages that are composed of multiple
175 -- individual messages. For messages that are not part of such a
176 -- group, or that are the first message in such a group. Msg_Cont
177 -- is set to False. For subsequent messages in a group, Msg_Cont
178 -- is set to True. This is used to make sure that such a group of
179 -- messages is either suppressed or retained as a group (e.g. in
180 -- the circuit that deletes identical messages).
183 -- If this flag is set, the message is not printed. This is used
184 -- in the circuit for deleting duplicate/redundant error messages.
196 -- The list of error messages
198 --------------------------
199 -- Warning Mode Control --
200 --------------------------
202 -- Pragma Warnings allows warnings to be turned off for a specified
203 -- region of code, and the following tabl is the data structure used
204 -- to keep track of these regions.
206 -- It contains pairs of source locations, the first being the start
207 -- location for a warnings off region, and the second being the end
208 -- location. When a pragma Warnings (Off) is encountered, a new entry
209 -- is established extending from the location of the pragma to the
210 -- end of the current source file. A subsequent pragma Warnings (On)
211 -- adjusts the end point of this entry appropriately.
213 -- If all warnings are suppressed by comamnd switch, then there is a
214 -- dummy entry (put there by Errout.Initialize) at the start of the
215 -- table which covers all possible Source_Ptr values. Note that the
216 -- source pointer values in this table always reference the original
217 -- template, not an instantiation copy, in the generic case.
232 -----------------------
233 -- Local Subprograms --
234 -----------------------
237 -- Add 'Class to buffer for class wide type case (Class_Flag set)
240 -- Tests if message buffer ends with given string preceded by a space
243 -- Removes given string from end of buffer if it is present
244 -- at end of buffer, and preceded by a space.
247 -- Called from Error_Msg_N and Error_Msg_NE to generate line of debug
248 -- output giving node number (of node N) if the debug X switch is set.
251 -- This function is passed the Id values of two error messages. If
252 -- either M1 or M2 is a continuation message, or is already deleted,
253 -- the call is ignored. Otherwise a check is made to see if M1 and M2
254 -- are duplicated or redundant. If so, the message to be deleted and
255 -- all its continuations are marked with the Deleted flag set to True.
257 procedure Error_Msg_Internal
261 -- This is like Error_Msg, except that Flag_Location is known not to be
262 -- a location within a instantiation of a generic template. The outer
263 -- level routine, Error_Msg, takes care of dealing with the generic case.
264 -- Msg_Cont is set True to indicate that the message is a continuation of
265 -- a previous message. This means that it must have the same Flag_Location
266 -- as the previous message.
269 -- Given a message id, move to next message id, but skip any deleted
270 -- messages, so that this results in E on output being the first non-
271 -- deleted message following the input value of E, or No_Error_Msg if
272 -- the input value of E was either already No_Error_Msg, or was the
273 -- last non-deleted message.
276 -- Determines if warnings should be suppressed for the given node
279 -- Determines if a node is an OK node to place an error message on (return
280 -- True) or if the error message should be suppressed (return False). A
281 -- message is suppressed if the node already has an error posted on it,
282 -- or if it refers to an Etype that has an error posted on it, or if
283 -- it references an Entity that has an error posted on it.
286 -- Output source line, error flag, and text of stored error message and
287 -- all subsequent messages for the same line and unit. On return E is
288 -- set to be one higher than the last message output.
291 -- Output a line number as six digits (with leading zeroes suppressed),
292 -- followed by a period and a blank (note that this is 8 characters which
293 -- means that tabs in the source line will not get messed up). Line numbers
294 -- that match or are less than the last Source_Reference pragma are listed
295 -- as all blanks, avoiding output of junk line numbers.
298 -- Outputs characters of text in the text of the error message E, excluding
299 -- any final exclamation point. Note that no end of line is output, the
300 -- caller is responsible for adding the end of line.
302 procedure Output_Source_Line
306 -- Outputs text of source line L, in file S, together with preceding line
307 -- number, as described above for Output_Line_Number. The Errs parameter
308 -- indicates if there are errors attached to the line, which forces
309 -- listing on, even in the presence of pragma List (Off).
312 -- See if two messages have the same text. Returns true if the text
313 -- of the two messages is identical, or if one of them is the same
314 -- as the other with an appended "instance at xxx" tag.
317 -- Sets a single blank in the message if the preceding character is a
318 -- non-blank character other than a left parenthesis. Has no effect if
319 -- manual quote mode is turned on.
322 -- Sets a single blank in the message if the preceding character is a
323 -- non-blank character other than a left parenthesis or quote. Has no
324 -- effect if manual quote mode is turned on.
327 -- Add a single character to the current message. This routine does not
328 -- check for special insertion characters (they are just treated as text
329 -- characters if they occur).
332 -- Handle column number insertion (@ insertion character)
335 -- Handle name insertion (% insertion character)
338 -- Handle line number insertion (# insertion character). Loc is the
339 -- location to be referenced, and Flag is the location at which the
340 -- flag is posted (used to determine whether to add "in file xxx")
343 -- Handle node (name from node) insertion (& insertion character)
346 -- Handle insertion of reserved word name (* insertion character).
348 procedure Set_Msg_Insertion_Reserved_Word
351 -- Handle reserved word insertion (upper case letters). The Text argument
352 -- is the current error message input text, and J is an index which on
353 -- entry points to the first character of the reserved word, and on exit
354 -- points past the last character of the reserved word.
357 -- Handle type reference (right brace insertion character). Flag is the
358 -- location of the flag, which is provided for the internal call to
359 -- Set_Msg_Insertion_Line_Number,
362 -- Handle Uint insertion (^ insertion character)
365 -- Handle unit name insertion ($ insertion character)
368 -- Handle file name insertion (left brace insertion character)
371 -- Set the decimal representation of the argument in the error message
372 -- buffer with no leading zeroes output.
375 -- Output name from Name_Buffer, with surrounding quotes unless manual
376 -- quotation mode is in effect.
379 -- Add the sequence of characters for the name associated with the
380 -- given node to the current message.
383 -- Set quote if in normal quote mode, nothing if in manual quote mode
386 -- Add a sequence of characters to the current message. This routine does
387 -- not check for special insertion characters (they are just treated as
388 -- text characters if they occur).
391 -- Add a sequence of characters to the current message. The characters may
392 -- be one of the special insertion characters (see documentation in spec).
393 -- Flag is the location at which the error is to be posted, which is used
394 -- to determine whether or not the # insertion needs a file name. The
395 -- variables Msg_Buffer, Msglen, Is_Warning_Msg, and Is_Unconditional_Msg
396 -- are set on return.
399 -- Sets the Error_Posted flag on the given node, and all its parents
400 -- that are subexpressions and then on the parent non-subexpression
401 -- construct that contains the original expression (this reduces the
402 -- number of cascaded messages)
405 -- Outputs up to N levels of qualification for the given entity. For
406 -- example, the entity A.B.C.D will output B.C. if N = 2.
408 function Special_Msg_Delete
413 -- This function is called from Error_Msg_NEL, passing the message Msg,
414 -- node N on which the error is to be posted, and the entity or node E
415 -- to be used for an & insertion in the message if any. The job of this
416 -- procedure is to test for certain cascaded messages that we would like
417 -- to suppress. If the message is to be suppressed then we return True.
418 -- If the message should be generated (the normal case) False is returned.
421 -- Sets Is_Warning_Msg true if Msg is a warning message (contains a
422 -- question mark character), and False otherwise.
425 -- This procedure is given an entity id for an internal type, i.e.
426 -- a type with an internal name. It unwinds the type to try to get
427 -- to something reasonably printable, generating prefixes like
428 -- "subtype of", "access to", etc along the way in the buffer. The
429 -- value in Ent on return is the final name to be printed. Hopefully
430 -- this is not an internal name, but in some internal name cases, it
431 -- is an internal name, and has to be printed anyway (although in this
432 -- case the message has been killed if possible). The global variable
433 -- Class_Flag is set to True if the resulting entity should have
434 -- 'Class appended to its name (see Add_Class procedure), and is
435 -- otherwise unchanged.
438 -- Determines if given location is covered by a warnings off suppression
439 -- range in the warnings table (or is suppressed by compilation option,
440 -- which generates a warning range for the whole source file).
442 ---------------
443 -- Add_Class --
444 ---------------
447 begin
453 Set_Msg_Name_Buffer;
457 ----------------------
458 -- Buffer_Ends_With --
459 ----------------------
464 begin
465 return
466 Msglen > Len
471 -------------------
472 -- Buffer_Remove --
473 -------------------
476 begin
482 -----------------------
483 -- Change_Error_Text --
484 -----------------------
490 begin
494 -- If in immediate error message mode, output modified error message now
495 -- This is just a bit tricky, because we want to output just a single
496 -- message, and the messages we modified is already linked in. We solve
497 -- this by temporarily resetting its forward pointer to empty.
499 if Debug_Flag_OO then
500 Save_Next := Errors.Table (Error_Id).Next;
501 Errors.Table (Error_Id).Next := No_Error_Msg;
502 Write_Eol;
503 Output_Source_Line
504 (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);
505 Output_Error_Msgs (Err_Id);
506 Errors.Table (Error_Id).Next := Save_Next;
507 end if;
508 end Change_Error_Text;
510 -----------------------------
511 -- Check_Duplicate_Message --
512 -----------------------------
514 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
515 L1, L2 : Error_Msg_Id;
516 N1, N2 : Error_Msg_Id;
518 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
519 -- Called to delete message Delete, keeping message Keep. Marks
520 -- all messages of Delete with deleted flag set to True, and also
521 -- makes sure that for the error messages that are retained the
522 -- preferred message is the one retained (we prefer the shorter
523 -- one in the case where one has an Instance tag). Note that we
524 -- always know that Keep has at least as many continuations as
525 -- Delete (since we always delete the shorter sequence).
527 ----------------
528 -- Delete_Msg --
529 ----------------
531 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
532 D, K : Error_Msg_Id;
534 begin
535 D := Delete;
536 K := Keep;
538 loop
539 Errors.Table (D).Deleted := True;
541 -- Adjust error message count
543 if Errors.Table (D).Warn then
544 Warnings_Detected := Warnings_Detected - 1;
545 else
546 Total_Errors_Detected := Total_Errors_Detected - 1;
548 if Errors.Table (D).Serious then
549 Serious_Errors_Detected := Serious_Errors_Detected - 1;
550 end if;
551 end if;
553 -- Substitute shorter of the two error messages
555 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
556 Errors.Table (K).Text := Errors.Table (D).Text;
557 end if;
559 D := Errors.Table (D).Next;
560 K := Errors.Table (K).Next;
562 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
563 return;
564 end if;
565 end loop;
566 end Delete_Msg;
568 -- Start of processing for Check_Duplicate_Message
570 begin
571 -- Both messages must be non-continuation messages and not deleted
573 if Errors.Table (M1).Msg_Cont
574 or else Errors.Table (M2).Msg_Cont
575 or else Errors.Table (M1).Deleted
576 or else Errors.Table (M2).Deleted
577 then
578 return;
579 end if;
581 -- Definitely not equal if message text does not match
583 if not Same_Error (M1, M2) then
584 return;
585 end if;
587 -- Same text. See if all continuations are also identical
589 L1 := M1;
590 L2 := M2;
592 loop
593 N1 := Errors.Table (L1).Next;
594 N2 := Errors.Table (L2).Next;
596 -- If M1 continuations have run out, we delete M1, either the
597 -- messages have the same number of continuations, or M2 has
598 -- more and we prefer the one with more anyway.
600 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
601 Delete_Msg (M1, M2);
602 return;
604 -- If M2 continuatins have run out, we delete M2
606 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
607 Delete_Msg (M2, M1);
608 return;
610 -- Otherwise see if continuations are the same, if not, keep both
611 -- sequences, a curious case, but better to keep everything!
613 elsif not Same_Error (N1, N2) then
614 return;
616 -- If continuations are the same, continue scan
618 else
619 L1 := N1;
620 L2 := N2;
621 end if;
622 end loop;
623 end Check_Duplicate_Message;
625 ------------------------
626 -- Compilation_Errors --
627 ------------------------
629 function Compilation_Errors return Boolean is
630 begin
631 return Total_Errors_Detected /= 0
632 or else (Warnings_Detected /= 0
633 and then Warning_Mode = Treat_As_Error);
634 end Compilation_Errors;
636 ------------------
637 -- Debug_Output --
638 ------------------
640 procedure Debug_Output (N : Node_Id) is
641 begin
642 if Debug_Flag_1 then
643 Write_Str ("*** following error message posted on node id = #");
644 Write_Int (Int (N));
645 Write_Str (" ***");
646 Write_Eol;
647 end if;
648 end Debug_Output;
650 ----------
651 -- dmsg --
652 ----------
654 procedure dmsg (Id : Error_Msg_Id) is
655 E : Error_Msg_Object renames Errors.Table (Id);
657 begin
658 w ("Dumping error message, Id = ", Int (Id));
659 w (" Text = ", E.Text.all);
660 w (" Next = ", Int (E.Next));
661 w (" Sfile = ", Int (E.Sfile));
663 Write_Str
664 (" Sptr = ");
665 Write_Location (E.Sptr);
666 Write_Eol;
668 Write_Str
669 (" Fptr = ");
670 Write_Location (E.Fptr);
671 Write_Eol;
673 w (" Line = ", Int (E.Line));
674 w (" Col = ", Int (E.Col));
675 w (" Warn = ", E.Warn);
676 w (" Serious = ", E.Serious);
677 w (" Uncond = ", E.Uncond);
678 w (" Msg_Cont = ", E.Msg_Cont);
679 w (" Deleted = ", E.Deleted);
681 Write_Eol;
682 end dmsg;
684 ---------------
685 -- Error_Msg --
686 ---------------
688 -- Error_Msg posts a flag at the given location, except that if the
689 -- Flag_Location points within a generic template and corresponds
690 -- to an instantiation of this generic template, then the actual
691 -- message will be posted on the generic instantiation, along with
692 -- additional messages referencing the generic declaration.
694 procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
695 Sindex : Source_File_Index;
696 -- Source index for flag location
698 Orig_Loc : Source_Ptr;
699 -- Original location of Flag_Location (i.e. location in original
700 -- template in instantiation case, otherwise unchanged).
702 begin
703 -- If we already have messages, and we are trying to place a message
704 -- at No_Location or in package Standard, then just ignore the attempt
705 -- since we assume that what is happening is some cascaded junk. Note
706 -- that this is safe in the sense that proceeding will surely bomb.
708 if Flag_Location < First_Source_Ptr
709 and then Total_Errors_Detected > 0
710 then
711 return;
712 end if;
714 Sindex := Get_Source_File_Index (Flag_Location);
715 Test_Warning_Msg (Msg);
717 -- It is a fatal error to issue an error message when scanning from
718 -- the internal source buffer (see Sinput for further documentation)
720 pragma Assert (Source /= Internal_Source_Ptr);
722 -- Ignore warning message that is suppressed
724 Orig_Loc := Original_Location (Flag_Location);
726 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
727 return;
728 end if;
730 -- The idea at this stage is that we have two kinds of messages.
732 -- First, we have those that are to be placed as requested at
733 -- Flag_Location. This includes messages that have nothing to
734 -- do with generics, and also messages placed on generic templates
735 -- that reflect an error in the template itself. For such messages
736 -- we simply call Error_Msg_Internal to place the message in the
737 -- requested location.
739 if Instantiation (Sindex) = No_Location then
740 Error_Msg_Internal (Msg, Flag_Location, False);
741 return;
742 end if;
744 -- If we are trying to flag an error in an instantiation, we may have
745 -- a generic contract violation. What we generate in this case is:
747 -- instantiation error at ...
748 -- original error message
750 -- or
752 -- warning: in instantiation at
753 -- warning: original warning message
755 -- All these messages are posted at the location of the top level
756 -- instantiation. If there are nested instantiations, then the
757 -- instantiation error message can be repeated, pointing to each
758 -- of the relevant instantiations.
760 -- However, before we do this, we need to worry about the case where
761 -- indeed we are in an instantiation, but the message is a warning
762 -- message. In this case, it almost certainly a warning for the
763 -- template itself and so it is posted on the template. At least
764 -- this is the default mode, it can be cancelled (resulting the
765 -- warning being placed on the instance as in the error case) by
766 -- setting the global Warn_On_Instance True.
768 if (not Warn_On_Instance) and then Is_Warning_Msg then
769 Error_Msg_Internal (Msg, Flag_Location, False);
770 return;
771 end if;
773 -- Second, we need to worry about the case where there was a real error
774 -- in the template, and we are getting a repeat of this error in the
775 -- instantiation. We don't want to complain about the instantiation
776 -- in this case, since we have already flagged the template.
778 -- To deal with this case, just see if we have posted a message at
779 -- the template location already. If so, assume that the current
780 -- message is redundant. There could be cases in which this is not
781 -- a correct assumption, but it is not terrible to lose a message
782 -- about an incorrect instantiation given that we have already
783 -- flagged a message on the template.
785 for Err in Errors.First .. Errors.Last loop
786 if Errors.Table (Err).Sptr = Orig_Loc then
788 -- If the current message is a real error, as opposed to a
789 -- warning, then we don't want to let a warning on the
790 -- template inhibit a real error on the instantiation.
792 if Is_Warning_Msg
793 or else not Errors.Table (Err).Warn
794 then
795 return;
796 end if;
797 end if;
798 end loop;
800 -- OK, this is the case where we have an instantiation error, and
801 -- we need to generate the error on the instantiation, rather than
802 -- on the template. First, see if we have posted this exact error
803 -- before, and if so suppress it. It is not so easy to use the main
804 -- list of errors for this, since they have already been split up
805 -- according to the processing below. Consequently we use an auxiliary
806 -- data structure that just records these types of messages (it will
807 -- never have very many entries).
809 declare
810 Actual_Error_Loc : Source_Ptr;
811 -- Location of outer level instantiation in instantiation case, or
812 -- just a copy of Flag_Location in the normal case. This is the
813 -- location where all error messages will actually be posted.
815 Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
816 -- Save possible location set for caller's message. We need to
817 -- use Error_Msg_Sloc for the location of the instantiation error
818 -- but we have to preserve a possible original value.
820 X : Source_File_Index;
822 Msg_Cont_Status : Boolean;
823 -- Used to label continuation lines in instantiation case with
824 -- proper Msg_Cont status.
826 begin
827 -- Loop to find highest level instantiation, where all error
828 -- messages will be placed.
830 X := Sindex;
831 loop
832 Actual_Error_Loc := Instantiation (X);
833 X := Get_Source_File_Index (Actual_Error_Loc);
834 exit when Instantiation (X) = No_Location;
835 end loop;
837 -- Since we are generating the messages at the instantiation
838 -- point in any case, we do not want the references to the
839 -- bad lines in the instance to be annotated with the location
840 -- of the instantiation.
842 Suppress_Instance_Location := True;
843 Msg_Cont_Status := False;
845 -- Loop to generate instantiation messages
847 Error_Msg_Sloc := Flag_Location;
848 X := Get_Source_File_Index (Flag_Location);
850 while Instantiation (X) /= No_Location loop
852 -- Suppress instantiation message on continuation lines
855 if Is_Warning_Msg then
856 Error_Msg_Internal
857 ("?in instantiation #",
858 Actual_Error_Loc, Msg_Cont_Status);
860 else
861 Error_Msg_Internal
862 ("instantiation error #",
863 Actual_Error_Loc, Msg_Cont_Status);
864 end if;
865 end if;
867 Error_Msg_Sloc := Instantiation (X);
868 X := Get_Source_File_Index (Error_Msg_Sloc);
869 Msg_Cont_Status := True;
870 end loop;
872 Suppress_Instance_Location := False;
873 Error_Msg_Sloc := Save_Error_Msg_Sloc;
875 -- Here we output the original message on the outer instantiation
877 Error_Msg_Internal (Msg, Actual_Error_Loc, Msg_Cont_Status);
878 end;
879 end Error_Msg;
881 ------------------
882 -- Error_Msg_AP --
883 ------------------
885 procedure Error_Msg_AP (Msg : String) is
886 S1 : Source_Ptr;
887 C : Character;
889 begin
890 -- If we had saved the Scan_Ptr value after scanning the previous
891 -- token, then we would have exactly the right place for putting
892 -- the flag immediately at hand. However, that would add at least
893 -- two instructions to a Scan call *just* to service the possibility
894 -- of an Error_Msg_AP call. So instead we reconstruct that value.
896 -- We have two possibilities, start with Prev_Token_Ptr and skip over
897 -- the current token, which is made harder by the possibility that this
898 -- token may be in error, or start with Token_Ptr and work backwards.
899 -- We used to take the second approach, but it's hard because of
900 -- comments, and harder still because things that look like comments
901 -- can appear inside strings. So now we take the first approach.
903 -- Note: in the case where there is no previous token, Prev_Token_Ptr
904 -- is set to Source_First, which is a reasonable position for the
905 -- error flag in this situation.
907 S1 := Prev_Token_Ptr;
908 C := Source (S1);
910 -- If the previous token is a string literal, we need a special approach
911 -- since there may be white space inside the literal and we don't want
912 -- to stop on that white space.
914 if Prev_Token = Tok_String_Literal then
915 loop
916 S1 := S1 + 1;
918 if Source (S1) = C then
919 S1 := S1 + 1;
920 exit when Source (S1) /= C;
921 elsif Source (S1) in Line_Terminator then
922 exit;
923 end if;
924 end loop;
926 -- Character literal also needs special handling
928 elsif Prev_Token = Tok_Char_Literal then
929 S1 := S1 + 3;
931 -- Otherwise we search forward for the end of the current token, marked
932 -- by a line terminator, white space, a comment symbol or if we bump
933 -- into the following token (i.e. the current token)
935 else
936 while Source (S1) not in Line_Terminator
938 and then Source (S1) /= ASCII.HT
940 and then S1 /= Token_Ptr
941 loop
942 S1 := S1 + 1;
943 end loop;
944 end if;
946 -- S1 is now set to the location for the flag
948 Error_Msg (Msg, S1);
950 end Error_Msg_AP;
952 ------------------
953 -- Error_Msg_BC --
954 ------------------
956 procedure Error_Msg_BC (Msg : String) is
957 begin
958 -- If we are at end of file, post the flag after the previous token
960 if Token = Tok_EOF then
961 Error_Msg_AP (Msg);
963 -- If we are at start of file, post the flag at the current token
965 elsif Token_Ptr = Source_First (Current_Source_File) then
966 Error_Msg_SC (Msg);
968 -- If the character before the current token is a space or a horizontal
969 -- tab, then we place the flag on this character (in the case of a tab
970 -- we would really like to place it in the "last" character of the tab
971 -- space, but that it too much trouble to worry about).
974 or else Source (Token_Ptr - 1) = ASCII.HT
975 then
976 Error_Msg (Msg, Token_Ptr - 1);
978 -- If there is no space or tab before the current token, then there is
979 -- no room to place the flag before the token, so we place it on the
980 -- token instead (this happens for example at the start of a line).
982 else
983 Error_Msg (Msg, Token_Ptr);
984 end if;
985 end Error_Msg_BC;
987 ------------------------
988 -- Error_Msg_Internal --
989 ------------------------
991 procedure Error_Msg_Internal
992 (Msg : String;
993 Flag_Location : Source_Ptr;
994 Msg_Cont : Boolean)
995 is
996 Next_Msg : Error_Msg_Id;
997 -- Pointer to next message at insertion point
999 Prev_Msg : Error_Msg_Id;
1000 -- Pointer to previous message at insertion point
1002 Temp_Msg : Error_Msg_Id;
1004 Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location);
1006 procedure Handle_Serious_Error;
1007 -- Internal procedure to do all error message handling for a serious
1008 -- error message, other than bumping the error counts and arranging
1009 -- for the message to be output.
1011 --------------------------
1012 -- Handle_Serious_Error --
1013 --------------------------
1015 procedure Handle_Serious_Error is
1016 begin
1017 -- Turn off code generation if not done already
1019 if Operating_Mode = Generate_Code then
1020 Operating_Mode := Check_Semantics;
1021 Expander_Active := False;
1022 end if;
1024 -- Set the fatal error flag in the unit table unless we are
1025 -- in Try_Semantics mode. This stops the semantics from being
1026 -- performed if we find a serious error. This is skipped if we
1027 -- are currently dealing with the configuration pragma file.
1029 if not Try_Semantics
1030 and then Current_Source_Unit /= No_Unit
1031 then
1032 Set_Fatal_Error (Get_Source_Unit (Orig_Loc));
1033 end if;
1034 end Handle_Serious_Error;
1036 -- Start of processing for Error_Msg_Internal
1038 begin
1039 if Raise_Exception_On_Error /= 0 then
1040 raise Error_Msg_Exception;
1041 end if;
1043 Continuation := Msg_Cont;
1044 Suppress_Message := False;
1045 Kill_Message := False;
1046 Set_Msg_Text (Msg, Orig_Loc);
1048 -- Kill continuation if parent message killed
1050 if Continuation and Last_Killed then
1051 return;
1052 end if;
1054 -- Return without doing anything if message is suppressed
1056 if Suppress_Message
1057 and not All_Errors_Mode
1059 then
1060 if not Continuation then
1061 Last_Killed := True;
1062 end if;
1064 return;
1065 end if;
1067 -- Return without doing anything if message is killed and this
1068 -- is not the first error message. The philosophy is that if we
1069 -- get a weird error message and we already have had a message,
1070 -- then we hope the weird message is a junk cascaded message
1072 if Kill_Message
1073 and then not All_Errors_Mode
1074 and then Total_Errors_Detected /= 0
1075 then
1076 if not Continuation then
1077 Last_Killed := True;
1078 end if;
1080 return;
1081 end if;
1083 -- Immediate return if warning message and warnings are suppressed
1085 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
1086 Cur_Msg := No_Error_Msg;
1087 return;
1088 end if;
1090 -- If message is to be ignored in special ignore message mode, this is
1091 -- where we do this special processing, bypassing message output.
1093 if Ignore_Errors_Enable > 0 then
1094 if Is_Serious_Error then
1095 Handle_Serious_Error;
1096 end if;
1098 return;
1099 end if;
1101 -- Otherwise build error message object for new message
1103 Errors.Increment_Last;
1104 Cur_Msg := Errors.Last;
1118 -- If immediate errors mode set, output error message now. Also output
1119 -- now if the -d1 debug flag is set (so node number message comes out
1120 -- just before actual error message)
1123 Write_Eol;
1129 -- If not in immediate errors mode, then we insert the message in the
1130 -- error chain for later output by Finalize. The messages are sorted
1131 -- first by unit (main unit comes first), and within a unit by source
1132 -- location (earlier flag location first in the chain).
1134 else
1139 exit when
1144 then
1152 -- Now we insert the new message in the error chain. The insertion
1153 -- point for the message is after Prev_Msg and before Next_Msg.
1155 -- The possible insertion point for the new message is after Prev_Msg
1156 -- and before Next_Msg. However, this is where we do a special check
1157 -- for redundant parsing messages, defined as messages posted on the
1158 -- same line. The idea here is that probably such messages are junk
1159 -- from the parser recovering. In full errors mode, we don't do this
1160 -- deletion, but otherwise such messages are discarded at this stage.
1168 and then not All_Errors_Mode
1169 then
1170 -- Don't delete unconditional messages and at this stage,
1171 -- don't delete continuation lines (we attempted to delete
1172 -- those earlier if the parent message was deleted.
1175 and then not Continuation
1176 then
1178 -- Don't delete if prev msg is warning and new msg is
1179 -- an error. This is because we don't want a real error
1180 -- masked by a warning. In all other cases (that is parse
1181 -- errors for the same line that are not unconditional)
1182 -- we do delete the message. This helps to avoid
1183 -- junk extra messages from cascaded parsing errors
1187 then
1188 -- All tests passed, delete the message by simply
1189 -- returning without any further processing.
1200 -- Come here if message is to be inserted in the error chain
1208 else
1215 -- Bump appropriate statistics count
1219 else
1224 Handle_Serious_Error;
1228 -- Terminate if max errors reached
1236 -----------------
1237 -- Error_Msg_N --
1238 -----------------
1241 begin
1245 ------------------
1246 -- Error_Msg_NE --
1247 ------------------
1249 procedure Error_Msg_NE
1253 is
1254 begin
1258 -------------------
1259 -- Error_Msg_NEL --
1260 -------------------
1262 procedure Error_Msg_NEL
1267 is
1268 begin
1281 if All_Errors_Mode
1285 then
1290 else
1299 -----------------
1300 -- Error_Msg_S --
1301 -----------------
1304 begin
1308 ------------------
1309 -- Error_Msg_SC --
1310 ------------------
1313 begin
1314 -- If we are at end of file, post the flag after the previous token
1319 -- For all other cases the message is posted at the current token
1320 -- pointer position
1322 else
1327 ------------------
1328 -- Error_Msg_SP --
1329 ------------------
1332 begin
1333 -- Note: in the case where there is no previous token, Prev_Token_Ptr
1334 -- is set to Source_First, which is a reasonable position for the
1335 -- error flag in this situation
1340 --------------
1341 -- Finalize --
1342 --------------
1350 begin
1351 -- Reset current error source file if the main unit has a pragma
1352 -- Source_Reference. This ensures outputting the proper name of
1353 -- the source file in this situation.
1359 -- Eliminate any duplicated error messages from the list. This is
1360 -- done after the fact to avoid problems with Change_Error_Text.
1369 loop
1377 -- Brief Error mode
1381 Set_Standard_Error;
1399 Write_Eol;
1405 Set_Standard_Output;
1408 -- Full source listing case
1414 Write_Eol;
1416 -- First list initial main source file with its error messages
1419 Err_Flag :=
1420 E /= No_Error_Msg
1430 Write_Eol;
1436 -- Then output errors, if any, for subsidiary units
1440 loop
1441 Write_Eol;
1442 Output_Source_Line
1448 -- Verbose mode (error lines only with error flags)
1453 -- Loop through error lines
1456 Write_Eol;
1457 Output_Source_Line
1463 -- Output error summary if verbose or full list mode
1467 -- Extra blank line if error messages or source listing were output
1470 or else Full_List
1471 then
1472 Write_Eol;
1475 -- Message giving number of lines read and number of errors detected.
1476 -- This normally goes to Standard_Output. The exception is when brief
1477 -- mode is not set, verbose mode (or full list mode) is set, and
1478 -- there are errors. In this case we send the message to standard
1479 -- error to make sure that *something* appears on standard error in
1480 -- an error situation.
1482 -- Formerly, only the "# errors" suffix was sent to stderr, whereas
1483 -- "# lines:" appeared on stdout. This caused problems on VMS when
1484 -- the stdout buffer was flushed, giving an extra line feed after
1485 -- the prefix.
1488 and then not Brief_Output
1490 then
1491 Set_Standard_Error;
1494 -- Message giving total number of lines
1501 else
1511 else
1536 Write_Eol;
1537 Set_Standard_Output;
1542 then
1543 Set_Standard_Error;
1545 Write_Eol;
1546 Set_Standard_Output;
1556 ------------------
1557 -- Get_Location --
1558 ------------------
1561 begin
1565 ----------------
1566 -- Get_Msg_Id --
1567 ----------------
1570 begin
1574 ----------------
1575 -- Initialize --
1576 ----------------
1579 begin
1588 -- Initialize warnings table, if all warnings are suppressed, supply
1589 -- an initial dummy entry covering all possible source locations.
1601 -----------------
1602 -- No_Warnings --
1603 -----------------
1606 begin
1616 then
1619 else
1624 -------------
1625 -- OK_Node --
1626 -------------
1631 begin
1638 then
1649 then
1651 else
1656 -----------------------
1657 -- Output_Error_Msgs --
1658 -----------------------
1668 begin
1671 -- Skip deleted messages at start
1677 -- Figure out if we will place more than one error flag on this line
1683 loop
1691 -- Output the error flags. The circuit here makes sure that the tab
1692 -- characters in the original line are properly accounted for. The
1693 -- eight blanks at the start are to match the line number.
1700 -- Loop through error messages for this line to place flags
1706 loop
1707 -- Loop to output blanks till current flag position
1712 else
1719 -- Output flag (unless already output, this happens if more
1720 -- than one error message occurs at the same flag position).
1725 then
1727 else
1738 Write_Eol;
1741 -- Now output the error messages
1748 loop
1760 Write_Eol;
1767 ------------------------
1768 -- Output_Line_Number --
1769 ------------------------
1777 begin
1781 else
1794 else
1797 else
1809 ---------------------
1810 -- Output_Msg_Text --
1811 ---------------------
1814 begin
1818 then
1829 ------------------------
1830 -- Output_Source_Line --
1831 ------------------------
1833 procedure Output_Source_Line
1837 is
1842 -- Set True once line number is output
1844 begin
1848 Write_Eol;
1854 -- Write starting line, except do not write it if we had more
1855 -- than one source reference pragma, since in this case there
1856 -- is no very useful number to write.
1861 Write_Eol;
1874 loop
1878 -- Deal with matching entry in List_Pragmas table
1880 if Full_List
1883 then
1888 -- Ignore if on line with errors so that error flags
1889 -- get properly listed with the error line .
1912 -- Normal case (no matching entry in List_Pragmas table)
1914 else
1924 Write_Eol;
1928 --------------------
1929 -- Purge_Messages --
1930 --------------------
1936 -- Returns True for a message that is to be purged. Also adjusts
1937 -- error counts appropriately.
1940 begin
1944 then
1947 else
1957 else
1962 -- Start of processing for Purge_Messages
1964 begin
1980 -----------------------------
1981 -- Remove_Warning_Messages --
1982 -----------------------------
1987 -- This function checks one node for a possible warning message.
1991 -- This defines the traversal operation
1993 -----------------------
1994 -- Check_For_Warning --
1995 -----------------------
2002 -- Returns True for a message that is to be removed. Also adjusts
2003 -- warning count appropriately.
2005 -------------------
2006 -- To_Be_Removed --
2007 -------------------
2010 begin
2014 then
2017 else
2022 -- Start of processing for Check_For_Warnings
2024 begin
2042 then
2043 -- Warnings may have been posted on subexpressions of
2044 -- the original tree. We place the original node back
2045 -- on the tree to remove those warnings, whose sloc
2046 -- do not match those of any node in the current tree.
2047 -- Given that we are in unreachable code, this modification
2048 -- to the tree is harmless.
2050 declare
2053 begin
2057 else
2065 else
2070 -- Start of processing for Remove_Warning_Messages
2072 begin
2074 declare
2076 begin
2082 ----------------
2083 -- Same_Error --
2084 ----------------
2093 begin
2094 return
2096 or else
2098 and then
2100 and then
2102 or else
2104 and then
2106 and then
2110 -------------------
2111 -- Set_Msg_Blank --
2112 -------------------
2115 begin
2119 and then not Manual_Quote_Mode
2120 then
2125 -------------------------------
2126 -- Set_Msg_Blank_Conditional --
2127 -------------------------------
2130 begin
2135 and then not Manual_Quote_Mode
2136 then
2141 ------------------
2142 -- Set_Msg_Char --
2143 ------------------
2146 begin
2148 -- The check for message buffer overflow is needed to deal with cases
2149 -- where insertions get too long (in particular a child unit name can
2150 -- be very long).
2158 ------------------------------
2159 -- Set_Msg_Insertion_Column --
2160 ------------------------------
2163 begin
2170 ---------------------------------
2171 -- Set_Msg_Insertion_File_Name --
2172 ---------------------------------
2175 begin
2180 Set_Msg_Blank;
2183 else
2184 Set_Msg_Blank;
2186 Set_Msg_Quote;
2187 Set_Msg_Name_Buffer;
2188 Set_Msg_Quote;
2191 -- The following assignments ensure that the second and third percent
2192 -- insertion characters will correspond to the Error_Msg_Name_2 and
2193 -- Error_Msg_Name_3 as required.
2200 -----------------------------------
2201 -- Set_Msg_Insertion_Line_Number --
2202 -----------------------------------
2208 begin
2209 Set_Msg_Blank;
2221 else
2222 -- Add "at file-name:" if reference is to other than the source
2223 -- file in which the error message is placed. Note that we check
2224 -- full file names, rather than just the source indexes, to
2225 -- deal with generic instantiations from the current file.
2232 Get_Name_String
2234 Set_Msg_Name_Buffer;
2237 -- If in current file, add text "at line "
2239 else
2243 -- Output line number for reference
2247 -- Deal with the instantiation case. We may have a reference to,
2248 -- e.g. a type, that is declared within a generic template, and
2249 -- what we are really referring to is the occurrence in an instance.
2250 -- In this case, the line number of the instantiation is also of
2251 -- interest, and we add a notation:
2253 -- , instance at xxx
2255 -- where xxx is a line number output using this same routine (and
2256 -- the recursion can go further if the instantiation is itself in
2257 -- a generic template).
2259 -- The flag location passed to us in this situation is indeed the
2260 -- line number within the template, but as described in Sinput.L
2261 -- (file sinput-l.ads, section "Handling Generic Instantiations")
2262 -- we can retrieve the location of the instantiation itself from
2263 -- this flag location value.
2265 -- Note: this processing is suppressed if Suppress_Instance_Location
2266 -- is set True. This is used to prevent redundant annotations of the
2267 -- location of the instantiation in the case where we are placing
2268 -- the messages on the instantiation in any case.
2271 and then not Suppress_Instance_Location
2272 then
2279 ----------------------------
2280 -- Set_Msg_Insertion_Name --
2281 ----------------------------
2284 begin
2289 Set_Msg_Blank;
2292 else
2293 Set_Msg_Blank_Conditional;
2296 -- Remove %s or %b at end. These come from unit names. If the
2297 -- caller wanted the (unit) or (body), then they would have used
2298 -- the $ insertion character. Certainly no error message should
2299 -- ever have %b or %s explicitly occurring.
2304 or else
2306 then
2310 -- Remove upper case letter at end, again, we should not be getting
2311 -- such names, and what we hope is that the remainder makes sense.
2315 then
2319 -- If operator name or character literal name, just print it as is
2320 -- Also print as is if it ends in a right paren (case of x'val(nnn))
2325 then
2326 Set_Msg_Name_Buffer;
2328 -- Else output with surrounding quotes in proper casing mode
2330 else
2332 Set_Msg_Quote;
2333 Set_Msg_Name_Buffer;
2334 Set_Msg_Quote;
2338 -- The following assignments ensure that the second and third percent
2339 -- insertion characters will correspond to the Error_Msg_Name_2 and
2340 -- Error_Msg_Name_3 as required.
2347 ----------------------------
2348 -- Set_Msg_Insertion_Node --
2349 ----------------------------
2352 begin
2353 Suppress_Message :=
2354 Error_Msg_Node_1 = Error
2358 Set_Msg_Blank_Conditional;
2362 Set_Msg_Blank;
2366 Set_Msg_Blank;
2369 else
2370 Set_Msg_Blank_Conditional;
2372 -- Skip quotes for operator case
2377 else
2378 Set_Msg_Quote;
2381 Set_Msg_Quote;
2385 -- The following assignment ensures that a second ampersand insertion
2386 -- character will correspond to the Error_Msg_Node_2 parameter.
2392 -------------------------------------
2393 -- Set_Msg_Insertion_Reserved_Name --
2394 -------------------------------------
2397 begin
2398 Set_Msg_Blank_Conditional;
2400 Set_Msg_Quote;
2402 Set_Msg_Name_Buffer;
2403 Set_Msg_Quote;
2406 -------------------------------------
2407 -- Set_Msg_Insertion_Reserved_Word --
2408 -------------------------------------
2410 procedure Set_Msg_Insertion_Reserved_Word
2413 is
2414 begin
2415 Set_Msg_Blank_Conditional;
2425 Set_Msg_Quote;
2426 Set_Msg_Name_Buffer;
2427 Set_Msg_Quote;
2430 --------------------------------------
2431 -- Set_Msg_Insertion_Type_Reference --
2432 --------------------------------------
2437 begin
2438 Set_Msg_Blank;
2461 then
2463 Set_Msg_Name_Buffer;
2479 -- Special case of anonymous array
2484 then
2488 Set_Msg_Insertion_Line_Number
2493 -- If we fall through, it is not a special case, so first output
2494 -- the name of the type, preceded by private for a private type
2498 else
2508 -- Types in Standard are displayed as "Standard.name"
2511 Set_Msg_Quote;
2514 Add_Class;
2515 Set_Msg_Quote;
2517 -- Types in other language defined units are displayed as
2518 -- "package-name.type-name"
2520 elsif
2522 then
2523 Get_Unqualified_Decoded_Name_String
2526 Set_Msg_Quote;
2528 Set_Msg_Name_Buffer;
2532 Add_Class;
2533 Set_Msg_Quote;
2535 -- All other types display as "type name" defined at line xxx
2536 -- possibly qualified if qualification is requested.
2538 else
2539 Set_Msg_Quote;
2542 Add_Class;
2543 Set_Msg_Quote;
2546 -- If the original type did not come from a predefined
2547 -- file, add the location where the type was defined.
2550 and then
2551 not Is_Predefined_File_Name
2553 then
2557 -- If it did come from a predefined file, deal with the case where
2558 -- this was a file with a generic instantiation from elsewhere.
2560 else
2562 declare
2566 begin
2568 and then not Suppress_Instance_Location
2569 then
2579 ----------------------------
2580 -- Set_Msg_Insertion_Uint --
2581 ----------------------------
2584 begin
2585 Set_Msg_Blank;
2592 -- The following assignment ensures that a second carret insertion
2593 -- character will correspond to the Error_Msg_Uint_2 parameter.
2598 ---------------------------------
2599 -- Set_Msg_Insertion_Unit_Name --
2600 ---------------------------------
2603 begin
2608 Set_Msg_Blank;
2611 else
2613 Set_Msg_Blank;
2614 Set_Msg_Quote;
2615 Set_Msg_Name_Buffer;
2616 Set_Msg_Quote;
2619 -- The following assignment ensures that a second percent insertion
2620 -- character will correspond to the Error_Msg_Unit_2 parameter.
2626 -----------------
2627 -- Set_Msg_Int --
2628 -----------------
2631 begin
2639 -------------------------
2640 -- Set_Msg_Name_Buffer --
2641 -------------------------
2644 begin
2650 ------------------
2651 -- Set_Msg_Node --
2652 ------------------
2658 begin
2678 -- The only remaining possibilities are identifiers, defining
2679 -- identifiers, pragmas, and pragma argument associations, i.e.
2680 -- nodes that have a Chars field.
2682 -- Internal names generally represent something gone wrong. An exception
2683 -- is the case of internal type names, where we try to find a reasonable
2684 -- external representation for the external name
2687 and then
2691 or else
2693 then
2696 else
2703 else
2707 -- At this stage, the name to output is in Nam
2711 -- Remove trailing upper case letters from the name (useful for
2712 -- dealing with some cases of internal names.
2718 -- If we have any of the names from standard that start with the
2719 -- characters "any " (e.g. Any_Type), then kill the message since
2720 -- almost certainly it is a junk cascaded message.
2724 then
2728 -- Now we have to set the proper case. If we have a source location
2729 -- then do a check to see if the name in the source is the same name
2730 -- as the name in the Names table, except for possible differences
2731 -- in case, which is the case when we can copy from the source.
2733 declare
2739 begin
2743 -- Determine if the reference we are dealing with corresponds
2744 -- to text at the point of the error reference. This will often
2745 -- be the case for simple identifier references, and is the case
2746 -- where we can copy the spelling from the source.
2750 then
2754 exit when
2762 -- If we get through the loop without a mismatch, then output
2763 -- the name the way it is spelled in the source program
2773 -- Otherwise set the casing using the default identifier casing
2775 else
2780 Set_Msg_Name_Buffer;
2781 Add_Class;
2783 -- Add 'Class if class wide type
2789 Set_Msg_Name_Buffer;
2793 -------------------
2794 -- Set_Msg_Quote --
2795 -------------------
2798 begin
2804 -----------------
2805 -- Set_Msg_Str --
2806 -----------------
2809 begin
2815 ------------------
2816 -- Set_Msg_Text --
2817 ------------------
2823 begin
2834 -- Check for insertion character
2837 Set_Msg_Insertion_Name;
2840 Set_Msg_Insertion_Unit_Name;
2843 Set_Msg_Insertion_File_Name;
2849 Set_Msg_Insertion_Reserved_Name;
2852 Set_Msg_Insertion_Node;
2861 Set_Msg_Insertion_Column;
2864 Set_Msg_Insertion_Uint;
2883 -- Upper case letter (start of reserved word if 2 or more)
2888 then
2892 -- Normal character with no special treatment
2894 else
2901 ------------------------------
2902 -- Set_Next_Non_Deleted_Msg --
2903 ------------------------------
2906 begin
2910 else
2911 loop
2918 ----------------
2919 -- Set_Posted --
2920 ----------------
2925 begin
2926 -- We always set Error_Posted on the node itself
2930 -- If it is a subexpression, then set Error_Posted on parents
2931 -- up to and including the first non-subexpression construct. This
2932 -- helps avoid cascaded error messages within a single expression.
2935 loop
2942 -- A special check, if we just posted an error on an attribute
2943 -- definition clause, then also set the entity involved as posted.
2944 -- For example, this stops complaining about the alignment after
2945 -- complaining about the size, which is likely to be useless.
2954 -----------------------
2955 -- Set_Qualification --
2956 -----------------------
2959 begin
2967 ---------------------------
2968 -- Set_Warnings_Mode_Off --
2969 ---------------------------
2972 begin
2973 -- Don't bother with entries from instantiation copies, since we
2974 -- will already have a copy in the template, which is what matters
2980 -- If last entry in table already covers us, this is a redundant
2981 -- pragma Warnings (Off) and can be ignored. This also handles the
2982 -- case where all warnings are suppressed by command line switch.
2987 then
2990 -- Otherwise establish a new entry, extending from the location of
2991 -- the pragma to the end of the current source file. This ending
2992 -- point will be adjusted by a subsequent pragma Warnings (On).
2994 else
3002 --------------------------
3003 -- Set_Warnings_Mode_On --
3004 --------------------------
3007 begin
3008 -- Don't bother with entries from instantiation copies, since we
3009 -- will already have a copy in the template, which is what matters
3015 -- Nothing to do unless command line switch to suppress all warnings
3016 -- is off, and the last entry in the warnings table covers this
3017 -- pragma Warnings (On), in which case adjust the end point.
3023 then
3028 ------------------------
3029 -- Special_Msg_Delete --
3030 ------------------------
3032 function Special_Msg_Delete
3037 is
3038 begin
3039 -- Never delete messages in -gnatdO mode
3044 -- When an atomic object refers to a non-atomic type in the same
3045 -- scope, we implicitly make the type atomic. In the non-error
3046 -- case this is surely safe (and in fact prevents an error from
3047 -- occurring if the type is not atomic by default). But if the
3048 -- object cannot be made atomic, then we introduce an extra junk
3049 -- message by this manipulation, which we get rid of here.
3051 -- We identify this case by the fact that it references a type for
3052 -- which Is_Atomic is set, but there is no Atomic pragma setting it.
3058 then
3061 -- When a size is wrong for a frozen type there is no explicit
3062 -- size clause, and other errors have occurred, suppress the
3063 -- message, since it is likely that this size error is a cascaded
3064 -- result of other errors. The reason we eliminate unfrozen types
3065 -- is that messages issued before the freeze type are for sure OK.
3072 and then
3074 and then
3076 and then
3078 then
3081 -- All special tests complete, so go ahead with message
3083 else
3088 ------------------------------
3089 -- Test_Warning_Serious_Msg --
3090 ------------------------------
3093 begin
3098 else
3105 then
3110 then
3120 --------------------------
3121 -- Unwind_Internal_Type --
3122 --------------------------
3129 begin
3130 -- Undo placement of a quote, since we will put it back later
3138 -- The loop here deals with recursive types, we are trying to
3139 -- find a related entity that is not an implicit type. Note
3140 -- that the check with Old_Ent stops us from getting "stuck".
3141 -- Also, we don't output the "type derived from" message more
3142 -- than once in the case where we climb up multiple levels.
3144 loop
3147 -- Implicit access type, use directly designated type
3153 -- Classwide type
3159 -- Use base type if this is a subtype
3164 -- Avoid duplication "subtype of subtype of", and also replace
3165 -- "derived from subtype of" simply by "derived from"
3169 then
3175 -- If this is a base type with a first named subtype, use the
3176 -- first named subtype instead. This is not quite accurate in
3177 -- all cases, but it makes too much noise to be accurate and
3178 -- add 'Base in all cases. Note that we only do this is the
3179 -- first named subtype is not itself an internal name. This
3180 -- avoids the obvious loop (subtype->basetype->subtype) which
3181 -- would otherwise occur!)
3185 and then
3186 not Is_Internal_Name
3188 then
3191 -- Otherwise use root type
3193 else
3197 -- Test for "subtype of type derived from" which seems
3198 -- excessive and is replaced by simply "type derived from"
3202 -- Avoid duplication "type derived from type derived from"
3214 -- If we are stuck in a loop, get out and settle for the internal
3215 -- name after all. In this case we set to kill the message if it
3216 -- is not the first error message (we really try hard not to show
3217 -- the dirty laundry of the implementation to the poor user!)
3224 -- Get out if we finally found a non-internal name to use
3235 -------------------------
3236 -- Warnings_Suppressed --
3237 -------------------------
3240 begin
3244 then