| blob | e4576e64d50bc122b04dc90dce8144950ad71c04 |
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- E R R O U T --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision: 1.4 $
10 -- --
11 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- GNAT was originally developed by the GNAT team at New York University. --
25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
26 -- --
27 ------------------------------------------------------------------------------
29 -- Warning! Error messages can be generated during Gigi processing by direct
30 -- calls to error message routines, so it is essential that the processing
31 -- in this body be consistent with the requirements for the Gigi processing
32 -- environment, and that in particular, no disallowed table expansion is
33 -- 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 unconditional
79 -- A flag used to kill weird messages (e.g. those containing uninterpreted
80 -- implicit type references) if we have already seen at least one message
81 -- already. The idea is that we hope the weird message is a junk cascaded
82 -- message that should be suppressed.
85 -- Set True if the most recently posted non-continuation message was
86 -- killed. This is used to determine the processing of any continuation
87 -- messages that follow.
90 -- Index into List_Pragmas table
93 -- Starts True, gets set False by pragma List (Off), True by List (On)
96 -- Set True in manual quotation mode
99 -- Maximum length of error message. The addition of Max_Line_Length
100 -- ensures that two insertion tokens of maximum length can be accomodated.
103 -- Buffer used to prepare error messages
106 -- Number of characters currently stored in the message buffer
109 -- A flag used to suppress certain obviously redundant messages (i.e.
110 -- those referring to a node whose type is Any_Type). This suppression
111 -- is effective only if All_Errors_Mode is off.
114 -- Normally, if a # location in a message references a location within
115 -- a generic template, then a note is added giving the location of the
116 -- instantiation. If this variable is set True, then this note is not
117 -- output. This is used for internal processing for the case of an
118 -- illegal instantiation. See Error_Msg routine for further details.
120 -----------------------------------
121 -- Error Message Data Structures --
122 -----------------------------------
124 -- The error messages are stored as a linked list of error message objects
125 -- sorted into ascending order by the source location (Sloc). Each object
126 -- records the text of the message and its source location.
128 -- The following record type and table are used to represent error
129 -- messages, with one entry in the table being allocated for each message.
133 -- Text of error message, fully expanded with all insertions
136 -- Pointer to next message in error chain
139 -- Source table index of source file. In the case of an error that
140 -- refers to a template, always references the original template
141 -- not an instantiation copy.
144 -- Flag pointer. In the case of an error that refers to a template,
145 -- always references the original template, not an instantiation copy.
146 -- This value is the actual place in the source that the error message
147 -- will be posted.
150 -- Flag location used in the call to post the error. This is normally
151 -- the same as Sptr, except in the case of instantiations, where it
152 -- is the original flag location value. This may refer to an instance
153 -- when the actual message (and hence Sptr) references the template.
156 -- Line number for error message
159 -- Column number for error message
162 -- True if warning message (i.e. insertion character ? appeared)
165 -- True if unconditional message (i.e. insertion character ! appeared)
168 -- This is used for logical messages that are composed of multiple
169 -- individual messages. For messages that are not part of such a
170 -- group, or that are the first message in such a group. Msg_Cont
171 -- is set to False. For subsequent messages in a group, Msg_Cont
172 -- is set to True. This is used to make sure that such a group of
173 -- messages is either suppressed or retained as a group (e.g. in
174 -- the circuit that deletes identical messages).
177 -- If this flag is set, the message is not printed. This is used
178 -- in the circuit for deleting duplicate/redundant error messages.
190 -- The list of error messages
192 --------------------------
193 -- Warning Mode Control --
194 --------------------------
196 -- Pragma Warnings allows warnings to be turned off for a specified
197 -- region of code, and the following tabl is the data structure used
198 -- to keep track of these regions.
200 -- It contains pairs of source locations, the first being the start
201 -- location for a warnings off region, and the second being the end
202 -- location. When a pragma Warnings (Off) is encountered, a new entry
203 -- is established extending from the location of the pragma to the
204 -- end of the current source file. A subsequent pragma Warnings (On)
205 -- adjusts the end point of this entry appropriately.
207 -- If all warnings are suppressed by comamnd switch, then there is a
208 -- dummy entry (put there by Errout.Initialize) at the start of the
209 -- table which covers all possible Source_Ptr values. Note that the
210 -- source pointer values in this table always reference the original
211 -- template, not an instantiation copy, in the generic case.
226 -----------------------
227 -- Local Subprograms --
228 -----------------------
231 -- Add 'Class to buffer for class wide type case (Class_Flag set)
234 -- Tests if message buffer ends with given string preceded by a space
237 -- Removes given string from end of buffer if it is present
238 -- at end of buffer, and preceded by a space.
241 -- Called from Error_Msg_N and Error_Msg_NE to generate line of debug
242 -- output giving node number (of node N) if the debug X switch is set.
245 -- This function is passed the Id values of two error messages. If
246 -- either M1 or M2 is a continuation message, or is already deleted,
247 -- the call is ignored. Otherwise a check is made to see if M1 and M2
248 -- are duplicated or redundant. If so, the message to be deleted and
249 -- all its continuations are marked with the Deleted flag set to True.
251 procedure Error_Msg_Internal
255 -- This is like Error_Msg, except that Flag_Location is known not to be
256 -- a location within a instantiation of a generic template. The outer
257 -- level routine, Error_Msg, takes care of dealing with the generic case.
258 -- Msg_Cont is set True to indicate that the message is a continuation of
259 -- a previous message. This means that it must have the same Flag_Location
260 -- as the previous message.
263 -- Given a message id, move to next message id, but skip any deleted
264 -- messages, so that this results in E on output being the first non-
265 -- deleted message following the input value of E, or No_Error_Msg if
266 -- the input value of E was either already No_Error_Msg, or was the
267 -- last non-deleted message.
270 -- Determines if warnings should be suppressed for the given node
273 -- Determines if a node is an OK node to place an error message on (return
274 -- True) or if the error message should be suppressed (return False). A
275 -- message is suppressed if the node already has an error posted on it,
276 -- or if it refers to an Etype that has an error posted on it, or if
277 -- it references an Entity that has an error posted on it.
280 -- Output source line, error flag, and text of stored error message and
281 -- all subsequent messages for the same line and unit. On return E is
282 -- set to be one higher than the last message output.
285 -- Output a line number as six digits (with leading zeroes suppressed),
286 -- followed by a period and a blank (note that this is 8 characters which
287 -- means that tabs in the source line will not get messed up). Line numbers
288 -- that match or are less than the last Source_Reference pragma are listed
289 -- as all blanks, avoiding output of junk line numbers.
292 -- Outputs characters of text in the text of the error message E, excluding
293 -- any final exclamation point. Note that no end of line is output, the
294 -- caller is responsible for adding the end of line.
296 procedure Output_Source_Line
300 -- Outputs text of source line L, in file S, together with preceding line
301 -- number, as described above for Output_Line_Number. The Errs parameter
302 -- indicates if there are errors attached to the line, which forces
303 -- listing on, even in the presence of pragma List (Off).
306 -- See if two messages have the same text. Returns true if the text
307 -- of the two messages is identical, or if one of them is the same
308 -- as the other with an appended "instance at xxx" tag.
311 -- Sets a single blank in the message if the preceding character is a
312 -- non-blank character other than a left parenthesis. Has no effect if
313 -- manual quote mode is turned on.
316 -- Sets a single blank in the message if the preceding character is a
317 -- non-blank character other than a left parenthesis or quote. Has no
318 -- effect if manual quote mode is turned on.
321 -- Add a single character to the current message. This routine does not
322 -- check for special insertion characters (they are just treated as text
323 -- characters if they occur).
326 -- Handle column number insertion (@ insertion character)
329 -- Handle name insertion (% insertion character)
332 -- Handle line number insertion (# insertion character). Loc is the
333 -- location to be referenced, and Flag is the location at which the
334 -- flag is posted (used to determine whether to add "in file xxx")
337 -- Handle node (name from node) insertion (& insertion character)
340 -- Handle insertion of reserved word name (* insertion character).
342 procedure Set_Msg_Insertion_Reserved_Word
345 -- Handle reserved word insertion (upper case letters). The Text argument
346 -- is the current error message input text, and J is an index which on
347 -- entry points to the first character of the reserved word, and on exit
348 -- points past the last character of the reserved word.
351 -- Handle type reference (right brace insertion character). Flag is the
352 -- location of the flag, which is provided for the internal call to
353 -- Set_Msg_Insertion_Line_Number,
356 -- Handle Uint insertion (^ insertion character)
359 -- Handle unit name insertion ($ insertion character)
362 -- Handle file name insertion (left brace insertion character)
365 -- Set the decimal representation of the argument in the error message
366 -- buffer with no leading zeroes output.
369 -- Output name from Name_Buffer, with surrounding quotes unless manual
370 -- quotation mode is in effect.
373 -- Add the sequence of characters for the name associated with the
374 -- given node to the current message.
377 -- Set quote if in normal quote mode, nothing if in manual quote mode
380 -- Add a sequence of characters to the current message. This routine does
381 -- not check for special insertion characters (they are just treated as
382 -- text characters if they occur).
385 -- Add a sequence of characters to the current message. The characters may
386 -- be one of the special insertion characters (see documentation in spec).
387 -- Flag is the location at which the error is to be posted, which is used
388 -- to determine whether or not the # insertion needs a file name. The
389 -- variables Msg_Buffer, Msglen, Is_Warning_Msg, and Is_Unconditional_Msg
390 -- are set on return.
393 -- Sets the Error_Posted flag on the given node, and all its parents
394 -- that are subexpressions and then on the parent non-subexpression
395 -- construct that contains the original expression (this reduces the
396 -- number of cascaded messages)
399 -- Outputs up to N levels of qualification for the given entity. For
400 -- example, the entity A.B.C.D will output B.C. if N = 2.
403 -- Sets Is_Warning_Msg true if Msg is a warning message (contains a
404 -- question mark character), and False otherwise.
407 -- This procedure is given an entity id for an internal type, i.e.
408 -- a type with an internal name. It unwinds the type to try to get
409 -- to something reasonably printable, generating prefixes like
410 -- "subtype of", "access to", etc along the way in the buffer. The
411 -- value in Ent on return is the final name to be printed. Hopefully
412 -- this is not an internal name, but in some internal name cases, it
413 -- is an internal name, and has to be printed anyway (although in this
414 -- case the message has been killed if possible). The global variable
415 -- Class_Flag is set to True if the resulting entity should have
416 -- 'Class appended to its name (see Add_Class procedure), and is
417 -- otherwise unchanged.
420 -- Determines if given location is covered by a warnings off suppression
421 -- range in the warnings table (or is suppressed by compilation option,
422 -- which generates a warning range for the whole source file).
424 ---------------
425 -- Add_Class --
426 ---------------
429 begin
435 Set_Msg_Name_Buffer;
439 ----------------------
440 -- Buffer_Ends_With --
441 ----------------------
446 begin
447 return
448 Msglen > Len
453 -------------------
454 -- Buffer_Remove --
455 -------------------
458 begin
464 -----------------------
465 -- Change_Error_Text --
466 -----------------------
472 begin
476 -- If in immediate error message mode, output modified error message now
477 -- This is just a bit tricky, because we want to output just a single
478 -- message, and the messages we modified is already linked in. We solve
479 -- this by temporarily resetting its forward pointer to empty.
481 if Debug_Flag_OO then
482 Save_Next := Errors.Table (Error_Id).Next;
483 Errors.Table (Error_Id).Next := No_Error_Msg;
484 Write_Eol;
485 Output_Source_Line
486 (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);
487 Output_Error_Msgs (Err_Id);
488 Errors.Table (Error_Id).Next := Save_Next;
489 end if;
490 end Change_Error_Text;
492 -----------------------------
493 -- Check_Duplicate_Message --
494 -----------------------------
496 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
497 L1, L2 : Error_Msg_Id;
498 N1, N2 : Error_Msg_Id;
500 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
501 -- Called to delete message Delete, keeping message Keep. Marks
502 -- all messages of Delete with deleted flag set to True, and also
503 -- makes sure that for the error messages that are retained the
504 -- preferred message is the one retained (we prefer the shorter
505 -- one in the case where one has an Instance tag). Note that we
506 -- always know that Keep has at least as many continuations as
507 -- Delete (since we always delete the shorter sequence).
509 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
510 D, K : Error_Msg_Id;
512 begin
513 D := Delete;
514 K := Keep;
516 loop
517 Errors.Table (D).Deleted := True;
519 -- Adjust error message count
521 if Errors.Table (D).Warn then
522 Warnings_Detected := Warnings_Detected - 1;
523 else
524 Errors_Detected := Errors_Detected - 1;
525 end if;
527 -- Substitute shorter of the two error messages
529 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
530 Errors.Table (K).Text := Errors.Table (D).Text;
531 end if;
533 D := Errors.Table (D).Next;
534 K := Errors.Table (K).Next;
536 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
537 return;
538 end if;
539 end loop;
540 end Delete_Msg;
542 -- Start of processing for Check_Duplicate_Message
544 begin
545 -- Both messages must be non-continuation messages and not deleted
547 if Errors.Table (M1).Msg_Cont
548 or else Errors.Table (M2).Msg_Cont
549 or else Errors.Table (M1).Deleted
550 or else Errors.Table (M2).Deleted
551 then
552 return;
553 end if;
555 -- Definitely not equal if message text does not match
557 if not Same_Error (M1, M2) then
558 return;
559 end if;
561 -- Same text. See if all continuations are also identical
563 L1 := M1;
564 L2 := M2;
566 loop
567 N1 := Errors.Table (L1).Next;
568 N2 := Errors.Table (L2).Next;
570 -- If M1 continuations have run out, we delete M1, either the
571 -- messages have the same number of continuations, or M2 has
572 -- more and we prefer the one with more anyway.
574 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
575 Delete_Msg (M1, M2);
576 return;
578 -- If M2 continuatins have run out, we delete M2
580 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
581 Delete_Msg (M2, M1);
582 return;
584 -- Otherwise see if continuations are the same, if not, keep both
585 -- sequences, a curious case, but better to keep everything!
587 elsif not Same_Error (N1, N2) then
588 return;
590 -- If continuations are the same, continue scan
592 else
593 L1 := N1;
594 L2 := N2;
595 end if;
596 end loop;
597 end Check_Duplicate_Message;
599 ------------------------
600 -- Compilation_Errors --
601 ------------------------
603 function Compilation_Errors return Boolean is
604 begin
605 return Errors_Detected /= 0
606 or else (Warnings_Detected /= 0
607 and then Warning_Mode = Treat_As_Error);
608 end Compilation_Errors;
610 ------------------
611 -- Debug_Output --
612 ------------------
614 procedure Debug_Output (N : Node_Id) is
615 begin
616 if Debug_Flag_1 then
617 Write_Str ("*** following error message posted on node id = #");
618 Write_Int (Int (N));
619 Write_Str (" ***");
620 Write_Eol;
621 end if;
622 end Debug_Output;
624 ----------
625 -- dmsg --
626 ----------
628 procedure dmsg (Id : Error_Msg_Id) is
629 E : Error_Msg_Object renames Errors.Table (Id);
631 begin
632 w ("Dumping error message, Id = ", Int (Id));
633 w (" Text = ", E.Text.all);
634 w (" Next = ", Int (E.Next));
635 w (" Sfile = ", Int (E.Sfile));
637 Write_Str
638 (" Sptr = ");
639 Write_Location (E.Sptr);
640 Write_Eol;
642 Write_Str
643 (" Fptr = ");
644 Write_Location (E.Fptr);
645 Write_Eol;
647 w (" Line = ", Int (E.Line));
648 w (" Col = ", Int (E.Col));
649 w (" Warn = ", E.Warn);
650 w (" Uncond = ", E.Uncond);
651 w (" Msg_Cont = ", E.Msg_Cont);
652 w (" Deleted = ", E.Deleted);
654 Write_Eol;
655 end dmsg;
657 ---------------
658 -- Error_Msg --
659 ---------------
661 -- Error_Msg posts a flag at the given location, except that if the
662 -- Flag_Location points within a generic template and corresponds
663 -- to an instantiation of this generic template, then the actual
664 -- message will be posted on the generic instantiation, along with
665 -- additional messages referencing the generic declaration.
667 procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
668 Sindex : Source_File_Index;
669 -- Source index for flag location
671 Orig_Loc : Source_Ptr;
672 -- Original location of Flag_Location (i.e. location in original
673 -- template in instantiation case, otherwise unchanged).
675 begin
676 -- If we already have messages, and we are trying to place a message
677 -- at No_Location or in package Standard, then just ignore the attempt
678 -- since we assume that what is happening is some cascaded junk. Note
679 -- that this is safe in the sense that proceeding will surely bomb.
681 if Flag_Location < First_Source_Ptr
682 and then Errors_Detected > 0
683 then
684 return;
685 end if;
687 Sindex := Get_Source_File_Index (Flag_Location);
688 Test_Warning_Msg (Msg);
690 -- It is a fatal error to issue an error message when scanning from
691 -- the internal source buffer (see Sinput for further documentation)
693 pragma Assert (Source /= Internal_Source_Ptr);
695 -- Ignore warning message that is suppressed
697 Orig_Loc := Original_Location (Flag_Location);
699 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
700 return;
701 end if;
703 -- The idea at this stage is that we have two kinds of messages.
705 -- First, we have those that are to be placed as requested at
706 -- Flag_Location. This includes messages that have nothing to
707 -- do with generics, and also messages placed on generic templates
708 -- that reflect an error in the template itself. For such messages
709 -- we simply call Error_Msg_Internal to place the message in the
710 -- requested location.
712 if Instantiation (Sindex) = No_Location then
713 Error_Msg_Internal (Msg, Flag_Location, False);
714 return;
715 end if;
717 -- If we are trying to flag an error in an instantiation, we may have
718 -- a generic contract violation. What we generate in this case is:
720 -- instantiation error at ...
721 -- original error message
723 -- or
725 -- warning: in instantiation at
726 -- warning: original warning message
728 -- All these messages are posted at the location of the top level
729 -- instantiation. If there are nested instantiations, then the
730 -- instantiation error message can be repeated, pointing to each
731 -- of the relevant instantiations.
733 -- However, before we do this, we need to worry about the case where
734 -- indeed we are in an instantiation, but the message is a warning
735 -- message. In this case, it almost certainly a warning for the
736 -- template itself and so it is posted on the template. At least
737 -- this is the default mode, it can be cancelled (resulting the
738 -- warning being placed on the instance as in the error case) by
739 -- setting the global Warn_On_Instance True.
741 if (not Warn_On_Instance) and then Is_Warning_Msg then
742 Error_Msg_Internal (Msg, Flag_Location, False);
743 return;
744 end if;
746 -- Second, we need to worry about the case where there was a real error
747 -- in the template, and we are getting a repeat of this error in the
748 -- instantiation. We don't want to complain about the instantiation
749 -- in this case, since we have already flagged the template.
751 -- To deal with this case, just see if we have posted a message at
752 -- the template location already. If so, assume that the current
753 -- message is redundant. There could be cases in which this is not
754 -- a correct assumption, but it is not terrible to lose a message
755 -- about an incorrect instantiation given that we have already
756 -- flagged a message on the template.
758 for Err in Errors.First .. Errors.Last loop
759 if Errors.Table (Err).Sptr = Orig_Loc then
761 -- If the current message is a real error, as opposed to a
762 -- warning, then we don't want to let a warning on the
763 -- template inhibit a real error on the instantiation.
765 if Is_Warning_Msg
766 or else not Errors.Table (Err).Warn
767 then
768 return;
769 end if;
770 end if;
771 end loop;
773 -- OK, this is the case where we have an instantiation error, and
774 -- we need to generate the error on the instantiation, rather than
775 -- on the template. First, see if we have posted this exact error
776 -- before, and if so suppress it. It is not so easy to use the main
777 -- list of errors for this, since they have already been split up
778 -- according to the processing below. Consequently we use an auxiliary
779 -- data structure that just records these types of messages (it will
780 -- never have very many entries).
782 declare
783 Actual_Error_Loc : Source_Ptr;
784 -- Location of outer level instantiation in instantiation case, or
785 -- just a copy of Flag_Location in the normal case. This is the
786 -- location where all error messages will actually be posted.
788 Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
789 -- Save possible location set for caller's message. We need to
790 -- use Error_Msg_Sloc for the location of the instantiation error
791 -- but we have to preserve a possible original value.
793 X : Source_File_Index;
795 Msg_Cont_Status : Boolean;
796 -- Used to label continuation lines in instantiation case with
797 -- proper Msg_Cont status.
799 begin
800 -- Loop to find highest level instantiation, where all error
801 -- messages will be placed.
803 X := Sindex;
804 loop
805 Actual_Error_Loc := Instantiation (X);
806 X := Get_Source_File_Index (Actual_Error_Loc);
807 exit when Instantiation (X) = No_Location;
808 end loop;
810 -- Since we are generating the messages at the instantiation
811 -- point in any case, we do not want the references to the
812 -- bad lines in the instance to be annotated with the location
813 -- of the instantiation.
815 Suppress_Instance_Location := True;
816 Msg_Cont_Status := False;
818 -- Loop to generate instantiation messages
820 Error_Msg_Sloc := Flag_Location;
821 X := Get_Source_File_Index (Flag_Location);
823 while Instantiation (X) /= No_Location loop
825 -- Suppress instantiation message on continuation lines
828 if Is_Warning_Msg then
829 Error_Msg_Internal
830 ("?in instantiation #",
831 Actual_Error_Loc, Msg_Cont_Status);
833 else
834 Error_Msg_Internal
835 ("instantiation error #",
836 Actual_Error_Loc, Msg_Cont_Status);
837 end if;
838 end if;
840 Error_Msg_Sloc := Instantiation (X);
841 X := Get_Source_File_Index (Error_Msg_Sloc);
842 Msg_Cont_Status := True;
843 end loop;
845 Suppress_Instance_Location := False;
846 Error_Msg_Sloc := Save_Error_Msg_Sloc;
848 -- Here we output the original message on the outer instantiation
850 Error_Msg_Internal (Msg, Actual_Error_Loc, Msg_Cont_Status);
851 end;
852 end Error_Msg;
854 ------------------
855 -- Error_Msg_AP --
856 ------------------
858 procedure Error_Msg_AP (Msg : String) is
859 S1 : Source_Ptr;
860 C : Character;
862 begin
863 -- If we had saved the Scan_Ptr value after scanning the previous
864 -- token, then we would have exactly the right place for putting
865 -- the flag immediately at hand. However, that would add at least
866 -- two instructions to a Scan call *just* to service the possibility
867 -- of an Error_Msg_AP call. So instead we reconstruct that value.
869 -- We have two possibilities, start with Prev_Token_Ptr and skip over
870 -- the current token, which is made harder by the possibility that this
871 -- token may be in error, or start with Token_Ptr and work backwards.
872 -- We used to take the second approach, but it's hard because of
873 -- comments, and harder still because things that look like comments
874 -- can appear inside strings. So now we take the first approach.
876 -- Note: in the case where there is no previous token, Prev_Token_Ptr
877 -- is set to Source_First, which is a reasonable position for the
878 -- error flag in this situation.
880 S1 := Prev_Token_Ptr;
881 C := Source (S1);
883 -- If the previous token is a string literal, we need a special approach
884 -- since there may be white space inside the literal and we don't want
885 -- to stop on that white space.
887 if Prev_Token = Tok_String_Literal then
888 loop
889 S1 := S1 + 1;
891 if Source (S1) = C then
892 S1 := S1 + 1;
893 exit when Source (S1) /= C;
894 elsif Source (S1) in Line_Terminator then
895 exit;
896 end if;
897 end loop;
899 -- Character literal also needs special handling
901 elsif Prev_Token = Tok_Char_Literal then
902 S1 := S1 + 3;
904 -- Otherwise we search forward for the end of the current token, marked
905 -- by a line terminator, white space, a comment symbol or if we bump
906 -- into the following token (i.e. the current token)
908 else
909 while Source (S1) not in Line_Terminator
911 and then Source (S1) /= ASCII.HT
913 and then S1 /= Token_Ptr
914 loop
915 S1 := S1 + 1;
916 end loop;
917 end if;
919 -- S1 is now set to the location for the flag
921 Error_Msg (Msg, S1);
923 end Error_Msg_AP;
925 ------------------
926 -- Error_Msg_BC --
927 ------------------
929 procedure Error_Msg_BC (Msg : String) is
930 begin
931 -- If we are at end of file, post the flag after the previous token
933 if Token = Tok_EOF then
934 Error_Msg_AP (Msg);
936 -- If we are at start of file, post the flag at the current token
938 elsif Token_Ptr = Source_First (Current_Source_File) then
939 Error_Msg_SC (Msg);
941 -- If the character before the current token is a space or a horizontal
942 -- tab, then we place the flag on this character (in the case of a tab
943 -- we would really like to place it in the "last" character of the tab
944 -- space, but that it too much trouble to worry about).
947 or else Source (Token_Ptr - 1) = ASCII.HT
948 then
949 Error_Msg (Msg, Token_Ptr - 1);
951 -- If there is no space or tab before the current token, then there is
952 -- no room to place the flag before the token, so we place it on the
953 -- token instead (this happens for example at the start of a line).
955 else
956 Error_Msg (Msg, Token_Ptr);
957 end if;
958 end Error_Msg_BC;
960 ------------------------
961 -- Error_Msg_Internal --
962 ------------------------
964 procedure Error_Msg_Internal
965 (Msg : String;
966 Flag_Location : Source_Ptr;
967 Msg_Cont : Boolean)
968 is
969 Next_Msg : Error_Msg_Id;
970 -- Pointer to next message at insertion point
972 Prev_Msg : Error_Msg_Id;
973 -- Pointer to previous message at insertion point
975 Temp_Msg : Error_Msg_Id;
977 Orig_Loc : constant Source_Ptr := Original_Location (Flag_Location);
979 procedure Handle_Fatal_Error;
980 -- Internal procedure to do all error message handling other than
981 -- bumping the error count and arranging for the message to be output.
983 procedure Handle_Fatal_Error is
984 begin
985 -- Turn off code generation if not done already
987 if Operating_Mode = Generate_Code then
988 Operating_Mode := Check_Semantics;
989 Expander_Active := False;
990 end if;
992 -- Set the fatal error flag in the unit table unless we are
993 -- in Try_Semantics mode. This stops the semantics from being
994 -- performed if we find a parser error. This is skipped if we
995 -- are currently dealing with the configuration pragma file.
997 if not Try_Semantics
998 and then Current_Source_Unit /= No_Unit
999 then
1000 Set_Fatal_Error (Get_Source_Unit (Orig_Loc));
1001 end if;
1002 end Handle_Fatal_Error;
1004 -- Start of processing for Error_Msg_Internal
1006 begin
1007 if Raise_Exception_On_Error /= 0 then
1008 raise Error_Msg_Exception;
1009 end if;
1011 Continuation := Msg_Cont;
1012 Suppress_Message := False;
1013 Kill_Message := False;
1014 Set_Msg_Text (Msg, Orig_Loc);
1016 -- Kill continuation if parent message killed
1018 if Continuation and Last_Killed then
1019 return;
1020 end if;
1022 -- Return without doing anything if message is suppressed
1024 if Suppress_Message
1025 and not All_Errors_Mode
1027 then
1028 if not Continuation then
1029 Last_Killed := True;
1030 end if;
1032 return;
1033 end if;
1035 -- Return without doing anything if message is killed and this
1036 -- is not the first error message. The philosophy is that if we
1037 -- get a weird error message and we already have had a message,
1038 -- then we hope the weird message is a junk cascaded message
1040 if Kill_Message
1041 and then not All_Errors_Mode
1042 and then Errors_Detected /= 0
1043 then
1044 if not Continuation then
1045 Last_Killed := True;
1046 end if;
1048 return;
1049 end if;
1051 -- Immediate return if warning message and warnings are suppressed
1053 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
1054 Cur_Msg := No_Error_Msg;
1055 return;
1056 end if;
1058 -- If message is to be ignored in special ignore message mode, this is
1059 -- where we do this special processing, bypassing message output.
1061 if Ignore_Errors_Enable > 0 then
1062 Handle_Fatal_Error;
1063 return;
1064 end if;
1066 -- Otherwise build error message object for new message
1068 Errors.Increment_Last;
1069 Cur_Msg := Errors.Last;
1082 -- If immediate errors mode set, output error message now. Also output
1083 -- now if the -d1 debug flag is set (so node number message comes out
1084 -- just before actual error message)
1087 Write_Eol;
1093 -- If not in immediate errors mode, then we insert the message in the
1094 -- error chain for later output by Finalize. The messages are sorted
1095 -- first by unit (main unit comes first), and within a unit by source
1096 -- location (earlier flag location first in the chain).
1098 else
1103 exit when
1108 then
1116 -- Now we insert the new message in the error chain. The insertion
1117 -- point for the message is after Prev_Msg and before Next_Msg.
1119 -- The possible insertion point for the new message is after Prev_Msg
1120 -- and before Next_Msg. However, this is where we do a special check
1121 -- for redundant parsing messages, defined as messages posted on the
1122 -- same line. The idea here is that probably such messages are junk
1123 -- from the parser recovering. In full errors mode, we don't do this
1124 -- deletion, but otherwise such messages are discarded at this stage.
1132 and then not All_Errors_Mode
1133 then
1134 -- Don't delete unconditional messages and at this stage,
1135 -- don't delete continuation lines (we attempted to delete
1136 -- those earlier if the parent message was deleted.
1139 and then not Continuation
1140 then
1142 -- Don't delete if prev msg is warning and new msg is
1143 -- an error. This is because we don't want a real error
1144 -- masked by a warning. In all other cases (that is parse
1145 -- errors for the same line that are not unconditional)
1146 -- we do delete the message. This helps to avoid
1147 -- junk extra messages from cascaded parsing errors
1151 then
1152 -- All tests passed, delete the message by simply
1153 -- returning without any further processing.
1164 -- Come here if message is to be inserted in the error chain
1172 else
1179 -- Bump appropriate statistics count
1183 else
1185 Handle_Fatal_Error;
1188 -- Terminate if max errors reached
1196 -----------------
1197 -- Error_Msg_N --
1198 -----------------
1201 begin
1210 if All_Errors_Mode
1214 then
1219 else
1228 ------------------
1229 -- Error_Msg_NE --
1230 ------------------
1232 procedure Error_Msg_NE
1236 is
1237 begin
1246 if All_Errors_Mode
1250 then
1255 else
1264 -----------------
1265 -- Error_Msg_S --
1266 -----------------
1269 begin
1273 ------------------
1274 -- Error_Msg_SC --
1275 ------------------
1278 begin
1279 -- If we are at end of file, post the flag after the previous token
1284 -- For all other cases the message is posted at the current token
1285 -- pointer position
1287 else
1292 ------------------
1293 -- Error_Msg_SP --
1294 ------------------
1297 begin
1298 -- Note: in the case where there is no previous token, Prev_Token_Ptr
1299 -- is set to Source_First, which is a reasonable position for the
1300 -- error flag in this situation
1305 --------------
1306 -- Finalize --
1307 --------------
1315 begin
1316 -- Reset current error source file if the main unit has a pragma
1317 -- Source_Reference. This ensures outputting the proper name of
1318 -- the source file in this situation.
1324 -- Eliminate any duplicated error messages from the list. This is
1325 -- done after the fact to avoid problems with Change_Error_Text.
1334 loop
1342 -- Brief Error mode
1346 Set_Standard_Error;
1364 Write_Eol;
1370 Set_Standard_Output;
1373 -- Full source listing case
1379 Write_Eol;
1381 -- First list initial main source file with its error messages
1384 Err_Flag :=
1385 E /= No_Error_Msg
1395 Write_Eol;
1401 -- Then output errors, if any, for subsidiary units
1405 loop
1406 Write_Eol;
1407 Output_Source_Line
1413 -- Verbose mode (error lines only with error flags)
1418 -- Loop through error lines
1421 Write_Eol;
1422 Output_Source_Line
1428 -- Output error summary if verbose or full list mode
1432 -- Extra blank line if error messages or source listing were output
1435 Write_Eol;
1438 -- Message giving number of lines read and number of errors detected.
1439 -- This normally goes to Standard_Output. The exception is when brief
1440 -- mode is not set, verbose mode (or full list mode) is set, and
1441 -- there are errors. In this case we send the message to standard
1442 -- error to make sure that *something* appears on standard error in
1443 -- an error situation.
1445 -- Formerly, only the "# errors" suffix was sent to stderr, whereas
1446 -- "# lines:" appeared on stdout. This caused problems on VMS when
1447 -- the stdout buffer was flushed, giving an extra line feed after
1448 -- the prefix.
1451 and then not Brief_Output
1453 then
1454 Set_Standard_Error;
1457 -- Message giving total number of lines
1464 else
1474 else
1499 Write_Eol;
1500 Set_Standard_Output;
1505 then
1506 Set_Standard_Error;
1508 Write_Eol;
1509 Set_Standard_Output;
1519 ------------------
1520 -- Get_Location --
1521 ------------------
1524 begin
1528 ----------------
1529 -- Get_Msg_Id --
1530 ----------------
1533 begin
1537 ----------------
1538 -- Initialize --
1539 ----------------
1542 begin
1550 -- Initialize warnings table, if all warnings are suppressed, supply
1551 -- an initial dummy entry covering all possible source locations.
1563 -----------------
1564 -- No_Warnings --
1565 -----------------
1568 begin
1578 then
1581 else
1586 -------------
1587 -- OK_Node --
1588 -------------
1593 begin
1600 then
1611 then
1613 else
1618 -----------------------
1619 -- Output_Error_Msgs --
1620 -----------------------
1630 begin
1633 -- Skip deleted messages at start
1639 -- Figure out if we will place more than one error flag on this line
1645 loop
1653 -- Output the error flags. The circuit here makes sure that the tab
1654 -- characters in the original line are properly accounted for. The
1655 -- eight blanks at the start are to match the line number.
1662 -- Loop through error messages for this line to place flags
1668 loop
1669 -- Loop to output blanks till current flag position
1674 else
1681 -- Output flag (unless already output, this happens if more
1682 -- than one error message occurs at the same flag position).
1687 then
1689 else
1700 Write_Eol;
1703 -- Now output the error messages
1710 loop
1722 Write_Eol;
1729 ------------------------
1730 -- Output_Line_Number --
1731 ------------------------
1739 begin
1743 else
1756 else
1759 else
1771 ---------------------
1772 -- Output_Msg_Text --
1773 ---------------------
1776 begin
1780 then
1791 ------------------------
1792 -- Output_Source_Line --
1793 ------------------------
1795 procedure Output_Source_Line
1799 is
1804 -- Set True once line number is output
1806 begin
1810 Write_Eol;
1816 -- Write starting line, except do not write it if we had more
1817 -- than one source reference pragma, since in this case there
1818 -- is no very useful number to write.
1823 Write_Eol;
1836 loop
1840 -- Deal with matching entry in List_Pragmas table
1842 if Full_List
1845 then
1850 -- Ignore if on line with errors so that error flags
1851 -- get properly listed with the error line .
1874 -- Normal case (no matching entry in List_Pragmas table)
1876 else
1886 Write_Eol;
1890 --------------------
1891 -- Purge_Messages --
1892 --------------------
1898 -- Returns True for a message that is to be purged. Also adjusts
1899 -- error counts appropriately.
1902 begin
1906 then
1909 else
1915 else
1920 -- Start of processing for Purge_Messages
1922 begin
1938 -----------------------------
1939 -- Remove_Warning_Messages --
1940 -----------------------------
1945 -- This function checks one node for a possible warning message.
1949 -- This defines the traversal operation
1951 -----------------------
1952 -- Check_For_Warning --
1953 -----------------------
1960 -- Returns True for a message that is to be removed. Also adjusts
1961 -- warning count appropriately.
1963 -------------------
1964 -- To_Be_Removed --
1965 -------------------
1968 begin
1972 then
1975 else
1980 -- Start of processing for Check_For_Warnings
1982 begin
1999 then
2000 -- Warnings may have been posted on subexpressions of
2001 -- the original tree. We temporarily replace the raise
2002 -- statement with the original expression to remove
2003 -- those warnings, whose sloc do not match those of
2004 -- any node in the current tree.
2006 declare
2010 begin
2017 else
2022 -- Start of processing for Remove_Warning_Messages
2024 begin
2026 declare
2028 begin
2034 ----------------
2035 -- Same_Error --
2036 ----------------
2045 begin
2046 return
2048 or else
2050 and then
2052 and then
2054 or else
2056 and then
2058 and then
2062 -------------------
2063 -- Set_Msg_Blank --
2064 -------------------
2067 begin
2071 and then not Manual_Quote_Mode
2072 then
2077 -------------------------------
2078 -- Set_Msg_Blank_Conditional --
2079 -------------------------------
2082 begin
2087 and then not Manual_Quote_Mode
2088 then
2093 ------------------
2094 -- Set_Msg_Char --
2095 ------------------
2098 begin
2100 -- The check for message buffer overflow is needed to deal with cases
2101 -- where insertions get too long (in particular a child unit name can
2102 -- be very long).
2110 ------------------------------
2111 -- Set_Msg_Insertion_Column --
2112 ------------------------------
2115 begin
2122 ---------------------------------
2123 -- Set_Msg_Insertion_File_Name --
2124 ---------------------------------
2127 begin
2132 Set_Msg_Blank;
2135 else
2136 Set_Msg_Blank;
2138 Set_Msg_Quote;
2139 Set_Msg_Name_Buffer;
2140 Set_Msg_Quote;
2143 -- The following assignments ensure that the second and third percent
2144 -- insertion characters will correspond to the Error_Msg_Name_2 and
2145 -- Error_Msg_Name_3 as required.
2152 -----------------------------------
2153 -- Set_Msg_Insertion_Line_Number --
2154 -----------------------------------
2160 begin
2161 Set_Msg_Blank;
2173 else
2174 -- Add "at file-name:" if reference is to other than the source
2175 -- file in which the error message is placed. Note that we check
2176 -- full file names, rather than just the source indexes, to
2177 -- deal with generic instantiations from the current file.
2184 Get_Name_String
2186 Set_Msg_Name_Buffer;
2189 -- If in current file, add text "at line "
2191 else
2195 -- Output line number for reference
2199 -- Deal with the instantiation case. We may have a reference to,
2200 -- e.g. a type, that is declared within a generic template, and
2201 -- what we are really referring to is the occurrence in an instance.
2202 -- In this case, the line number of the instantiation is also of
2203 -- interest, and we add a notation:
2205 -- , instance at xxx
2207 -- where xxx is a line number output using this same routine (and
2208 -- the recursion can go further if the instantiation is itself in
2209 -- a generic template).
2211 -- The flag location passed to us in this situation is indeed the
2212 -- line number within the template, but as described in Sinput.L
2213 -- (file sinput-l.ads, section "Handling Generic Instantiations")
2214 -- we can retrieve the location of the instantiation itself from
2215 -- this flag location value.
2217 -- Note: this processing is suppressed if Suppress_Instance_Location
2218 -- is set True. This is used to prevent redundant annotations of the
2219 -- location of the instantiation in the case where we are placing
2220 -- the messages on the instantiation in any case.
2223 and then not Suppress_Instance_Location
2224 then
2231 ----------------------------
2232 -- Set_Msg_Insertion_Name --
2233 ----------------------------
2236 begin
2241 Set_Msg_Blank;
2244 else
2245 Set_Msg_Blank_Conditional;
2248 -- Remove %s or %b at end. These come from unit names. If the
2249 -- caller wanted the (unit) or (body), then they would have used
2250 -- the $ insertion character. Certainly no error message should
2251 -- ever have %b or %s explicitly occurring.
2256 or else
2258 then
2262 -- Remove upper case letter at end, again, we should not be getting
2263 -- such names, and what we hope is that the remainder makes sense.
2267 then
2271 -- If operator name or character literal name, just print it as is
2272 -- Also print as is if it ends in a right paren (case of x'val(nnn))
2277 then
2278 Set_Msg_Name_Buffer;
2280 -- Else output with surrounding quotes in proper casing mode
2282 else
2284 Set_Msg_Quote;
2285 Set_Msg_Name_Buffer;
2286 Set_Msg_Quote;
2290 -- The following assignments ensure that the second and third percent
2291 -- insertion characters will correspond to the Error_Msg_Name_2 and
2292 -- Error_Msg_Name_3 as required.
2299 ----------------------------
2300 -- Set_Msg_Insertion_Node --
2301 ----------------------------
2304 begin
2305 Suppress_Message :=
2306 Error_Msg_Node_1 = Error
2310 Set_Msg_Blank_Conditional;
2314 Set_Msg_Blank;
2318 Set_Msg_Blank;
2321 else
2322 Set_Msg_Blank_Conditional;
2324 -- Skip quotes for operator case
2329 else
2330 Set_Msg_Quote;
2333 Set_Msg_Quote;
2337 -- The following assignment ensures that a second ampersand insertion
2338 -- character will correspond to the Error_Msg_Node_2 parameter.
2344 -------------------------------------
2345 -- Set_Msg_Insertion_Reserved_Name --
2346 -------------------------------------
2349 begin
2350 Set_Msg_Blank_Conditional;
2352 Set_Msg_Quote;
2354 Set_Msg_Name_Buffer;
2355 Set_Msg_Quote;
2358 -------------------------------------
2359 -- Set_Msg_Insertion_Reserved_Word --
2360 -------------------------------------
2362 procedure Set_Msg_Insertion_Reserved_Word
2365 is
2366 begin
2367 Set_Msg_Blank_Conditional;
2377 Set_Msg_Quote;
2378 Set_Msg_Name_Buffer;
2379 Set_Msg_Quote;
2382 --------------------------------------
2383 -- Set_Msg_Insertion_Type_Reference --
2384 --------------------------------------
2389 begin
2390 Set_Msg_Blank;
2413 then
2415 Set_Msg_Name_Buffer;
2431 -- Special case of anonymous array
2436 then
2440 Set_Msg_Insertion_Line_Number
2445 -- If we fall through, it is not a special case, so first output
2446 -- the name of the type, preceded by private for a private type
2450 else
2460 -- Types in Standard are displayed as "Standard.name"
2463 Set_Msg_Quote;
2466 Add_Class;
2467 Set_Msg_Quote;
2469 -- Types in other language defined units are displayed as
2470 -- "package-name.type-name"
2472 elsif
2474 then
2475 Get_Unqualified_Decoded_Name_String
2478 Set_Msg_Quote;
2480 Set_Msg_Name_Buffer;
2484 Add_Class;
2485 Set_Msg_Quote;
2487 -- All other types display as "type name" defined at line xxx
2488 -- possibly qualified if qualification is requested.
2490 else
2491 Set_Msg_Quote;
2494 Add_Class;
2495 Set_Msg_Quote;
2498 -- If the original type did not come from a predefined
2499 -- file, add the location where the type was defined.
2502 and then
2503 not Is_Predefined_File_Name
2505 then
2509 -- If it did come from a predefined file, deal with the case where
2510 -- this was a file with a generic instantiation from elsewhere.
2512 else
2514 declare
2518 begin
2520 and then not Suppress_Instance_Location
2521 then
2531 ----------------------------
2532 -- Set_Msg_Insertion_Uint --
2533 ----------------------------
2536 begin
2537 Set_Msg_Blank;
2544 -- The following assignment ensures that a second carret insertion
2545 -- character will correspond to the Error_Msg_Uint_2 parameter.
2550 ---------------------------------
2551 -- Set_Msg_Insertion_Unit_Name --
2552 ---------------------------------
2555 begin
2560 Set_Msg_Blank;
2563 else
2565 Set_Msg_Blank;
2566 Set_Msg_Quote;
2567 Set_Msg_Name_Buffer;
2568 Set_Msg_Quote;
2571 -- The following assignment ensures that a second percent insertion
2572 -- character will correspond to the Error_Msg_Unit_2 parameter.
2578 -----------------
2579 -- Set_Msg_Int --
2580 -----------------
2583 begin
2591 -------------------------
2592 -- Set_Msg_Name_Buffer --
2593 -------------------------
2596 begin
2602 ------------------
2603 -- Set_Msg_Node --
2604 ------------------
2610 begin
2630 -- The only remaining possibilities are identifiers, defining
2631 -- identifiers, pragmas, and pragma argument associations, i.e.
2632 -- nodes that have a Chars field.
2634 -- Internal names generally represent something gone wrong. An exception
2635 -- is the case of internal type names, where we try to find a reasonable
2636 -- external representation for the external name
2639 and then
2643 or else
2645 then
2648 else
2655 else
2659 -- At this stage, the name to output is in Nam
2663 -- Remove trailing upper case letters from the name (useful for
2664 -- dealing with some cases of internal names.
2670 -- If we have any of the names from standard that start with the
2671 -- characters "any " (e.g. Any_Type), then kill the message since
2672 -- almost certainly it is a junk cascaded message.
2676 then
2680 -- Now we have to set the proper case. If we have a source location
2681 -- then do a check to see if the name in the source is the same name
2682 -- as the name in the Names table, except for possible differences
2683 -- in case, which is the case when we can copy from the source.
2685 declare
2691 begin
2695 -- Determine if the reference we are dealing with corresponds
2696 -- to text at the point of the error reference. This will often
2697 -- be the case for simple identifier references, and is the case
2698 -- where we can copy the spelling from the source.
2702 then
2706 exit when
2714 -- If we get through the loop without a mismatch, then output
2715 -- the name the way it is spelled in the source program
2725 -- Otherwise set the casing using the default identifier casing
2727 else
2732 Set_Msg_Name_Buffer;
2733 Add_Class;
2735 -- Add 'Class if class wide type
2741 Set_Msg_Name_Buffer;
2745 -------------------
2746 -- Set_Msg_Quote --
2747 -------------------
2750 begin
2756 -----------------
2757 -- Set_Msg_Str --
2758 -----------------
2761 begin
2767 ------------------
2768 -- Set_Msg_Text --
2769 ------------------
2775 begin
2786 -- Check for insertion character
2789 Set_Msg_Insertion_Name;
2792 Set_Msg_Insertion_Unit_Name;
2795 Set_Msg_Insertion_File_Name;
2801 Set_Msg_Insertion_Reserved_Name;
2804 Set_Msg_Insertion_Node;
2813 Set_Msg_Insertion_Column;
2816 Set_Msg_Insertion_Uint;
2832 -- Upper case letter (start of reserved word if 2 or more)
2837 then
2841 -- Normal character with no special treatment
2843 else
2850 ------------------------------
2851 -- Set_Next_Non_Deleted_Msg --
2852 ------------------------------
2855 begin
2859 else
2860 loop
2867 ----------------
2868 -- Set_Posted --
2869 ----------------
2874 begin
2875 -- We always set Error_Posted on the node itself
2879 -- If it is a subexpression, then set Error_Posted on parents
2880 -- up to and including the first non-subexpression construct. This
2881 -- helps avoid cascaded error messages within a single expression.
2884 loop
2892 -----------------------
2893 -- Set_Qualification --
2894 -----------------------
2897 begin
2905 ---------------------------
2906 -- Set_Warnings_Mode_Off --
2907 ---------------------------
2910 begin
2911 -- Don't bother with entries from instantiation copies, since we
2912 -- will already have a copy in the template, which is what matters
2918 -- If last entry in table already covers us, this is a redundant
2919 -- pragma Warnings (Off) and can be ignored. This also handles the
2920 -- case where all warnings are suppressed by command line switch.
2925 then
2928 -- Otherwise establish a new entry, extending from the location of
2929 -- the pragma to the end of the current source file. This ending
2930 -- point will be adjusted by a subsequent pragma Warnings (On).
2932 else
2940 --------------------------
2941 -- Set_Warnings_Mode_On --
2942 --------------------------
2945 begin
2946 -- Don't bother with entries from instantiation copies, since we
2947 -- will already have a copy in the template, which is what matters
2953 -- Nothing to do unless command line switch to suppress all warnings
2954 -- is off, and the last entry in the warnings table covers this
2955 -- pragma Warnings (On), in which case adjust the end point.
2961 then
2966 ----------------------
2967 -- Test_Warning_Msg --
2968 ----------------------
2971 begin
2980 then
2989 --------------------------
2990 -- Unwind_Internal_Type --
2991 --------------------------
2998 begin
2999 -- Undo placement of a quote, since we will put it back later
3007 -- The loop here deals with recursive types, we are trying to
3008 -- find a related entity that is not an implicit type. Note
3009 -- that the check with Old_Ent stops us from getting "stuck".
3010 -- Also, we don't output the "type derived from" message more
3011 -- than once in the case where we climb up multiple levels.
3013 loop
3016 -- Implicit access type, use directly designated type
3022 -- Classwide type
3028 -- Use base type if this is a subtype
3033 -- Avoid duplication "subtype of subtype of", and also replace
3034 -- "derived from subtype of" simply by "derived from"
3038 then
3044 -- If this is a base type with a first named subtype, use the
3045 -- first named subtype instead. This is not quite accurate in
3046 -- all cases, but it makes too much noise to be accurate and
3047 -- add 'Base in all cases. Note that we only do this is the
3048 -- first named subtype is not itself an internal name. This
3049 -- avoids the obvious loop (subtype->basetype->subtype) which
3050 -- would otherwise occur!)
3054 and then
3055 not Is_Internal_Name
3057 then
3060 -- Otherwise use root type
3062 else
3066 -- Test for "subtype of type derived from" which seems
3067 -- excessive and is replaced by simply "type derived from"
3071 -- Avoid duplication "type derived from type derived from"
3083 -- If we are stuck in a loop, get out and settle for the internal
3084 -- name after all. In this case we set to kill the message if it
3085 -- is not the first error message (we really try hard not to show
3086 -- the dirty laundry of the implementation to the poor user!)
3093 -- Get out if we finally found a non-internal name to use
3104 -------------------------
3105 -- Warnings_Suppressed --
3106 -------------------------
3109 begin
3113 then