OSDN Git Service

2010-06-22 Robert Dewar <dewar@adacore.com>
[pf3gnuchains/gcc-fork.git] / gcc / ada / errout.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                               E R R O U T                                --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
10 --                                                                          --
11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
12 -- terms of the  GNU General Public License as published  by the Free Soft- --
13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17 -- for  more details.  You should have  received  a copy of the GNU General --
18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
20 --                                                                          --
21 -- GNAT was originally developed  by the GNAT team at  New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
23 --                                                                          --
24 ------------------------------------------------------------------------------
25
26 --  Warning! Error messages can be generated during Gigi processing by direct
27 --  calls to error message routines, so it is essential that the processing
28 --  in this body be consistent with the requirements for the Gigi processing
29 --  environment, and that in particular, no disallowed table expansion is
30 --  allowed to occur.
31
32 with Atree;    use Atree;
33 with Casing;   use Casing;
34 with Csets;    use Csets;
35 with Debug;    use Debug;
36 with Einfo;    use Einfo;
37 with Erroutc;  use Erroutc;
38 with Fname;    use Fname;
39 with Gnatvsn;  use Gnatvsn;
40 with Hostparm; use Hostparm;
41 with Lib;      use Lib;
42 with Opt;      use Opt;
43 with Nlists;   use Nlists;
44 with Output;   use Output;
45 with Scans;    use Scans;
46 with Sem_Aux;  use Sem_Aux;
47 with Sinput;   use Sinput;
48 with Sinfo;    use Sinfo;
49 with Snames;   use Snames;
50 with Stand;    use Stand;
51 with Stylesw;  use Stylesw;
52 with Uname;    use Uname;
53
54 package body Errout is
55
56    Errors_Must_Be_Ignored : Boolean := False;
57    --  Set to True by procedure Set_Ignore_Errors (True), when calls to error
58    --  message procedures should be ignored (when parsing irrelevant text in
59    --  sources being preprocessed).
60
61    Finalize_Called : Boolean := False;
62    --  Set True if the Finalize routine has been called
63
64    Warn_On_Instance : Boolean;
65    --  Flag set true for warning message to be posted on instance
66
67    ------------------------------------
68    -- Table of Non-Instance Messages --
69    ------------------------------------
70
71    --  This table contains an entry for every error message processed by the
72    --  Error_Msg routine that is not posted on generic (or inlined) instance.
73    --  As explained in further detail in the Error_Msg procedure body, this
74    --  table is used to avoid posting redundant messages on instances.
75
76    type NIM_Record is record
77       Msg : String_Ptr;
78       Loc : Source_Ptr;
79    end record;
80    --  Type used to store text and location of one message
81
82    package Non_Instance_Msgs is new Table.Table (
83      Table_Component_Type => NIM_Record,
84      Table_Index_Type     => Int,
85      Table_Low_Bound      => 1,
86      Table_Initial        => 100,
87      Table_Increment      => 100,
88      Table_Name           => "Non_Instance_Msgs");
89
90    -----------------------
91    -- Local Subprograms --
92    -----------------------
93
94    procedure Error_Msg_Internal
95      (Msg      : String;
96       Sptr     : Source_Ptr;
97       Optr     : Source_Ptr;
98       Msg_Cont : Boolean);
99    --  This is the low level routine used to post messages after dealing with
100    --  the issue of messages placed on instantiations (which get broken up
101    --  into separate calls in Error_Msg). Sptr is the location on which the
102    --  flag will be placed in the output. In the case where the flag is on
103    --  the template, this points directly to the template, not to one of the
104    --  instantiation copies of the template. Optr is the original location
105    --  used to flag the error, and this may indeed point to an instantiation
106    --  copy. So typically we can see Optr pointing to the template location
107    --  in an instantiation copy when Sptr points to the source location of
108    --  the actual instantiation (i.e the line with the new). Msg_Cont is
109    --  set true if this is a continuation message.
110
111    function No_Warnings (N : Node_Or_Entity_Id) return Boolean;
112    --  Determines if warnings should be suppressed for the given node
113
114    function OK_Node (N : Node_Id) return Boolean;
115    --  Determines if a node is an OK node to place an error message on (return
116    --  True) or if the error message should be suppressed (return False). A
117    --  message is suppressed if the node already has an error posted on it,
118    --  or if it refers to an Etype that has an error posted on it, or if
119    --  it references an Entity that has an error posted on it.
120
121    procedure Output_Source_Line
122      (L     : Physical_Line_Number;
123       Sfile : Source_File_Index;
124       Errs  : Boolean);
125    --  Outputs text of source line L, in file S, together with preceding line
126    --  number, as described above for Output_Line_Number. The Errs parameter
127    --  indicates if there are errors attached to the line, which forces
128    --  listing on, even in the presence of pragma List (Off).
129
130    procedure Set_Msg_Insertion_Column;
131    --  Handle column number insertion (@ insertion character)
132
133    procedure Set_Msg_Insertion_Node;
134    --  Handle node (name from node) insertion (& insertion character)
135
136    procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr);
137    --  Handle type reference (right brace insertion character). Flag is the
138    --  location of the flag, which is provided for the internal call to
139    --  Set_Msg_Insertion_Line_Number,
140
141    procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True);
142    --  Handle unit name insertion ($ insertion character). Depending on Boolean
143    --  parameter Suffix, (spec) or (body) is appended after the unit name.
144
145    procedure Set_Msg_Node (Node : Node_Id);
146    --  Add the sequence of characters for the name associated with the
147    --  given node to the current message.
148
149    procedure Set_Msg_Text (Text : String; Flag : Source_Ptr);
150    --  Add a sequence of characters to the current message. The characters may
151    --  be one of the special insertion characters (see documentation in spec).
152    --  Flag is the location at which the error is to be posted, which is used
153    --  to determine whether or not the # insertion needs a file name. The
154    --  variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and
155    --  Is_Unconditional_Msg are set on return.
156
157    procedure Set_Posted (N : Node_Id);
158    --  Sets the Error_Posted flag on the given node, and all its parents
159    --  that are subexpressions and then on the parent non-subexpression
160    --  construct that contains the original expression (this reduces the
161    --  number of cascaded messages). Note that this call only has an effect
162    --  for a serious error. For a non-serious error, it has no effect.
163
164    procedure Set_Qualification (N : Nat; E : Entity_Id);
165    --  Outputs up to N levels of qualification for the given entity. For
166    --  example, the entity A.B.C.D will output B.C. if N = 2.
167
168    function Special_Msg_Delete
169      (Msg : String;
170       N   : Node_Or_Entity_Id;
171       E   : Node_Or_Entity_Id) return Boolean;
172    --  This function is called from Error_Msg_NEL, passing the message Msg,
173    --  node N on which the error is to be posted, and the entity or node E
174    --  to be used for an & insertion in the message if any. The job of this
175    --  procedure is to test for certain cascaded messages that we would like
176    --  to suppress. If the message is to be suppressed then we return True.
177    --  If the message should be generated (the normal case) False is returned.
178
179    procedure Unwind_Internal_Type (Ent : in out Entity_Id);
180    --  This procedure is given an entity id for an internal type, i.e. a type
181    --  with an internal name. It unwinds the type to try to get to something
182    --  reasonably printable, generating prefixes like "subtype of", "access
183    --  to", etc along the way in the buffer. The value in Ent on return is the
184    --  final name to be printed. Hopefully this is not an internal name, but in
185    --  some internal name cases, it is an internal name, and has to be printed
186    --  anyway (although in this case the message has been killed if possible).
187    --  The global variable Class_Flag is set to True if the resulting entity
188    --  should have 'Class appended to its name (see Add_Class procedure), and
189    --  is otherwise unchanged.
190
191    procedure VMS_Convert;
192    --  This procedure has no effect if called when the host is not OpenVMS. If
193    --  the host is indeed OpenVMS, then the error message stored in Msg_Buffer
194    --  is scanned for appearances of switch names which need converting to
195    --  corresponding VMS qualifier names. See Gnames/Vnames table in Errout
196    --  spec for precise definition of the conversion that is performed by this
197    --  routine in OpenVMS mode.
198
199    -----------------------
200    -- Change_Error_Text --
201    -----------------------
202
203    procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is
204       Save_Next : Error_Msg_Id;
205       Err_Id    : Error_Msg_Id := Error_Id;
206
207    begin
208       Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr);
209       Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen));
210
211       --  If in immediate error message mode, output modified error message now
212       --  This is just a bit tricky, because we want to output just a single
213       --  message, and the messages we modified is already linked in. We solve
214       --  this by temporarily resetting its forward pointer to empty.
215
216       if Debug_Flag_OO then
217          Save_Next := Errors.Table (Error_Id).Next;
218          Errors.Table (Error_Id).Next := No_Error_Msg;
219          Write_Eol;
220          Output_Source_Line
221            (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True);
222          Output_Error_Msgs (Err_Id);
223          Errors.Table (Error_Id).Next := Save_Next;
224       end if;
225    end Change_Error_Text;
226
227    ------------------------
228    -- Compilation_Errors --
229    ------------------------
230
231    function Compilation_Errors return Boolean is
232    begin
233       if not Finalize_Called then
234          raise Program_Error;
235       else
236          return Erroutc.Compilation_Errors;
237       end if;
238    end Compilation_Errors;
239
240    ---------------
241    -- Error_Msg --
242    ---------------
243
244    --  Error_Msg posts a flag at the given location, except that if the
245    --  Flag_Location points within a generic template and corresponds to an
246    --  instantiation of this generic template, then the actual message will be
247    --  posted on the generic instantiation, along with additional messages
248    --  referencing the generic declaration.
249
250    procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is
251       Sindex : Source_File_Index;
252       --  Source index for flag location
253
254       Orig_Loc : Source_Ptr;
255       --  Original location of Flag_Location (i.e. location in original
256       --  template in instantiation case, otherwise unchanged).
257
258    begin
259       --  It is a fatal error to issue an error message when scanning from the
260       --  internal source buffer (see Sinput for further documentation)
261
262       pragma Assert (Sinput.Source /= Internal_Source_Ptr);
263
264       --  Return if all errors are to be ignored
265
266       if Errors_Must_Be_Ignored then
267          return;
268       end if;
269
270       --  If we already have messages, and we are trying to place a message at
271       --  No_Location or in package Standard, then just ignore the attempt
272       --  since we assume that what is happening is some cascaded junk. Note
273       --  that this is safe in the sense that proceeding will surely bomb.
274
275       if Flag_Location < First_Source_Ptr
276         and then Total_Errors_Detected > 0
277       then
278          return;
279       end if;
280
281       --  Start of processing for new message
282
283       Sindex := Get_Source_File_Index (Flag_Location);
284       Test_Style_Warning_Serious_Msg (Msg);
285       Orig_Loc := Original_Location (Flag_Location);
286
287       --  If the current location is in an instantiation, the issue arises of
288       --  whether to post the message on the template or the instantiation.
289
290       --  The way we decide is to see if we have posted the same message on
291       --  the template when we compiled the template (the template is always
292       --  compiled before any instantiations). For this purpose, we use a
293       --  separate table of messages. The reason we do this is twofold:
294
295       --     First, the messages can get changed by various processing
296       --     including the insertion of tokens etc, making it hard to
297       --     do the comparison.
298
299       --     Second, we will suppress a warning on a template if it is not in
300       --     the current extended source unit. That's reasonable and means we
301       --     don't want the warning on the instantiation here either, but it
302       --     does mean that the main error table would not in any case include
303       --     the message.
304
305       if Flag_Location = Orig_Loc then
306          Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location));
307          Warn_On_Instance := False;
308
309       --  Here we have an instance message
310
311       else
312          --  Delete if debug flag off, and this message duplicates a message
313          --  already posted on the corresponding template
314
315          if not Debug_Flag_GG then
316             for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop
317                if Msg = Non_Instance_Msgs.Table (J).Msg.all
318                  and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc
319                then
320                   return;
321                end if;
322             end loop;
323          end if;
324
325          --  No duplicate, so error/warning will be posted on instance
326
327          Warn_On_Instance := Is_Warning_Msg;
328       end if;
329
330       --  Ignore warning message that is suppressed for this location. Note
331       --  that style checks are not considered warning messages for this
332       --  purpose.
333
334       if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then
335          return;
336
337       --  For style messages, check too many messages so far
338
339       elsif Is_Style_Msg
340         and then Maximum_Messages /= 0
341         and then Warnings_Detected >= Maximum_Messages
342       then
343          return;
344       end if;
345
346       --  The idea at this stage is that we have two kinds of messages
347
348       --  First, we have those messages that are to be placed as requested at
349       --  Flag_Location. This includes messages that have nothing to do with
350       --  generics, and also messages placed on generic templates that reflect
351       --  an error in the template itself. For such messages we simply call
352       --  Error_Msg_Internal to place the message in the requested location.
353
354       if Instantiation (Sindex) = No_Location then
355          Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False);
356          return;
357       end if;
358
359       --  If we are trying to flag an error in an instantiation, we may have
360       --  a generic contract violation. What we generate in this case is:
361
362       --     instantiation error at ...
363       --     original error message
364
365       --  or
366
367       --     warning: in instantiation at
368       --     warning: original warning message
369
370       --  All these messages are posted at the location of the top level
371       --  instantiation. If there are nested instantiations, then the
372       --  instantiation error message can be repeated, pointing to each
373       --  of the relevant instantiations.
374
375       --  Note: the instantiation mechanism is also shared for inlining of
376       --  subprogram bodies when front end inlining is done. In this case the
377       --  messages have the form:
378
379       --     in inlined body at ...
380       --     original error message
381
382       --  or
383
384       --     warning: in inlined body at
385       --     warning: original warning message
386
387       --  OK, here we have an instantiation error, and we need to generate the
388       --  error on the instantiation, rather than on the template.
389
390       declare
391          Actual_Error_Loc : Source_Ptr;
392          --  Location of outer level instantiation in instantiation case, or
393          --  just a copy of Flag_Location in the normal case. This is the
394          --  location where all error messages will actually be posted.
395
396          Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc;
397          --  Save possible location set for caller's message. We need to use
398          --  Error_Msg_Sloc for the location of the instantiation error but we
399          --  have to preserve a possible original value.
400
401          X : Source_File_Index;
402
403          Msg_Cont_Status : Boolean;
404          --  Used to label continuation lines in instantiation case with
405          --  proper Msg_Cont status.
406
407       begin
408          --  Loop to find highest level instantiation, where all error
409          --  messages will be placed.
410
411          X := Sindex;
412          loop
413             Actual_Error_Loc := Instantiation (X);
414             X := Get_Source_File_Index (Actual_Error_Loc);
415             exit when Instantiation (X) = No_Location;
416          end loop;
417
418          --  Since we are generating the messages at the instantiation point in
419          --  any case, we do not want the references to the bad lines in the
420          --  instance to be annotated with the location of the instantiation.
421
422          Suppress_Instance_Location := True;
423          Msg_Cont_Status := False;
424
425          --  Loop to generate instantiation messages
426
427          Error_Msg_Sloc := Flag_Location;
428          X := Get_Source_File_Index (Flag_Location);
429
430          while Instantiation (X) /= No_Location loop
431
432             --  Suppress instantiation message on continuation lines
433
434             if Msg (Msg'First) /= '\' then
435
436                --  Case of inlined body
437
438                if Inlined_Body (X) then
439                   if Is_Warning_Msg or else Is_Style_Msg then
440                      Error_Msg_Internal
441                        ("?in inlined body #",
442                         Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
443
444                   else
445                      Error_Msg_Internal
446                        ("error in inlined body #",
447                         Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
448                   end if;
449
450                --  Case of generic instantiation
451
452                else
453                   if Is_Warning_Msg or else Is_Style_Msg then
454                      Error_Msg_Internal
455                        ("?in instantiation #",
456                         Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
457
458                   else
459                      Error_Msg_Internal
460                        ("instantiation error #",
461                         Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
462                   end if;
463                end if;
464             end if;
465
466             Error_Msg_Sloc := Instantiation (X);
467             X := Get_Source_File_Index (Error_Msg_Sloc);
468             Msg_Cont_Status := True;
469          end loop;
470
471          Suppress_Instance_Location := False;
472          Error_Msg_Sloc := Save_Error_Msg_Sloc;
473
474          --  Here we output the original message on the outer instantiation
475
476          Error_Msg_Internal
477            (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
478       end;
479    end Error_Msg;
480
481    ------------------
482    -- Error_Msg_AP --
483    ------------------
484
485    procedure Error_Msg_AP (Msg : String) is
486       S1 : Source_Ptr;
487       C  : Character;
488
489    begin
490       --  If we had saved the Scan_Ptr value after scanning the previous
491       --  token, then we would have exactly the right place for putting
492       --  the flag immediately at hand. However, that would add at least
493       --  two instructions to a Scan call *just* to service the possibility
494       --  of an Error_Msg_AP call. So instead we reconstruct that value.
495
496       --  We have two possibilities, start with Prev_Token_Ptr and skip over
497       --  the current token, which is made harder by the possibility that this
498       --  token may be in error, or start with Token_Ptr and work backwards.
499       --  We used to take the second approach, but it's hard because of
500       --  comments, and harder still because things that look like comments
501       --  can appear inside strings. So now we take the first approach.
502
503       --  Note: in the case where there is no previous token, Prev_Token_Ptr
504       --  is set to Source_First, which is a reasonable position for the
505       --  error flag in this situation.
506
507       S1 := Prev_Token_Ptr;
508       C := Source (S1);
509
510       --  If the previous token is a string literal, we need a special approach
511       --  since there may be white space inside the literal and we don't want
512       --  to stop on that white space.
513
514       --  Note: since this is an error recovery issue anyway, it is not worth
515       --  worrying about special UTF_32 line terminator characters here.
516
517       if Prev_Token = Tok_String_Literal then
518          loop
519             S1 := S1 + 1;
520
521             if Source (S1) = C then
522                S1 := S1 + 1;
523                exit when Source (S1) /= C;
524             elsif Source (S1) in Line_Terminator then
525                exit;
526             end if;
527          end loop;
528
529       --  Character literal also needs special handling
530
531       elsif Prev_Token = Tok_Char_Literal then
532          S1 := S1 + 3;
533
534       --  Otherwise we search forward for the end of the current token, marked
535       --  by a line terminator, white space, a comment symbol or if we bump
536       --  into the following token (i.e. the current token).
537
538       --  Again, it is not worth worrying about UTF_32 special line terminator
539       --  characters in this context, since this is only for error recovery.
540
541       else
542          while Source (S1) not in Line_Terminator
543            and then Source (S1) /= ' '
544            and then Source (S1) /= ASCII.HT
545            and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-')
546            and then S1 /= Token_Ptr
547          loop
548             S1 := S1 + 1;
549          end loop;
550       end if;
551
552       --  S1 is now set to the location for the flag
553
554       Error_Msg (Msg, S1);
555    end Error_Msg_AP;
556
557    ------------------
558    -- Error_Msg_BC --
559    ------------------
560
561    procedure Error_Msg_BC (Msg : String) is
562    begin
563       --  If we are at end of file, post the flag after the previous token
564
565       if Token = Tok_EOF then
566          Error_Msg_AP (Msg);
567
568       --  If we are at start of file, post the flag at the current token
569
570       elsif Token_Ptr = Source_First (Current_Source_File) then
571          Error_Msg_SC (Msg);
572
573       --  If the character before the current token is a space or a horizontal
574       --  tab, then we place the flag on this character (in the case of a tab
575       --  we would really like to place it in the "last" character of the tab
576       --  space, but that it too much trouble to worry about).
577
578       elsif Source (Token_Ptr - 1) = ' '
579          or else Source (Token_Ptr - 1) = ASCII.HT
580       then
581          Error_Msg (Msg, Token_Ptr - 1);
582
583       --  If there is no space or tab before the current token, then there is
584       --  no room to place the flag before the token, so we place it on the
585       --  token instead (this happens for example at the start of a line).
586
587       else
588          Error_Msg (Msg, Token_Ptr);
589       end if;
590    end Error_Msg_BC;
591
592    -------------------
593    -- Error_Msg_CRT --
594    -------------------
595
596    procedure Error_Msg_CRT (Feature : String; N : Node_Id) is
597       CNRT : constant String := " not allowed in no run time mode";
598       CCRT : constant String := " not supported by configuration>";
599
600       S : String (1 .. Feature'Length + 1 + CCRT'Length);
601       L : Natural;
602
603    begin
604       S (1) := '|';
605       S (2 .. Feature'Length + 1) := Feature;
606       L := Feature'Length + 2;
607
608       if No_Run_Time_Mode then
609          S (L .. L + CNRT'Length - 1) := CNRT;
610          L := L + CNRT'Length - 1;
611
612       else pragma Assert (Configurable_Run_Time_Mode);
613          S (L .. L + CCRT'Length - 1) := CCRT;
614          L := L + CCRT'Length - 1;
615       end if;
616
617       Error_Msg_N (S (1 .. L), N);
618       Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;
619    end Error_Msg_CRT;
620
621    -----------------
622    -- Error_Msg_F --
623    -----------------
624
625    procedure Error_Msg_F (Msg : String; N : Node_Id) is
626    begin
627       Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N)));
628    end Error_Msg_F;
629
630    ------------------
631    -- Error_Msg_FE --
632    ------------------
633
634    procedure Error_Msg_FE
635      (Msg : String;
636       N   : Node_Id;
637       E   : Node_Or_Entity_Id)
638    is
639    begin
640       Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N)));
641    end Error_Msg_FE;
642
643    ------------------------
644    -- Error_Msg_Internal --
645    ------------------------
646
647    procedure Error_Msg_Internal
648      (Msg      : String;
649       Sptr     : Source_Ptr;
650       Optr     : Source_Ptr;
651       Msg_Cont : Boolean)
652    is
653       Next_Msg : Error_Msg_Id;
654       --  Pointer to next message at insertion point
655
656       Prev_Msg : Error_Msg_Id;
657       --  Pointer to previous message at insertion point
658
659       Temp_Msg : Error_Msg_Id;
660
661       procedure Handle_Serious_Error;
662       --  Internal procedure to do all error message handling for a serious
663       --  error message, other than bumping the error counts and arranging
664       --  for the message to be output.
665
666       --------------------------
667       -- Handle_Serious_Error --
668       --------------------------
669
670       procedure Handle_Serious_Error is
671       begin
672          --  Turn off code generation if not done already
673
674          if Operating_Mode = Generate_Code then
675             Operating_Mode := Check_Semantics;
676             Expander_Active := False;
677          end if;
678
679          --  Set the fatal error flag in the unit table unless we are in
680          --  Try_Semantics mode. This stops the semantics from being performed
681          --  if we find a serious error. This is skipped if we are currently
682          --  dealing with the configuration pragma file.
683
684          if not Try_Semantics and then Current_Source_Unit /= No_Unit then
685             Set_Fatal_Error (Get_Source_Unit (Sptr));
686          end if;
687       end Handle_Serious_Error;
688
689    --  Start of processing for Error_Msg_Internal
690
691    begin
692       if Raise_Exception_On_Error /= 0 then
693          raise Error_Msg_Exception;
694       end if;
695
696       Continuation := Msg_Cont;
697       Continuation_New_Line := False;
698       Suppress_Message := False;
699       Kill_Message := False;
700       Set_Msg_Text (Msg, Sptr);
701
702       --  Kill continuation if parent message killed
703
704       if Continuation and Last_Killed then
705          return;
706       end if;
707
708       --  Return without doing anything if message is suppressed
709
710       if Suppress_Message
711         and then not All_Errors_Mode
712         and then not Is_Warning_Msg
713         and then Msg (Msg'Last) /= '!'
714       then
715          if not Continuation then
716             Last_Killed := True;
717          end if;
718
719          return;
720       end if;
721
722       --  Return without doing anything if message is killed and this is not
723       --  the first error message. The philosophy is that if we get a weird
724       --  error message and we already have had a message, then we hope the
725       --  weird message is a junk cascaded message
726
727       if Kill_Message
728         and then not All_Errors_Mode
729         and then Total_Errors_Detected /= 0
730       then
731          if not Continuation then
732             Last_Killed := True;
733          end if;
734
735          return;
736       end if;
737
738       --  Special check for warning message to see if it should be output
739
740       if Is_Warning_Msg then
741
742          --  Immediate return if warning message and warnings are suppressed
743
744          if Warnings_Suppressed (Optr) or else Warnings_Suppressed (Sptr) then
745             Cur_Msg := No_Error_Msg;
746             return;
747          end if;
748
749          --  If the flag location is in the main extended source unit then for
750          --  sure we want the warning since it definitely belongs
751
752          if In_Extended_Main_Source_Unit (Sptr) then
753             null;
754
755          --  If the flag location is not in the main extended source unit, then
756          --  we want to eliminate the warning, unless it is in the extended
757          --  main code unit and we want warnings on the instance.
758
759          elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then
760             null;
761
762          --  Keep warning if debug flag G set
763
764          elsif Debug_Flag_GG then
765             null;
766
767          --  Keep warning if message text ends in !!
768
769          elsif Msg (Msg'Last) = '!' and then Msg (Msg'Last - 1) = '!' then
770             null;
771
772          --  Here is where we delete a warning from a with'ed unit
773
774          else
775             Cur_Msg := No_Error_Msg;
776
777             if not Continuation then
778                Last_Killed := True;
779             end if;
780
781             return;
782          end if;
783       end if;
784
785       --  If message is to be ignored in special ignore message mode, this is
786       --  where we do this special processing, bypassing message output.
787
788       if Ignore_Errors_Enable > 0 then
789          if Is_Serious_Error then
790             Handle_Serious_Error;
791          end if;
792
793          return;
794       end if;
795
796       --  If error message line length set, and this is a continuation message
797       --  then all we do is to append the text to the text of the last message
798       --  with a comma space separator (eliminating a possible (style) or
799       --  info prefix).
800
801       if Error_Msg_Line_Length /= 0
802         and then Continuation
803       then
804          Cur_Msg := Errors.Last;
805
806          declare
807             Oldm : String_Ptr := Errors.Table (Cur_Msg).Text;
808             Newm : String (1 .. Oldm'Last + 2 + Msglen);
809             Newl : Natural;
810             M    : Natural;
811
812          begin
813             --  First copy old message to new one and free it
814
815             Newm (Oldm'Range) := Oldm.all;
816             Newl := Oldm'Length;
817             Free (Oldm);
818
819             --  Remove (style) or info: at start of message
820
821             if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then
822                M := 9;
823
824             elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then
825                M := 7;
826
827             else
828                M := 1;
829             end if;
830
831             --  Now deal with separation between messages. Normally this is
832             --  simply comma space, but there are some special cases.
833
834             --  If continuation new line, then put actual NL character in msg
835
836             if Continuation_New_Line then
837                Newl := Newl + 1;
838                Newm (Newl) := ASCII.LF;
839
840             --  If continuation message is enclosed in parentheses, then
841             --  special treatment (don't need a comma, and we want to combine
842             --  successive parenthetical remarks into a single one with
843             --  separating commas).
844
845             elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then
846
847                --  Case where existing message ends in right paren, remove
848                --  and separate parenthetical remarks with a comma.
849
850                if Newm (Newl) = ')' then
851                   Newm (Newl) := ',';
852                   Msg_Buffer (M) := ' ';
853
854                --  Case where we are adding new parenthetical comment
855
856                else
857                   Newl := Newl + 1;
858                   Newm (Newl) := ' ';
859                end if;
860
861             --  Case where continuation not in parens and no new line
862
863             else
864                Newm (Newl + 1 .. Newl + 2) := ", ";
865                Newl := Newl + 2;
866             end if;
867
868             --  Append new message
869
870             Newm (Newl + 1 .. Newl + Msglen - M + 1) :=
871               Msg_Buffer (M .. Msglen);
872             Newl := Newl + Msglen - M + 1;
873             Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl));
874          end;
875
876          return;
877       end if;
878
879       --  Otherwise build error message object for new message
880
881       Errors.Append
882         ((Text     => new String'(Msg_Buffer (1 .. Msglen)),
883           Next     => No_Error_Msg,
884           Sptr     => Sptr,
885           Optr     => Optr,
886           Sfile    => Get_Source_File_Index (Sptr),
887           Line     => Get_Physical_Line_Number (Sptr),
888           Col      => Get_Column_Number (Sptr),
889           Warn     => Is_Warning_Msg,
890           Style    => Is_Style_Msg,
891           Serious  => Is_Serious_Error,
892           Uncond   => Is_Unconditional_Msg,
893           Msg_Cont => Continuation,
894           Deleted  => False));
895       Cur_Msg := Errors.Last;
896
897       --  If immediate errors mode set, output error message now. Also output
898       --  now if the -d1 debug flag is set (so node number message comes out
899       --  just before actual error message)
900
901       if Debug_Flag_OO or else Debug_Flag_1 then
902          Write_Eol;
903          Output_Source_Line
904            (Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Sfile, True);
905          Temp_Msg := Cur_Msg;
906          Output_Error_Msgs (Temp_Msg);
907
908       --  If not in immediate errors mode, then we insert the message in the
909       --  error chain for later output by Finalize. The messages are sorted
910       --  first by unit (main unit comes first), and within a unit by source
911       --  location (earlier flag location first in the chain).
912
913       else
914          --  First a quick check, does this belong at the very end of the chain
915          --  of error messages. This saves a lot of time in the normal case if
916          --  there are lots of messages.
917
918          if Last_Error_Msg /= No_Error_Msg
919            and then Errors.Table (Cur_Msg).Sfile =
920                     Errors.Table (Last_Error_Msg).Sfile
921            and then (Sptr > Errors.Table (Last_Error_Msg).Sptr
922                        or else
923                           (Sptr = Errors.Table (Last_Error_Msg).Sptr
924                              and then
925                                Optr > Errors.Table (Last_Error_Msg).Optr))
926          then
927             Prev_Msg := Last_Error_Msg;
928             Next_Msg := No_Error_Msg;
929
930          --  Otherwise do a full sequential search for the insertion point
931
932          else
933             Prev_Msg := No_Error_Msg;
934             Next_Msg := First_Error_Msg;
935             while Next_Msg /= No_Error_Msg loop
936                exit when
937                  Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile;
938
939                if Errors.Table (Cur_Msg).Sfile =
940                     Errors.Table (Next_Msg).Sfile
941                then
942                   exit when Sptr < Errors.Table (Next_Msg).Sptr
943                               or else
944                                 (Sptr = Errors.Table (Next_Msg).Sptr
945                                    and then
946                                  Optr < Errors.Table (Next_Msg).Optr);
947                end if;
948
949                Prev_Msg := Next_Msg;
950                Next_Msg := Errors.Table (Next_Msg).Next;
951             end loop;
952          end if;
953
954          --  Now we insert the new message in the error chain. The insertion
955          --  point for the message is after Prev_Msg and before Next_Msg.
956
957          --  The possible insertion point for the new message is after Prev_Msg
958          --  and before Next_Msg. However, this is where we do a special check
959          --  for redundant parsing messages, defined as messages posted on the
960          --  same line. The idea here is that probably such messages are junk
961          --  from the parser recovering. In full errors mode, we don't do this
962          --  deletion, but otherwise such messages are discarded at this stage.
963
964          if Prev_Msg /= No_Error_Msg
965            and then Errors.Table (Prev_Msg).Line =
966                                              Errors.Table (Cur_Msg).Line
967            and then Errors.Table (Prev_Msg).Sfile =
968                                              Errors.Table (Cur_Msg).Sfile
969            and then Compiler_State = Parsing
970            and then not All_Errors_Mode
971          then
972             --  Don't delete unconditional messages and at this stage, don't
973             --  delete continuation lines (we attempted to delete those earlier
974             --  if the parent message was deleted.
975
976             if not Errors.Table (Cur_Msg).Uncond
977               and then not Continuation
978             then
979                --  Don't delete if prev msg is warning and new msg is an error.
980                --  This is because we don't want a real error masked by a
981                --  warning. In all other cases (that is parse errors for the
982                --  same line that are not unconditional) we do delete the
983                --  message. This helps to avoid junk extra messages from
984                --  cascaded parsing errors
985
986                if not (Errors.Table (Prev_Msg).Warn
987                          or else
988                        Errors.Table (Prev_Msg).Style)
989                  or else
990                       (Errors.Table (Cur_Msg).Warn
991                          or else
992                        Errors.Table (Cur_Msg).Style)
993                then
994                   --  All tests passed, delete the message by simply returning
995                   --  without any further processing.
996
997                   if not Continuation then
998                      Last_Killed := True;
999                   end if;
1000
1001                   return;
1002                end if;
1003             end if;
1004          end if;
1005
1006          --  Come here if message is to be inserted in the error chain
1007
1008          if not Continuation then
1009             Last_Killed := False;
1010          end if;
1011
1012          if Prev_Msg = No_Error_Msg then
1013             First_Error_Msg := Cur_Msg;
1014          else
1015             Errors.Table (Prev_Msg).Next := Cur_Msg;
1016          end if;
1017
1018          Errors.Table (Cur_Msg).Next := Next_Msg;
1019
1020          if Next_Msg = No_Error_Msg then
1021             Last_Error_Msg := Cur_Msg;
1022          end if;
1023       end if;
1024
1025       --  Bump appropriate statistics count
1026
1027       if Errors.Table (Cur_Msg).Warn or else Errors.Table (Cur_Msg).Style then
1028          Warnings_Detected := Warnings_Detected + 1;
1029
1030       else
1031          Total_Errors_Detected := Total_Errors_Detected + 1;
1032
1033          if Errors.Table (Cur_Msg).Serious then
1034             Serious_Errors_Detected := Serious_Errors_Detected + 1;
1035             Handle_Serious_Error;
1036          end if;
1037       end if;
1038
1039       --  If too many warnings turn off warnings
1040
1041       if Maximum_Messages /= 0 then
1042          if Warnings_Detected = Maximum_Messages then
1043             Warning_Mode := Suppress;
1044          end if;
1045
1046          --  If too many errors abandon compilation
1047
1048          if Total_Errors_Detected = Maximum_Messages then
1049             raise Unrecoverable_Error;
1050          end if;
1051       end if;
1052    end Error_Msg_Internal;
1053
1054    -----------------
1055    -- Error_Msg_N --
1056    -----------------
1057
1058    procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is
1059    begin
1060       Error_Msg_NEL (Msg, N, N, Sloc (N));
1061    end Error_Msg_N;
1062
1063    ------------------
1064    -- Error_Msg_NE --
1065    ------------------
1066
1067    procedure Error_Msg_NE
1068      (Msg : String;
1069       N   : Node_Or_Entity_Id;
1070       E   : Node_Or_Entity_Id)
1071    is
1072    begin
1073       Error_Msg_NEL (Msg, N, E, Sloc (N));
1074    end Error_Msg_NE;
1075
1076    -------------------
1077    -- Error_Msg_NEL --
1078    -------------------
1079
1080    procedure Error_Msg_NEL
1081      (Msg           : String;
1082       N             : Node_Or_Entity_Id;
1083       E             : Node_Or_Entity_Id;
1084       Flag_Location : Source_Ptr)
1085    is
1086    begin
1087       if Special_Msg_Delete (Msg, N, E) then
1088          return;
1089       end if;
1090
1091       Test_Style_Warning_Serious_Msg (Msg);
1092
1093       --  Special handling for warning messages
1094
1095       if Is_Warning_Msg then
1096
1097          --  Suppress if no warnings set for either entity or node
1098
1099          if No_Warnings (N) or else No_Warnings (E) then
1100
1101             --  Disable any continuation messages as well
1102
1103             Last_Killed := True;
1104             return;
1105          end if;
1106
1107          --  Suppress if inside loop that is known to be null or is probably
1108          --  null (case where loop executes only if invalid values present).
1109          --  In either case warnings in the loop are likely to be junk.
1110
1111          declare
1112             P : Node_Id;
1113
1114          begin
1115             P := Parent (N);
1116             while Present (P) loop
1117                if Nkind (P) = N_Loop_Statement
1118                  and then Suppress_Loop_Warnings (P)
1119                then
1120                   return;
1121                end if;
1122
1123                P := Parent (P);
1124             end loop;
1125          end;
1126       end if;
1127
1128       --  Test for message to be output
1129
1130       if All_Errors_Mode
1131         or else Msg (Msg'Last) = '!'
1132         or else Is_Warning_Msg
1133         or else OK_Node (N)
1134         or else (Msg (Msg'First) = '\' and then not Last_Killed)
1135       then
1136          Debug_Output (N);
1137          Error_Msg_Node_1 := E;
1138          Error_Msg (Msg, Flag_Location);
1139
1140       else
1141          Last_Killed := True;
1142       end if;
1143
1144       if not (Is_Warning_Msg or Is_Style_Msg) then
1145          Set_Posted (N);
1146       end if;
1147    end Error_Msg_NEL;
1148
1149    ------------------
1150    -- Error_Msg_NW --
1151    ------------------
1152
1153    procedure Error_Msg_NW
1154      (Eflag : Boolean;
1155       Msg   : String;
1156       N     : Node_Or_Entity_Id)
1157    is
1158    begin
1159       if Eflag
1160         and then In_Extended_Main_Source_Unit (N)
1161         and then Comes_From_Source (N)
1162       then
1163          Error_Msg_NEL (Msg, N, N, Sloc (N));
1164       end if;
1165    end Error_Msg_NW;
1166
1167    -----------------
1168    -- Error_Msg_S --
1169    -----------------
1170
1171    procedure Error_Msg_S (Msg : String) is
1172    begin
1173       Error_Msg (Msg, Scan_Ptr);
1174    end Error_Msg_S;
1175
1176    ------------------
1177    -- Error_Msg_SC --
1178    ------------------
1179
1180    procedure Error_Msg_SC (Msg : String) is
1181    begin
1182       --  If we are at end of file, post the flag after the previous token
1183
1184       if Token = Tok_EOF then
1185          Error_Msg_AP (Msg);
1186
1187       --  For all other cases the message is posted at the current token
1188       --  pointer position
1189
1190       else
1191          Error_Msg (Msg, Token_Ptr);
1192       end if;
1193    end Error_Msg_SC;
1194
1195    ------------------
1196    -- Error_Msg_SP --
1197    ------------------
1198
1199    procedure Error_Msg_SP (Msg : String) is
1200    begin
1201       --  Note: in the case where there is no previous token, Prev_Token_Ptr
1202       --  is set to Source_First, which is a reasonable position for the
1203       --  error flag in this situation
1204
1205       Error_Msg (Msg, Prev_Token_Ptr);
1206    end Error_Msg_SP;
1207
1208    --------------
1209    -- Finalize --
1210    --------------
1211
1212    procedure Finalize (Last_Call : Boolean) is
1213       Cur : Error_Msg_Id;
1214       Nxt : Error_Msg_Id;
1215       F   : Error_Msg_Id;
1216
1217    begin
1218       --  Eliminate any duplicated error messages from the list. This is
1219       --  done after the fact to avoid problems with Change_Error_Text.
1220
1221       Cur := First_Error_Msg;
1222       while Cur /= No_Error_Msg loop
1223          Nxt := Errors.Table (Cur).Next;
1224
1225          F := Nxt;
1226          while F /= No_Error_Msg
1227            and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr
1228          loop
1229             Check_Duplicate_Message (Cur, F);
1230             F := Errors.Table (F).Next;
1231          end loop;
1232
1233          Cur := Nxt;
1234       end loop;
1235
1236       --  Mark any messages suppressed by specific warnings as Deleted
1237
1238       Cur := First_Error_Msg;
1239       while Cur /= No_Error_Msg loop
1240          if not Errors.Table (Cur).Deleted
1241            and then Warning_Specifically_Suppressed
1242                      (Errors.Table (Cur).Sptr,
1243                       Errors.Table (Cur).Text)
1244          then
1245             Errors.Table (Cur).Deleted := True;
1246             Warnings_Detected := Warnings_Detected - 1;
1247          end if;
1248
1249          Cur := Errors.Table (Cur).Next;
1250       end loop;
1251
1252       Finalize_Called := True;
1253
1254       --  Check consistency of specific warnings (may add warnings). We only
1255       --  do this on the last call, after all possible warnings are posted.
1256
1257       if Last_Call then
1258          Validate_Specific_Warnings (Error_Msg'Access);
1259       end if;
1260    end Finalize;
1261
1262    ----------------
1263    -- First_Node --
1264    ----------------
1265
1266    function First_Node (C : Node_Id) return Node_Id is
1267       L        : constant Source_Ptr        := Sloc (Original_Node (C));
1268       Sfile    : constant Source_File_Index := Get_Source_File_Index (L);
1269       Earliest : Node_Id;
1270       Eloc     : Source_Ptr;
1271
1272       function Test_Earlier (N : Node_Id) return Traverse_Result;
1273       --  Function applied to every node in the construct
1274
1275       procedure Search_Tree_First is new Traverse_Proc (Test_Earlier);
1276       --  Create traversal procedure
1277
1278       ------------------
1279       -- Test_Earlier --
1280       ------------------
1281
1282       function Test_Earlier (N : Node_Id) return Traverse_Result is
1283          Loc : constant Source_Ptr := Sloc (Original_Node (N));
1284
1285       begin
1286          --  Check for earlier. The tests for being in the same file ensures
1287          --  against strange cases of foreign code somehow being present. We
1288          --  don't want wild placement of messages if that happens, so it is
1289          --  best to just ignore this situation.
1290
1291          if Loc < Eloc
1292            and then Get_Source_File_Index (Loc) = Sfile
1293          then
1294             Earliest := Original_Node (N);
1295             Eloc     := Loc;
1296          end if;
1297
1298          return OK_Orig;
1299       end Test_Earlier;
1300
1301    --  Start of processing for First_Node
1302
1303    begin
1304       Earliest := Original_Node (C);
1305       Eloc := Sloc (Earliest);
1306       Search_Tree_First (Original_Node (C));
1307       return Earliest;
1308    end First_Node;
1309
1310    ----------------
1311    -- First_Sloc --
1312    ----------------
1313
1314    function First_Sloc (N : Node_Id) return Source_Ptr is
1315       SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N));
1316       SF : constant Source_Ptr        := Source_First (SI);
1317       F  : Node_Id;
1318       S  : Source_Ptr;
1319
1320    begin
1321       F := First_Node (N);
1322       S := Sloc (F);
1323
1324       --  The following circuit is a bit subtle. When we have parenthesized
1325       --  expressions, then the Sloc will not record the location of the paren,
1326       --  but we would like to post the flag on the paren. So what we do is to
1327       --  crawl up the tree from the First_Node, adjusting the Sloc value for
1328       --  any parentheses we know are present. Yes, we know this circuit is not
1329       --  100% reliable (e.g. because we don't record all possible paren level
1330       --  values), but this is only for an error message so it is good enough.
1331
1332       Node_Loop : loop
1333          Paren_Loop : for J in 1 .. Paren_Count (F) loop
1334
1335             --  We don't look more than 12 characters behind the current
1336             --  location, and in any case not past the front of the source.
1337
1338             Search_Loop : for K in 1 .. 12 loop
1339                exit Search_Loop when S = SF;
1340
1341                if Source_Text (SI) (S - 1) = '(' then
1342                   S := S - 1;
1343                   exit Search_Loop;
1344
1345                elsif Source_Text (SI) (S - 1) <= ' ' then
1346                   S := S - 1;
1347
1348                else
1349                   exit Search_Loop;
1350                end if;
1351             end loop Search_Loop;
1352          end loop Paren_Loop;
1353
1354          exit Node_Loop when F = N;
1355          F := Parent (F);
1356          exit Node_Loop when Nkind (F) not in N_Subexpr;
1357       end loop Node_Loop;
1358
1359       return S;
1360    end First_Sloc;
1361
1362    ----------------
1363    -- Initialize --
1364    ----------------
1365
1366    procedure Initialize is
1367    begin
1368       Errors.Init;
1369       First_Error_Msg := No_Error_Msg;
1370       Last_Error_Msg := No_Error_Msg;
1371       Serious_Errors_Detected := 0;
1372       Total_Errors_Detected := 0;
1373       Warnings_Detected := 0;
1374       Cur_Msg := No_Error_Msg;
1375       List_Pragmas.Init;
1376
1377       --  Initialize warnings table, if all warnings are suppressed, supply an
1378       --  initial dummy entry covering all possible source locations.
1379
1380       Warnings.Init;
1381       Specific_Warnings.Init;
1382
1383       if Warning_Mode = Suppress then
1384          Warnings.Append
1385            ((Start => Source_Ptr'First, Stop => Source_Ptr'Last));
1386       end if;
1387    end Initialize;
1388
1389    -----------------
1390    -- No_Warnings --
1391    -----------------
1392
1393    function No_Warnings (N : Node_Or_Entity_Id) return Boolean is
1394    begin
1395       if Error_Posted (N) then
1396          return True;
1397
1398       elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then
1399          return True;
1400
1401       elsif Is_Entity_Name (N)
1402         and then Present (Entity (N))
1403         and then Has_Warnings_Off (Entity (N))
1404       then
1405          return True;
1406
1407       else
1408          return False;
1409       end if;
1410    end No_Warnings;
1411
1412    -------------
1413    -- OK_Node --
1414    -------------
1415
1416    function OK_Node (N : Node_Id) return Boolean is
1417       K : constant Node_Kind := Nkind (N);
1418
1419    begin
1420       if Error_Posted (N) then
1421          return False;
1422
1423       elsif K in N_Has_Etype
1424         and then Present (Etype (N))
1425         and then Error_Posted (Etype (N))
1426       then
1427          return False;
1428
1429       elsif (K in N_Op
1430               or else K = N_Attribute_Reference
1431               or else K = N_Character_Literal
1432               or else K = N_Expanded_Name
1433               or else K = N_Identifier
1434               or else K = N_Operator_Symbol)
1435         and then Present (Entity (N))
1436         and then Error_Posted (Entity (N))
1437       then
1438          return False;
1439       else
1440          return True;
1441       end if;
1442    end OK_Node;
1443
1444    ---------------------
1445    -- Output_Messages --
1446    ---------------------
1447
1448    procedure Output_Messages is
1449       E        : Error_Msg_Id;
1450       Err_Flag : Boolean;
1451
1452       procedure Write_Error_Summary;
1453       --  Write error summary
1454
1455       procedure Write_Header (Sfile : Source_File_Index);
1456       --  Write header line (compiling or checking given file)
1457
1458       procedure Write_Max_Errors;
1459       --  Write message if max errors reached
1460
1461       -------------------------
1462       -- Write_Error_Summary --
1463       -------------------------
1464
1465       procedure Write_Error_Summary is
1466       begin
1467          --  Extra blank line if error messages or source listing were output
1468
1469          if Total_Errors_Detected + Warnings_Detected > 0
1470            or else Full_List
1471          then
1472             Write_Eol;
1473          end if;
1474
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.
1481
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.
1486
1487          if Total_Errors_Detected + Warnings_Detected /= 0
1488            and then not Brief_Output
1489            and then (Verbose_Mode or Full_List)
1490          then
1491             Set_Standard_Error;
1492          end if;
1493
1494          --  Message giving total number of lines
1495
1496          Write_Str (" ");
1497          Write_Int (Num_Source_Lines (Main_Source_File));
1498
1499          if Num_Source_Lines (Main_Source_File) = 1 then
1500             Write_Str (" line: ");
1501          else
1502             Write_Str (" lines: ");
1503          end if;
1504
1505          if Total_Errors_Detected = 0 then
1506             Write_Str ("No errors");
1507
1508          elsif Total_Errors_Detected = 1 then
1509             Write_Str ("1 error");
1510
1511          else
1512             Write_Int (Total_Errors_Detected);
1513             Write_Str (" errors");
1514          end if;
1515
1516          if Warnings_Detected /= 0 then
1517             Write_Str (", ");
1518             Write_Int (Warnings_Detected);
1519             Write_Str (" warning");
1520
1521             if Warnings_Detected /= 1 then
1522                Write_Char ('s');
1523             end if;
1524
1525             if Warning_Mode = Treat_As_Error then
1526                Write_Str (" (treated as error");
1527
1528                if Warnings_Detected /= 1 then
1529                   Write_Char ('s');
1530                end if;
1531
1532                Write_Char (')');
1533             end if;
1534          end if;
1535
1536          Write_Eol;
1537          Set_Standard_Output;
1538       end Write_Error_Summary;
1539
1540       ------------------
1541       -- Write_Header --
1542       ------------------
1543
1544       procedure Write_Header (Sfile : Source_File_Index) is
1545       begin
1546          if Verbose_Mode or Full_List then
1547             if Original_Operating_Mode = Generate_Code then
1548                Write_Str ("Compiling: ");
1549             else
1550                Write_Str ("Checking: ");
1551             end if;
1552
1553             Write_Name (Full_File_Name (Sfile));
1554
1555             if not Debug_Flag_7 then
1556                Write_Str (" (source file time stamp: ");
1557                Write_Time_Stamp (Sfile);
1558                Write_Char (')');
1559             end if;
1560
1561             Write_Eol;
1562          end if;
1563       end Write_Header;
1564
1565       ----------------------
1566       -- Write_Max_Errors --
1567       ----------------------
1568
1569       procedure Write_Max_Errors is
1570       begin
1571          if Maximum_Messages /= 0 then
1572             if Warnings_Detected >= Maximum_Messages then
1573                Set_Standard_Error;
1574                Write_Line ("maximum number of warnings output");
1575                Write_Line ("any further warnings suppressed");
1576                Set_Standard_Output;
1577             end if;
1578
1579             --  If too many errors print message
1580
1581             if Total_Errors_Detected >= Maximum_Messages then
1582                Set_Standard_Error;
1583                Write_Line ("fatal error: maximum number of errors detected");
1584                Set_Standard_Output;
1585             end if;
1586          end if;
1587       end Write_Max_Errors;
1588
1589    --  Start of processing for Output_Messages
1590
1591    begin
1592       --  Error if Finalize has not been called
1593
1594       if not Finalize_Called then
1595          raise Program_Error;
1596       end if;
1597
1598       --  Reset current error source file if the main unit has a pragma
1599       --  Source_Reference. This ensures outputting the proper name of
1600       --  the source file in this situation.
1601
1602       if Main_Source_File = No_Source_File
1603         or else Num_SRef_Pragmas (Main_Source_File) /= 0
1604       then
1605          Current_Error_Source_File := No_Source_File;
1606       end if;
1607
1608       --  Brief Error mode
1609
1610       if Brief_Output or (not Full_List and not Verbose_Mode) then
1611          Set_Standard_Error;
1612
1613          E := First_Error_Msg;
1614          while E /= No_Error_Msg loop
1615             if not Errors.Table (E).Deleted and then not Debug_Flag_KK then
1616                if Full_Path_Name_For_Brief_Errors then
1617                   Write_Name (Full_Ref_Name (Errors.Table (E).Sfile));
1618                else
1619                   Write_Name (Reference_Name (Errors.Table (E).Sfile));
1620                end if;
1621
1622                Write_Char (':');
1623                Write_Int (Int (Physical_To_Logical
1624                                 (Errors.Table (E).Line,
1625                                  Errors.Table (E).Sfile)));
1626                Write_Char (':');
1627
1628                if Errors.Table (E).Col < 10 then
1629                   Write_Char ('0');
1630                end if;
1631
1632                Write_Int (Int (Errors.Table (E).Col));
1633                Write_Str (": ");
1634                Output_Msg_Text (E);
1635                Write_Eol;
1636             end if;
1637
1638             E := Errors.Table (E).Next;
1639          end loop;
1640
1641          Set_Standard_Output;
1642       end if;
1643
1644       --  Full source listing case
1645
1646       if Full_List then
1647          List_Pragmas_Index := 1;
1648          List_Pragmas_Mode := True;
1649          E := First_Error_Msg;
1650
1651          --  Normal case, to stdout (copyright notice already output)
1652
1653          if Full_List_File_Name = null then
1654             if not Debug_Flag_7 then
1655                Write_Eol;
1656             end if;
1657
1658          --  Output to file
1659
1660          else
1661             Create_List_File_Access.all (Full_List_File_Name.all);
1662             Set_Special_Output (Write_List_Info_Access.all'Access);
1663
1664             --  Write copyright notice to file
1665
1666             if not Debug_Flag_7 then
1667                Write_Str ("GNAT ");
1668                Write_Str (Gnat_Version_String);
1669                Write_Eol;
1670                Write_Str ("Copyright 1992-" &
1671                           Current_Year &
1672                           ", Free Software Foundation, Inc.");
1673                Write_Eol;
1674             end if;
1675          end if;
1676
1677          --  First list extended main source file units with errors
1678
1679          for U in Main_Unit .. Last_Unit loop
1680             if In_Extended_Main_Source_Unit (Cunit_Entity (U))
1681
1682               --  If debug flag d.m is set, only the main source is listed
1683
1684               and then (U = Main_Unit or else not Debug_Flag_Dot_M)
1685
1686               --  If the unit of the entity does not come from source, it is
1687               --  an implicit subprogram declaration for a child subprogram.
1688               --  Do not emit errors for it, they are listed with the body.
1689
1690               and then
1691                 (No (Cunit_Entity (U))
1692                    or else Comes_From_Source (Cunit_Entity (U))
1693                    or else not Is_Subprogram (Cunit_Entity (U)))
1694             then
1695                declare
1696                   Sfile : constant Source_File_Index := Source_Index (U);
1697
1698                begin
1699                   Write_Eol;
1700                   Write_Header (Sfile);
1701                   Write_Eol;
1702
1703                   --  Normally, we don't want an "error messages from file"
1704                   --  message when listing the entire file, so we set the
1705                   --  current source file as the current error source file.
1706                   --  However, the old style of doing things was to list this
1707                   --  message if pragma Source_Reference is present, even for
1708                   --  the main unit. Since the purpose of the -gnatd.m switch
1709                   --  is to duplicate the old behavior, we skip the reset if
1710                   --  this debug flag is set.
1711
1712                   if not Debug_Flag_Dot_M then
1713                      Current_Error_Source_File := Sfile;
1714                   end if;
1715
1716                   for N in 1 .. Last_Source_Line (Sfile) loop
1717                      while E /= No_Error_Msg
1718                        and then Errors.Table (E).Deleted
1719                      loop
1720                         E := Errors.Table (E).Next;
1721                      end loop;
1722
1723                      Err_Flag :=
1724                        E /= No_Error_Msg
1725                          and then Errors.Table (E).Line = N
1726                          and then Errors.Table (E).Sfile = Sfile;
1727
1728                      Output_Source_Line (N, Sfile, Err_Flag);
1729
1730                      if Err_Flag then
1731                         Output_Error_Msgs (E);
1732
1733                         if not Debug_Flag_2 then
1734                            Write_Eol;
1735                         end if;
1736                      end if;
1737                   end loop;
1738                end;
1739             end if;
1740          end loop;
1741
1742          --  Then output errors, if any, for subsidiary units not in the
1743          --  main extended unit.
1744
1745          --  Note: if debug flag d.m set, include errors for any units other
1746          --  than the main unit in the extended source unit (e.g. spec and
1747          --  subunits for a body).
1748
1749          while E /= No_Error_Msg
1750            and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr)
1751                        or else
1752                         (Debug_Flag_Dot_M
1753                           and then Get_Source_Unit
1754                                      (Errors.Table (E).Sptr) /= Main_Unit))
1755          loop
1756             if Errors.Table (E).Deleted then
1757                E := Errors.Table (E).Next;
1758
1759             else
1760                Write_Eol;
1761                Output_Source_Line
1762                  (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
1763                Output_Error_Msgs (E);
1764             end if;
1765          end loop;
1766
1767          --  If output to file, write extra copy of error summary to the
1768          --  output file, and then close it.
1769
1770          if Full_List_File_Name /= null then
1771             Write_Error_Summary;
1772             Write_Max_Errors;
1773             Close_List_File_Access.all;
1774             Cancel_Special_Output;
1775          end if;
1776       end if;
1777
1778       --  Verbose mode (error lines only with error flags). Normally this is
1779       --  ignored in full list mode, unless we are listing to a file, in which
1780       --  case we still generate -gnatv output to standard output.
1781
1782       if Verbose_Mode
1783         and then (not Full_List or else Full_List_File_Name /= null)
1784       then
1785          Write_Eol;
1786          Write_Header (Main_Source_File);
1787          E := First_Error_Msg;
1788
1789          --  Loop through error lines
1790
1791          while E /= No_Error_Msg loop
1792             if Errors.Table (E).Deleted then
1793                E := Errors.Table (E).Next;
1794             else
1795                Write_Eol;
1796                Output_Source_Line
1797                  (Errors.Table (E).Line, Errors.Table (E).Sfile, True);
1798                Output_Error_Msgs (E);
1799             end if;
1800          end loop;
1801       end if;
1802
1803       --  Output error summary if verbose or full list mode
1804
1805       if Verbose_Mode or else Full_List then
1806          Write_Error_Summary;
1807       end if;
1808
1809       Write_Max_Errors;
1810
1811       if Warning_Mode = Treat_As_Error then
1812          Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
1813          Warnings_Detected := 0;
1814       end if;
1815    end Output_Messages;
1816
1817    ------------------------
1818    -- Output_Source_Line --
1819    ------------------------
1820
1821    procedure Output_Source_Line
1822      (L     : Physical_Line_Number;
1823       Sfile : Source_File_Index;
1824       Errs  : Boolean)
1825    is
1826       S : Source_Ptr;
1827       C : Character;
1828
1829       Line_Number_Output : Boolean := False;
1830       --  Set True once line number is output
1831
1832       Empty_Line : Boolean := True;
1833       --  Set False if line includes at least one character
1834
1835    begin
1836       if Sfile /= Current_Error_Source_File then
1837          Write_Str ("==============Error messages for ");
1838
1839          case Sinput.File_Type (Sfile) is
1840             when Sinput.Src =>
1841                Write_Str ("source");
1842
1843             when Sinput.Config =>
1844                Write_Str ("configuration pragmas");
1845
1846             when Sinput.Def =>
1847                Write_Str ("symbol definition");
1848
1849             when Sinput.Preproc =>
1850                Write_Str ("preprocessing data");
1851          end case;
1852
1853          Write_Str (" file: ");
1854          Write_Name (Full_File_Name (Sfile));
1855          Write_Eol;
1856
1857          if Num_SRef_Pragmas (Sfile) > 0 then
1858             Write_Str ("--------------Line numbers from file: ");
1859             Write_Name (Full_Ref_Name (Sfile));
1860             Write_Str (" (starting at line ");
1861             Write_Int (Int (First_Mapped_Line (Sfile)));
1862             Write_Char (')');
1863             Write_Eol;
1864          end if;
1865
1866          Current_Error_Source_File := Sfile;
1867       end if;
1868
1869       if Errs or List_Pragmas_Mode then
1870          Output_Line_Number (Physical_To_Logical (L, Sfile));
1871          Line_Number_Output := True;
1872       end if;
1873
1874       S := Line_Start (L, Sfile);
1875
1876       loop
1877          C := Source_Text (Sfile) (S);
1878          exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF;
1879
1880          --  Deal with matching entry in List_Pragmas table
1881
1882          if Full_List
1883            and then List_Pragmas_Index <= List_Pragmas.Last
1884            and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc
1885          then
1886             case List_Pragmas.Table (List_Pragmas_Index).Ptyp is
1887                when Page =>
1888                   Write_Char (C);
1889
1890                   --  Ignore if on line with errors so that error flags
1891                   --  get properly listed with the error line .
1892
1893                   if not Errs then
1894                      Write_Char (ASCII.FF);
1895                   end if;
1896
1897                when List_On =>
1898                   List_Pragmas_Mode := True;
1899
1900                   if not Line_Number_Output then
1901                      Output_Line_Number (Physical_To_Logical (L, Sfile));
1902                      Line_Number_Output := True;
1903                   end if;
1904
1905                   Write_Char (C);
1906
1907                when List_Off =>
1908                   Write_Char (C);
1909                   List_Pragmas_Mode := False;
1910             end case;
1911
1912             List_Pragmas_Index := List_Pragmas_Index + 1;
1913
1914          --  Normal case (no matching entry in List_Pragmas table)
1915
1916          else
1917             if Errs or List_Pragmas_Mode then
1918                Write_Char (C);
1919             end if;
1920          end if;
1921
1922          Empty_Line := False;
1923          S := S + 1;
1924       end loop;
1925
1926       --  If we have output a source line, then add the line terminator, with
1927       --  training spaces preserved (so we output the line exactly as input).
1928
1929       if Line_Number_Output then
1930          if Empty_Line then
1931             Write_Eol;
1932          else
1933             Write_Eol_Keep_Blanks;
1934          end if;
1935       end if;
1936    end Output_Source_Line;
1937
1938    -----------------------------
1939    -- Remove_Warning_Messages --
1940    -----------------------------
1941
1942    procedure Remove_Warning_Messages (N : Node_Id) is
1943
1944       function Check_For_Warning (N : Node_Id) return Traverse_Result;
1945       --  This function checks one node for a possible warning message
1946
1947       function Check_All_Warnings is new Traverse_Func (Check_For_Warning);
1948       --  This defines the traversal operation
1949
1950       -----------------------
1951       -- Check_For_Warning --
1952       -----------------------
1953
1954       function Check_For_Warning (N : Node_Id) return Traverse_Result is
1955          Loc : constant Source_Ptr := Sloc (N);
1956          E   : Error_Msg_Id;
1957
1958          function To_Be_Removed (E : Error_Msg_Id) return Boolean;
1959          --  Returns True for a message that is to be removed. Also adjusts
1960          --  warning count appropriately.
1961
1962          -------------------
1963          -- To_Be_Removed --
1964          -------------------
1965
1966          function To_Be_Removed (E : Error_Msg_Id) return Boolean is
1967          begin
1968             if E /= No_Error_Msg
1969
1970                --  Don't remove if location does not match
1971
1972                and then Errors.Table (E).Optr = Loc
1973
1974                --  Don't remove if not warning/info message. Note that we do
1975                --  not remove style messages here. They are warning messages
1976                --  but not ones we want removed in this context.
1977
1978                and then Errors.Table (E).Warn
1979
1980                --  Don't remove unconditional messages
1981
1982                and then not Errors.Table (E).Uncond
1983             then
1984                Warnings_Detected := Warnings_Detected - 1;
1985                return True;
1986
1987             --  No removal required
1988
1989             else
1990                return False;
1991             end if;
1992          end To_Be_Removed;
1993
1994       --  Start of processing for Check_For_Warnings
1995
1996       begin
1997          while To_Be_Removed (First_Error_Msg) loop
1998             First_Error_Msg := Errors.Table (First_Error_Msg).Next;
1999          end loop;
2000
2001          if First_Error_Msg = No_Error_Msg then
2002             Last_Error_Msg := No_Error_Msg;
2003          end if;
2004
2005          E := First_Error_Msg;
2006          while E /= No_Error_Msg loop
2007             while To_Be_Removed (Errors.Table (E).Next) loop
2008                Errors.Table (E).Next :=
2009                  Errors.Table (Errors.Table (E).Next).Next;
2010
2011                if Errors.Table (E).Next = No_Error_Msg then
2012                   Last_Error_Msg := E;
2013                end if;
2014             end loop;
2015
2016             E := Errors.Table (E).Next;
2017          end loop;
2018
2019          if Nkind (N) = N_Raise_Constraint_Error
2020            and then Original_Node (N) /= N
2021            and then No (Condition (N))
2022          then
2023             --  Warnings may have been posted on subexpressions of the original
2024             --  tree. We place the original node back on the tree to remove
2025             --  those warnings, whose sloc do not match those of any node in
2026             --  the current tree. Given that we are in unreachable code, this
2027             --  modification to the tree is harmless.
2028
2029             declare
2030                Status : Traverse_Final_Result;
2031
2032             begin
2033                if Is_List_Member (N) then
2034                   Set_Condition (N, Original_Node (N));
2035                   Status := Check_All_Warnings (Condition (N));
2036                else
2037                   Rewrite (N, Original_Node (N));
2038                   Status := Check_All_Warnings (N);
2039                end if;
2040
2041                return Status;
2042             end;
2043
2044          else
2045             return OK;
2046          end if;
2047       end Check_For_Warning;
2048
2049    --  Start of processing for Remove_Warning_Messages
2050
2051    begin
2052       if Warnings_Detected /= 0 then
2053          declare
2054             Discard : Traverse_Final_Result;
2055             pragma Warnings (Off, Discard);
2056
2057          begin
2058             Discard := Check_All_Warnings (N);
2059          end;
2060       end if;
2061    end Remove_Warning_Messages;
2062
2063    procedure Remove_Warning_Messages (L : List_Id) is
2064       Stat : Node_Id;
2065    begin
2066       if Is_Non_Empty_List (L) then
2067          Stat := First (L);
2068          while Present (Stat) loop
2069             Remove_Warning_Messages (Stat);
2070             Next (Stat);
2071          end loop;
2072       end if;
2073    end Remove_Warning_Messages;
2074
2075    ---------------------------
2076    -- Set_Identifier_Casing --
2077    ---------------------------
2078
2079    procedure Set_Identifier_Casing
2080      (Identifier_Name : System.Address;
2081       File_Name       : System.Address)
2082    is
2083       Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name);
2084       File  : constant Big_String_Ptr := To_Big_String_Ptr (File_Name);
2085       Flen  : Natural;
2086
2087       Desired_Case : Casing_Type := Mixed_Case;
2088       --  Casing required for result. Default value of Mixed_Case is used if
2089       --  for some reason we cannot find the right file name in the table.
2090
2091    begin
2092       --  Get length of file name
2093
2094       Flen := 0;
2095       while File (Flen + 1) /= ASCII.NUL loop
2096          Flen := Flen + 1;
2097       end loop;
2098
2099       --  Loop through file names to find matching one. This is a bit slow, but
2100       --  we only do it in error situations so it is not so terrible. Note that
2101       --  if the loop does not exit, then the desired case will be left set to
2102       --  Mixed_Case, this can happen if the name was not in canonical form,
2103       --  and gets canonicalized on VMS. Possibly we could fix this by
2104       --  unconditinally canonicalizing these names ???
2105
2106       for J in 1 .. Last_Source_File loop
2107          Get_Name_String (Full_Debug_Name (J));
2108
2109          if Name_Len = Flen
2110            and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen))
2111          then
2112             Desired_Case := Identifier_Casing (J);
2113             exit;
2114          end if;
2115       end loop;
2116
2117       --  Copy identifier as given to Name_Buffer
2118
2119       for J in Name_Buffer'Range loop
2120          Name_Buffer (J) := Ident (J);
2121
2122          if Name_Buffer (J) = ASCII.NUL then
2123             Name_Len := J - 1;
2124             exit;
2125          end if;
2126       end loop;
2127
2128       Set_Casing (Desired_Case);
2129    end Set_Identifier_Casing;
2130
2131    -----------------------
2132    -- Set_Ignore_Errors --
2133    -----------------------
2134
2135    procedure Set_Ignore_Errors (To : Boolean) is
2136    begin
2137       Errors_Must_Be_Ignored := To;
2138    end Set_Ignore_Errors;
2139
2140    ------------------------------
2141    -- Set_Msg_Insertion_Column --
2142    ------------------------------
2143
2144    procedure Set_Msg_Insertion_Column is
2145    begin
2146       if RM_Column_Check then
2147          Set_Msg_Str (" in column ");
2148          Set_Msg_Int (Int (Error_Msg_Col) + 1);
2149       end if;
2150    end Set_Msg_Insertion_Column;
2151
2152    ----------------------------
2153    -- Set_Msg_Insertion_Node --
2154    ----------------------------
2155
2156    procedure Set_Msg_Insertion_Node is
2157       K : Node_Kind;
2158
2159    begin
2160       Suppress_Message :=
2161         Error_Msg_Node_1 = Error
2162           or else Error_Msg_Node_1 = Any_Type;
2163
2164       if Error_Msg_Node_1 = Empty then
2165          Set_Msg_Blank_Conditional;
2166          Set_Msg_Str ("<empty>");
2167
2168       elsif Error_Msg_Node_1 = Error then
2169          Set_Msg_Blank;
2170          Set_Msg_Str ("<error>");
2171
2172       elsif Error_Msg_Node_1 = Standard_Void_Type then
2173          Set_Msg_Blank;
2174          Set_Msg_Str ("procedure name");
2175
2176       else
2177          Set_Msg_Blank_Conditional;
2178
2179          --  Output name
2180
2181          K := Nkind (Error_Msg_Node_1);
2182
2183          --  If we have operator case, skip quotes since name of operator
2184          --  itself will supply the required quotations. An operator can be an
2185          --  applied use in an expression or an explicit operator symbol, or an
2186          --  identifier whose name indicates it is an operator.
2187
2188          if K in N_Op
2189            or else K = N_Operator_Symbol
2190            or else K = N_Defining_Operator_Symbol
2191            or else ((K = N_Identifier or else K = N_Defining_Identifier)
2192                        and then Is_Operator_Name (Chars (Error_Msg_Node_1)))
2193          then
2194             Set_Msg_Node (Error_Msg_Node_1);
2195
2196          --  Normal case, not an operator, surround with quotes
2197
2198          else
2199             Set_Msg_Quote;
2200             Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1);
2201             Set_Msg_Node (Error_Msg_Node_1);
2202             Set_Msg_Quote;
2203          end if;
2204       end if;
2205
2206       --  The following assignment ensures that a second ampersand insertion
2207       --  character will correspond to the Error_Msg_Node_2 parameter. We
2208       --  suppress possible validity checks in case operating in -gnatVa mode,
2209       --  and Error_Msg_Node_2 is not needed and has not been set.
2210
2211       declare
2212          pragma Suppress (Range_Check);
2213       begin
2214          Error_Msg_Node_1 := Error_Msg_Node_2;
2215       end;
2216    end Set_Msg_Insertion_Node;
2217
2218    --------------------------------------
2219    -- Set_Msg_Insertion_Type_Reference --
2220    --------------------------------------
2221
2222    procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is
2223       Ent : Entity_Id;
2224
2225    begin
2226       Set_Msg_Blank;
2227
2228       if Error_Msg_Node_1 = Standard_Void_Type then
2229          Set_Msg_Str ("package or procedure name");
2230          return;
2231
2232       elsif Error_Msg_Node_1 = Standard_Exception_Type then
2233          Set_Msg_Str ("exception name");
2234          return;
2235
2236       elsif     Error_Msg_Node_1 = Any_Access
2237         or else Error_Msg_Node_1 = Any_Array
2238         or else Error_Msg_Node_1 = Any_Boolean
2239         or else Error_Msg_Node_1 = Any_Character
2240         or else Error_Msg_Node_1 = Any_Composite
2241         or else Error_Msg_Node_1 = Any_Discrete
2242         or else Error_Msg_Node_1 = Any_Fixed
2243         or else Error_Msg_Node_1 = Any_Integer
2244         or else Error_Msg_Node_1 = Any_Modular
2245         or else Error_Msg_Node_1 = Any_Numeric
2246         or else Error_Msg_Node_1 = Any_Real
2247         or else Error_Msg_Node_1 = Any_Scalar
2248         or else Error_Msg_Node_1 = Any_String
2249       then
2250          Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1));
2251          Set_Msg_Name_Buffer;
2252          return;
2253
2254       elsif Error_Msg_Node_1 = Universal_Real then
2255          Set_Msg_Str ("type universal real");
2256          return;
2257
2258       elsif Error_Msg_Node_1 = Universal_Integer then
2259          Set_Msg_Str ("type universal integer");
2260          return;
2261
2262       elsif Error_Msg_Node_1 = Universal_Fixed then
2263          Set_Msg_Str ("type universal fixed");
2264          return;
2265       end if;
2266
2267       --  Special case of anonymous array
2268
2269       if Nkind (Error_Msg_Node_1) in N_Entity
2270         and then Is_Array_Type (Error_Msg_Node_1)
2271         and then Present (Related_Array_Object (Error_Msg_Node_1))
2272       then
2273          Set_Msg_Str ("type of ");
2274          Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1));
2275          Set_Msg_Str (" declared");
2276          Set_Msg_Insertion_Line_Number
2277            (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag);
2278          return;
2279       end if;
2280
2281       --  If we fall through, it is not a special case, so first output
2282       --  the name of the type, preceded by private for a private type
2283
2284       if Is_Private_Type (Error_Msg_Node_1) then
2285          Set_Msg_Str ("private type ");
2286       else
2287          Set_Msg_Str ("type ");
2288       end if;
2289
2290       Ent := Error_Msg_Node_1;
2291
2292       if Is_Internal_Name (Chars (Ent)) then
2293          Unwind_Internal_Type (Ent);
2294       end if;
2295
2296       --  Types in Standard are displayed as "Standard.name"
2297
2298       if Sloc (Ent) <= Standard_Location then
2299          Set_Msg_Quote;
2300          Set_Msg_Str ("Standard.");
2301          Set_Msg_Node (Ent);
2302          Add_Class;
2303          Set_Msg_Quote;
2304
2305       --  Types in other language defined units are displayed as
2306       --  "package-name.type-name"
2307
2308       elsif
2309         Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Ent)))
2310       then
2311          Get_Unqualified_Decoded_Name_String
2312            (Unit_Name (Get_Source_Unit (Ent)));
2313          Name_Len := Name_Len - 2;
2314          Set_Msg_Quote;
2315          Set_Casing (Mixed_Case);
2316          Set_Msg_Name_Buffer;
2317          Set_Msg_Char ('.');
2318          Set_Casing (Mixed_Case);
2319          Set_Msg_Node (Ent);
2320          Add_Class;
2321          Set_Msg_Quote;
2322
2323       --  All other types display as "type name" defined at line xxx
2324       --  possibly qualified if qualification is requested.
2325
2326       else
2327          Set_Msg_Quote;
2328          Set_Qualification (Error_Msg_Qual_Level, Ent);
2329          Set_Msg_Node (Ent);
2330          Add_Class;
2331
2332          --  If Ent is an anonymous subprogram type, there is no name to print,
2333          --  so remove enclosing quotes.
2334
2335          if Buffer_Ends_With ("""") then
2336             Buffer_Remove ("""");
2337          else
2338             Set_Msg_Quote;
2339          end if;
2340       end if;
2341
2342       --  If the original type did not come from a predefined file, add the
2343       --  location where the type was defined.
2344
2345       if Sloc (Error_Msg_Node_1) > Standard_Location
2346         and then
2347           not Is_Predefined_File_Name
2348                 (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1)))
2349       then
2350          Set_Msg_Str (" defined");
2351          Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag);
2352
2353       --  If it did come from a predefined file, deal with the case where
2354       --  this was a file with a generic instantiation from elsewhere.
2355
2356       else
2357          if Sloc (Error_Msg_Node_1) > Standard_Location then
2358             declare
2359                Iloc : constant Source_Ptr :=
2360                         Instantiation_Location (Sloc (Error_Msg_Node_1));
2361
2362             begin
2363                if Iloc /= No_Location
2364                  and then not Suppress_Instance_Location
2365                then
2366                   Set_Msg_Str (" from instance");
2367                   Set_Msg_Insertion_Line_Number (Iloc, Flag);
2368                end if;
2369             end;
2370          end if;
2371       end if;
2372    end Set_Msg_Insertion_Type_Reference;
2373
2374    ---------------------------------
2375    -- Set_Msg_Insertion_Unit_Name --
2376    ---------------------------------
2377
2378    procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is
2379    begin
2380       if Error_Msg_Unit_1 = No_Unit_Name then
2381          null;
2382
2383       elsif Error_Msg_Unit_1 = Error_Unit_Name then
2384          Set_Msg_Blank;
2385          Set_Msg_Str ("<error>");
2386
2387       else
2388          Get_Unit_Name_String (Error_Msg_Unit_1, Suffix);
2389          Set_Msg_Blank;
2390          Set_Msg_Quote;
2391          Set_Msg_Name_Buffer;
2392          Set_Msg_Quote;
2393       end if;
2394
2395       --  The following assignment ensures that a second percent insertion
2396       --  character will correspond to the Error_Msg_Unit_2 parameter. We
2397       --  suppress possible validity checks in case operating in -gnatVa mode,
2398       --  and Error_Msg_Unit_2 is not needed and has not been set.
2399
2400       declare
2401          pragma Suppress (Range_Check);
2402       begin
2403          Error_Msg_Unit_1 := Error_Msg_Unit_2;
2404       end;
2405    end Set_Msg_Insertion_Unit_Name;
2406
2407    ------------------
2408    -- Set_Msg_Node --
2409    ------------------
2410
2411    procedure Set_Msg_Node (Node : Node_Id) is
2412       Ent : Entity_Id;
2413       Nam : Name_Id;
2414
2415    begin
2416       if Nkind (Node) = N_Designator then
2417          Set_Msg_Node (Name (Node));
2418          Set_Msg_Char ('.');
2419          Set_Msg_Node (Identifier (Node));
2420          return;
2421
2422       elsif Nkind (Node) = N_Defining_Program_Unit_Name then
2423          Set_Msg_Node (Name (Node));
2424          Set_Msg_Char ('.');
2425          Set_Msg_Node (Defining_Identifier (Node));
2426          return;
2427
2428       elsif Nkind (Node) = N_Selected_Component then
2429          Set_Msg_Node (Prefix (Node));
2430          Set_Msg_Char ('.');
2431          Set_Msg_Node (Selector_Name (Node));
2432          return;
2433       end if;
2434
2435       --  The only remaining possibilities are identifiers, defining
2436       --  identifiers, pragmas, and pragma argument associations.
2437
2438       if Nkind (Node) = N_Pragma then
2439          Nam := Pragma_Name (Node);
2440
2441       --  The other cases have Chars fields, and we want to test for possible
2442       --  internal names, which generally represent something gone wrong. An
2443       --  exception is the case of internal type names, where we try to find a
2444       --  reasonable external representation for the external name
2445
2446       elsif Is_Internal_Name (Chars (Node))
2447         and then
2448           ((Is_Entity_Name (Node)
2449                           and then Present (Entity (Node))
2450                           and then Is_Type (Entity (Node)))
2451               or else
2452            (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node)))
2453       then
2454          if Nkind (Node) = N_Identifier then
2455             Ent := Entity (Node);
2456          else
2457             Ent := Node;
2458          end if;
2459
2460          --  If the type is the designated type of an access_to_subprogram,
2461          --  there is no name to provide in the call.
2462
2463          if Ekind (Ent) = E_Subprogram_Type then
2464             return;
2465          else
2466             Unwind_Internal_Type (Ent);
2467             Nam := Chars (Ent);
2468          end if;
2469
2470       --  If not internal name, just use name in Chars field
2471
2472       else
2473          Nam := Chars (Node);
2474       end if;
2475
2476       --  At this stage, the name to output is in Nam
2477
2478       Get_Unqualified_Decoded_Name_String (Nam);
2479
2480       --  Remove trailing upper case letters from the name (useful for
2481       --  dealing with some cases of internal names.
2482
2483       while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop
2484          Name_Len := Name_Len  - 1;
2485       end loop;
2486
2487       --  If we have any of the names from standard that start with the
2488       --  characters "any " (e.g. Any_Type), then kill the message since
2489       --  almost certainly it is a junk cascaded message.
2490
2491       if Name_Len > 4
2492         and then Name_Buffer (1 .. 4) = "any "
2493       then
2494          Kill_Message := True;
2495       end if;
2496
2497       --  Now we have to set the proper case. If we have a source location
2498       --  then do a check to see if the name in the source is the same name
2499       --  as the name in the Names table, except for possible differences
2500       --  in case, which is the case when we can copy from the source.
2501
2502       declare
2503          Src_Loc : constant Source_Ptr := Sloc (Node);
2504          Sbuffer : Source_Buffer_Ptr;
2505          Ref_Ptr : Integer;
2506          Src_Ptr : Source_Ptr;
2507
2508       begin
2509          Ref_Ptr := 1;
2510          Src_Ptr := Src_Loc;
2511
2512          --  For standard locations, always use mixed case
2513
2514          if Src_Loc <= No_Location
2515            or else Sloc (Node) <= No_Location
2516          then
2517             Set_Casing (Mixed_Case);
2518
2519          else
2520             --  Determine if the reference we are dealing with corresponds to
2521             --  text at the point of the error reference. This will often be
2522             --  the case for simple identifier references, and is the case
2523             --  where we can copy the spelling from the source.
2524
2525             Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc));
2526
2527             while Ref_Ptr <= Name_Len loop
2528                exit when
2529                  Fold_Lower (Sbuffer (Src_Ptr)) /=
2530                  Fold_Lower (Name_Buffer (Ref_Ptr));
2531                Ref_Ptr := Ref_Ptr + 1;
2532                Src_Ptr := Src_Ptr + 1;
2533             end loop;
2534
2535             --  If we get through the loop without a mismatch, then output the
2536             --  name the way it is spelled in the source program
2537
2538             if Ref_Ptr > Name_Len then
2539                Src_Ptr := Src_Loc;
2540
2541                for J in 1 .. Name_Len loop
2542                   Name_Buffer (J) := Sbuffer (Src_Ptr);
2543                   Src_Ptr := Src_Ptr + 1;
2544                end loop;
2545
2546             --  Otherwise set the casing using the default identifier casing
2547
2548             else
2549                Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
2550             end if;
2551          end if;
2552       end;
2553
2554       Set_Msg_Name_Buffer;
2555       Add_Class;
2556    end Set_Msg_Node;
2557
2558    ------------------
2559    -- Set_Msg_Text --
2560    ------------------
2561
2562    procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is
2563       C : Character;   -- Current character
2564       P : Natural;     -- Current index;
2565
2566    begin
2567       Manual_Quote_Mode := False;
2568       Is_Unconditional_Msg := False;
2569       Msglen := 0;
2570       Flag_Source := Get_Source_File_Index (Flag);
2571
2572       P := Text'First;
2573       while P <= Text'Last loop
2574          C := Text (P);
2575          P := P + 1;
2576
2577          --  Check for insertion character or sequence
2578
2579          case C is
2580             when '%' =>
2581                if P <= Text'Last and then Text (P) = '%' then
2582                   P := P + 1;
2583                   Set_Msg_Insertion_Name_Literal;
2584                else
2585                   Set_Msg_Insertion_Name;
2586                end if;
2587
2588             when '$' =>
2589                if P <= Text'Last and then Text (P) = '$' then
2590                   P := P + 1;
2591                   Set_Msg_Insertion_Unit_Name (Suffix => False);
2592
2593                else
2594                   Set_Msg_Insertion_Unit_Name;
2595                end if;
2596
2597             when '{' =>
2598                Set_Msg_Insertion_File_Name;
2599
2600             when '}' =>
2601                Set_Msg_Insertion_Type_Reference (Flag);
2602
2603             when '*' =>
2604                Set_Msg_Insertion_Reserved_Name;
2605
2606             when '&' =>
2607                Set_Msg_Insertion_Node;
2608
2609             when '#' =>
2610                Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag);
2611
2612             when '\' =>
2613                Continuation := True;
2614
2615                if Text (P) = '\' then
2616                   Continuation_New_Line := True;
2617                   P := P + 1;
2618                end if;
2619
2620             when '@' =>
2621                Set_Msg_Insertion_Column;
2622
2623             when '>' =>
2624                Set_Msg_Insertion_Run_Time_Name;
2625
2626             when '^' =>
2627                Set_Msg_Insertion_Uint;
2628
2629             when '`' =>
2630                Manual_Quote_Mode := not Manual_Quote_Mode;
2631                Set_Msg_Char ('"');
2632
2633             when '!' =>
2634                Is_Unconditional_Msg := True;
2635
2636             when '?' =>
2637                null; -- already dealt with
2638
2639             when '<' =>
2640                null; -- already dealt with
2641
2642             when '|' =>
2643                null; -- already dealt with
2644
2645             when ''' =>
2646                Set_Msg_Char (Text (P));
2647                P := P + 1;
2648
2649             when '~' =>
2650                Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
2651
2652             --  Upper case letter
2653
2654             when 'A' .. 'Z' =>
2655
2656                --  Start of reserved word if two or more
2657
2658                if P <= Text'Last and then Text (P) in 'A' .. 'Z' then
2659                   P := P - 1;
2660                   Set_Msg_Insertion_Reserved_Word (Text, P);
2661
2662                --  Single upper case letter is just inserted
2663
2664                else
2665                   Set_Msg_Char (C);
2666                end if;
2667
2668             --  Normal character with no special treatment
2669
2670             when others =>
2671                Set_Msg_Char (C);
2672          end case;
2673       end loop;
2674
2675       VMS_Convert;
2676    end Set_Msg_Text;
2677
2678    ----------------
2679    -- Set_Posted --
2680    ----------------
2681
2682    procedure Set_Posted (N : Node_Id) is
2683       P : Node_Id;
2684
2685    begin
2686       if Is_Serious_Error then
2687
2688          --  We always set Error_Posted on the node itself
2689
2690          Set_Error_Posted (N);
2691
2692          --  If it is a subexpression, then set Error_Posted on parents up to
2693          --  and including the first non-subexpression construct. This helps
2694          --  avoid cascaded error messages within a single expression.
2695
2696          P := N;
2697          loop
2698             P := Parent (P);
2699             exit when No (P);
2700             Set_Error_Posted (P);
2701             exit when Nkind (P) not in N_Subexpr;
2702          end loop;
2703
2704          --  A special check, if we just posted an error on an attribute
2705          --  definition clause, then also set the entity involved as posted.
2706          --  For example, this stops complaining about the alignment after
2707          --  complaining about the size, which is likely to be useless.
2708
2709          if Nkind (P) = N_Attribute_Definition_Clause then
2710             if Is_Entity_Name (Name (P)) then
2711                Set_Error_Posted (Entity (Name (P)));
2712             end if;
2713          end if;
2714       end if;
2715    end Set_Posted;
2716
2717    -----------------------
2718    -- Set_Qualification --
2719    -----------------------
2720
2721    procedure Set_Qualification (N : Nat; E : Entity_Id) is
2722    begin
2723       if N /= 0 and then Scope (E) /= Standard_Standard then
2724          Set_Qualification (N - 1, Scope (E));
2725          Set_Msg_Node (Scope (E));
2726          Set_Msg_Char ('.');
2727       end if;
2728    end Set_Qualification;
2729
2730    ------------------------
2731    -- Special_Msg_Delete --
2732    ------------------------
2733
2734    --  Is it really right to have all this specialized knowledge in errout?
2735
2736    function Special_Msg_Delete
2737      (Msg : String;
2738       N   : Node_Or_Entity_Id;
2739       E   : Node_Or_Entity_Id) return Boolean
2740    is
2741    begin
2742       --  Never delete messages in -gnatdO mode
2743
2744       if Debug_Flag_OO then
2745          return False;
2746
2747       --  Processing for "atomic access cannot be guaranteed"
2748
2749       elsif Msg = "atomic access to & cannot be guaranteed" then
2750
2751          --  When an atomic object refers to a non-atomic type in the same
2752          --  scope, we implicitly make the type atomic. In the non-error case
2753          --  this is surely safe (and in fact prevents an error from occurring
2754          --  if the type is not atomic by default). But if the object cannot be
2755          --  made atomic, then we introduce an extra junk message by this
2756          --  manipulation, which we get rid of here.
2757
2758          --  We identify this case by the fact that it references a type for
2759          --  which Is_Atomic is set, but there is no Atomic pragma setting it.
2760
2761          if Is_Type (E)
2762            and then Is_Atomic (E)
2763            and then No (Get_Rep_Pragma (E, Name_Atomic))
2764          then
2765             return True;
2766          end if;
2767
2768       --  Processing for "Size too small" messages
2769
2770       elsif Msg = "size for& too small, minimum allowed is ^" then
2771
2772          --  Suppress "size too small" errors in CodePeer mode, since pragma
2773          --  Pack is also ignored in this configuration.
2774
2775          if CodePeer_Mode then
2776             return True;
2777
2778          --  When a size is wrong for a frozen type there is no explicit size
2779          --  clause, and other errors have occurred, suppress the message,
2780          --  since it is likely that this size error is a cascaded result of
2781          --  other errors. The reason we eliminate unfrozen types is that
2782          --  messages issued before the freeze type are for sure OK.
2783
2784          elsif Is_Frozen (E)
2785            and then Serious_Errors_Detected > 0
2786            and then Nkind (N) /= N_Component_Clause
2787            and then Nkind (Parent (N)) /= N_Component_Clause
2788            and then
2789              No (Get_Attribute_Definition_Clause (E, Attribute_Size))
2790            and then
2791              No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size))
2792            and then
2793              No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size))
2794          then
2795             return True;
2796          end if;
2797       end if;
2798
2799       --  All special tests complete, so go ahead with message
2800
2801       return False;
2802    end Special_Msg_Delete;
2803
2804    --------------------------
2805    -- Unwind_Internal_Type --
2806    --------------------------
2807
2808    procedure Unwind_Internal_Type (Ent : in out Entity_Id) is
2809       Derived : Boolean := False;
2810       Mchar   : Character;
2811       Old_Ent : Entity_Id;
2812
2813    begin
2814       --  Undo placement of a quote, since we will put it back later
2815
2816       Mchar := Msg_Buffer (Msglen);
2817
2818       if Mchar = '"' then
2819          Msglen := Msglen - 1;
2820       end if;
2821
2822       --  The loop here deals with recursive types, we are trying to find a
2823       --  related entity that is not an implicit type. Note that the check with
2824       --  Old_Ent stops us from getting "stuck". Also, we don't output the
2825       --  "type derived from" message more than once in the case where we climb
2826       --  up multiple levels.
2827
2828       Find : loop
2829          Old_Ent := Ent;
2830
2831          --  Implicit access type, use directly designated type In Ada 2005,
2832          --  the designated type may be an anonymous access to subprogram, in
2833          --  which case we can only point to its definition.
2834
2835          if Is_Access_Type (Ent) then
2836             if Ekind (Ent) = E_Access_Subprogram_Type
2837               or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type
2838               or else Is_Access_Protected_Subprogram_Type (Ent)
2839             then
2840                Ent := Directly_Designated_Type (Ent);
2841
2842                if not Comes_From_Source (Ent) then
2843                   if Buffer_Ends_With ("type ") then
2844                      Buffer_Remove ("type ");
2845                   end if;
2846
2847                   if Is_Itype (Ent) then
2848                      declare
2849                         Assoc : constant Node_Id :=
2850                                   Associated_Node_For_Itype (Ent);
2851
2852                      begin
2853                         if Nkind (Assoc) in N_Subprogram_Specification then
2854
2855                            --  Anonymous access to subprogram in a signature.
2856                            --  Indicate the enclosing subprogram.
2857
2858                            Ent :=
2859                              Defining_Unit_Name
2860                                (Associated_Node_For_Itype (Ent));
2861                            Set_Msg_Str
2862                              ("access to subprogram declared in profile of ");
2863
2864                         else
2865                            Set_Msg_Str ("access to subprogram with profile ");
2866                         end if;
2867                      end;
2868                   end if;
2869
2870                elsif Ekind (Ent) = E_Function then
2871                   Set_Msg_Str ("access to function ");
2872                else
2873                   Set_Msg_Str ("access to procedure ");
2874                end if;
2875
2876                exit Find;
2877
2878             --  Type is access to object, named or anonymous
2879
2880             else
2881                Set_Msg_Str ("access to ");
2882                Ent := Directly_Designated_Type (Ent);
2883             end if;
2884
2885          --  Classwide type
2886
2887          elsif Is_Class_Wide_Type (Ent) then
2888             Class_Flag := True;
2889             Ent := Root_Type (Ent);
2890
2891          --  Use base type if this is a subtype
2892
2893          elsif Ent /= Base_Type (Ent) then
2894             Buffer_Remove ("type ");
2895
2896             --  Avoid duplication "subtype of subtype of", and also replace
2897             --  "derived from subtype of" simply by "derived from"
2898
2899             if not Buffer_Ends_With ("subtype of ")
2900               and then not Buffer_Ends_With ("derived from ")
2901             then
2902                Set_Msg_Str ("subtype of ");
2903             end if;
2904
2905             Ent := Base_Type (Ent);
2906
2907          --  If this is a base type with a first named subtype, use the first
2908          --  named subtype instead. This is not quite accurate in all cases,
2909          --  but it makes too much noise to be accurate and add 'Base in all
2910          --  cases. Note that we only do this is the first named subtype is not
2911          --  itself an internal name. This avoids the obvious loop (subtype ->
2912          --  basetype -> subtype) which would otherwise occur!)
2913
2914          else
2915             declare
2916                FST : constant Entity_Id := First_Subtype (Ent);
2917
2918             begin
2919                if not Is_Internal_Name (Chars (FST)) then
2920                   Ent := FST;
2921                   exit Find;
2922
2923                   --  Otherwise use root type
2924
2925                else
2926                   if not Derived then
2927                      Buffer_Remove ("type ");
2928
2929                      --  Test for "subtype of type derived from" which seems
2930                      --  excessive and is replaced by "type derived from".
2931
2932                      Buffer_Remove ("subtype of");
2933
2934                      --  Avoid duplicated "type derived from type derived from"
2935
2936                      if not Buffer_Ends_With ("type derived from ") then
2937                         Set_Msg_Str ("type derived from ");
2938                      end if;
2939
2940                      Derived := True;
2941                   end if;
2942                end if;
2943             end;
2944
2945             Ent := Etype (Ent);
2946          end if;
2947
2948          --  If we are stuck in a loop, get out and settle for the internal
2949          --  name after all. In this case we set to kill the message if it is
2950          --  not the first error message (we really try hard not to show the
2951          --  dirty laundry of the implementation to the poor user!)
2952
2953          if Ent = Old_Ent then
2954             Kill_Message := True;
2955             exit Find;
2956          end if;
2957
2958          --  Get out if we finally found a non-internal name to use
2959
2960          exit Find when not Is_Internal_Name (Chars (Ent));
2961       end loop Find;
2962
2963       if Mchar = '"' then
2964          Set_Msg_Char ('"');
2965       end if;
2966    end Unwind_Internal_Type;
2967
2968    -----------------
2969    -- VMS_Convert --
2970    -----------------
2971
2972    procedure VMS_Convert is
2973       P : Natural;
2974       L : Natural;
2975       N : Natural;
2976
2977    begin
2978       if not OpenVMS then
2979          return;
2980       end if;
2981
2982       P := Msg_Buffer'First;
2983       loop
2984          if P >= Msglen then
2985             return;
2986          end if;
2987
2988          if Msg_Buffer (P) = '-' then
2989             for G in Gnames'Range loop
2990                L := Gnames (G)'Length;
2991
2992                --  See if we have "-ggg switch", where ggg is Gnames entry
2993
2994                if P + L + 7 <= Msglen
2995                  and then Msg_Buffer (P + 1 .. P + L) = Gnames (G).all
2996                  and then Msg_Buffer (P + L + 1 .. P + L + 7) = " switch"
2997                then
2998                   --  Replace by "/vvv qualifier", where vvv is Vnames entry
2999
3000                   N := Vnames (G)'Length;
3001                   Msg_Buffer (P + N + 11 .. Msglen + N - L + 3) :=
3002                     Msg_Buffer (P + L + 8 .. Msglen);
3003                   Msg_Buffer (P) := '/';
3004                   Msg_Buffer (P + 1 .. P + N) := Vnames (G).all;
3005                   Msg_Buffer (P + N + 1 .. P + N + 10) := " qualifier";
3006                   P := P + N + 10;
3007                   Msglen := Msglen + N - L + 3;
3008                   exit;
3009                end if;
3010             end loop;
3011          end if;
3012
3013          P := P + 1;
3014       end loop;
3015    end VMS_Convert;
3016
3017 end Errout;