OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [errout.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.