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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [erroutc.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 C                               --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2011, 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 Casing;   use Casing;
33
with Debug;    use Debug;
34
with Err_Vars; use Err_Vars;
35
with Namet;    use Namet;
36
with Opt;      use Opt;
37
with Output;   use Output;
38
with Sinput;   use Sinput;
39
with Snames;   use Snames;
40
with Targparm; use Targparm;
41
with Uintp;    use Uintp;
42
 
43
package body Erroutc is
44
 
45
   ---------------
46
   -- Add_Class --
47
   ---------------
48
 
49
   procedure Add_Class is
50
   begin
51
      if Class_Flag then
52
         Class_Flag := False;
53
         Set_Msg_Char (''');
54
         Get_Name_String (Name_Class);
55
         Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
56
         Set_Msg_Name_Buffer;
57
      end if;
58
   end Add_Class;
59
 
60
   ----------------------
61
   -- Buffer_Ends_With --
62
   ----------------------
63
 
64
   function Buffer_Ends_With (S : String) return Boolean is
65
      Len : constant Natural := S'Length;
66
   begin
67
      return
68
        Msglen > Len
69
          and then Msg_Buffer (Msglen - Len) = ' '
70
          and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
71
   end Buffer_Ends_With;
72
 
73
   -------------------
74
   -- Buffer_Remove --
75
   -------------------
76
 
77
   procedure Buffer_Remove (S : String) is
78
   begin
79
      if Buffer_Ends_With (S) then
80
         Msglen := Msglen - S'Length;
81
      end if;
82
   end Buffer_Remove;
83
 
84
   -----------------------------
85
   -- Check_Duplicate_Message --
86
   -----------------------------
87
 
88
   procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
89
      L1, L2 : Error_Msg_Id;
90
      N1, N2 : Error_Msg_Id;
91
 
92
      procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
93
      --  Called to delete message Delete, keeping message Keep. Marks
94
      --  all messages of Delete with deleted flag set to True, and also
95
      --  makes sure that for the error messages that are retained the
96
      --  preferred message is the one retained (we prefer the shorter
97
      --  one in the case where one has an Instance tag). Note that we
98
      --  always know that Keep has at least as many continuations as
99
      --  Delete (since we always delete the shorter sequence).
100
 
101
      ----------------
102
      -- Delete_Msg --
103
      ----------------
104
 
105
      procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
106
         D, K : Error_Msg_Id;
107
 
108
      begin
109
         D := Delete;
110
         K := Keep;
111
 
112
         loop
113
            Errors.Table (D).Deleted := True;
114
 
115
            --  Adjust error message count
116
 
117
            if Errors.Table (D).Warn or else Errors.Table (D).Style then
118
               Warnings_Detected := Warnings_Detected - 1;
119
 
120
            else
121
               Total_Errors_Detected := Total_Errors_Detected - 1;
122
 
123
               if Errors.Table (D).Serious then
124
                  Serious_Errors_Detected := Serious_Errors_Detected - 1;
125
               end if;
126
            end if;
127
 
128
            --  Substitute shorter of the two error messages
129
 
130
            if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
131
               Errors.Table (K).Text := Errors.Table (D).Text;
132
            end if;
133
 
134
            D := Errors.Table (D).Next;
135
            K := Errors.Table (K).Next;
136
 
137
            if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
138
               return;
139
            end if;
140
         end loop;
141
      end Delete_Msg;
142
 
143
   --  Start of processing for Check_Duplicate_Message
144
 
145
   begin
146
      --  Both messages must be non-continuation messages and not deleted
147
 
148
      if Errors.Table (M1).Msg_Cont
149
        or else Errors.Table (M2).Msg_Cont
150
        or else Errors.Table (M1).Deleted
151
        or else Errors.Table (M2).Deleted
152
      then
153
         return;
154
      end if;
155
 
156
      --  Definitely not equal if message text does not match
157
 
158
      if not Same_Error (M1, M2) then
159
         return;
160
      end if;
161
 
162
      --  Same text. See if all continuations are also identical
163
 
164
      L1 := M1;
165
      L2 := M2;
166
 
167
      loop
168
         N1 := Errors.Table (L1).Next;
169
         N2 := Errors.Table (L2).Next;
170
 
171
         --  If M1 continuations have run out, we delete M1, either the
172
         --  messages have the same number of continuations, or M2 has
173
         --  more and we prefer the one with more anyway.
174
 
175
         if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
176
            Delete_Msg (M1, M2);
177
            return;
178
 
179
         --  If M2 continuations have run out, we delete M2
180
 
181
         elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
182
            Delete_Msg (M2, M1);
183
            return;
184
 
185
         --  Otherwise see if continuations are the same, if not, keep both
186
         --  sequences, a curious case, but better to keep everything!
187
 
188
         elsif not Same_Error (N1, N2) then
189
            return;
190
 
191
         --  If continuations are the same, continue scan
192
 
193
         else
194
            L1 := N1;
195
            L2 := N2;
196
         end if;
197
      end loop;
198
   end Check_Duplicate_Message;
199
 
200
   ------------------------
201
   -- Compilation_Errors --
202
   ------------------------
203
 
204
   function Compilation_Errors return Boolean is
205
   begin
206
      return Total_Errors_Detected /= 0
207
        or else (Warnings_Detected /= 0
208
                  and then Warning_Mode = Treat_As_Error);
209
   end Compilation_Errors;
210
 
211
   ------------------
212
   -- Debug_Output --
213
   ------------------
214
 
215
   procedure Debug_Output (N : Node_Id) is
216
   begin
217
      if Debug_Flag_1 then
218
         Write_Str ("*** following error message posted on node id = #");
219
         Write_Int (Int (N));
220
         Write_Str (" ***");
221
         Write_Eol;
222
      end if;
223
   end Debug_Output;
224
 
225
   ----------
226
   -- dmsg --
227
   ----------
228
 
229
   procedure dmsg (Id : Error_Msg_Id) is
230
      E : Error_Msg_Object renames Errors.Table (Id);
231
 
232
   begin
233
      w ("Dumping error message, Id = ", Int (Id));
234
      w ("  Text     = ", E.Text.all);
235
      w ("  Next     = ", Int (E.Next));
236
      w ("  Sfile    = ", Int (E.Sfile));
237
 
238
      Write_Str
239
        ("  Sptr     = ");
240
      Write_Location (E.Sptr);
241
      Write_Eol;
242
 
243
      Write_Str
244
        ("  Optr     = ");
245
      Write_Location (E.Optr);
246
      Write_Eol;
247
 
248
      w ("  Line     = ", Int (E.Line));
249
      w ("  Col      = ", Int (E.Col));
250
      w ("  Warn     = ", E.Warn);
251
      w ("  Style    = ", E.Style);
252
      w ("  Serious  = ", E.Serious);
253
      w ("  Uncond   = ", E.Uncond);
254
      w ("  Msg_Cont = ", E.Msg_Cont);
255
      w ("  Deleted  = ", E.Deleted);
256
 
257
      Write_Eol;
258
   end dmsg;
259
 
260
   ------------------
261
   -- Get_Location --
262
   ------------------
263
 
264
   function Get_Location (E : Error_Msg_Id) return Source_Ptr is
265
   begin
266
      return Errors.Table (E).Sptr;
267
   end Get_Location;
268
 
269
   ----------------
270
   -- Get_Msg_Id --
271
   ----------------
272
 
273
   function Get_Msg_Id return Error_Msg_Id is
274
   begin
275
      return Cur_Msg;
276
   end Get_Msg_Id;
277
 
278
   -----------------------
279
   -- Output_Error_Msgs --
280
   -----------------------
281
 
282
   procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
283
      P : Source_Ptr;
284
      T : Error_Msg_Id;
285
      S : Error_Msg_Id;
286
 
287
      Flag_Num   : Pos;
288
      Mult_Flags : Boolean := False;
289
 
290
   begin
291
      S := E;
292
 
293
      --  Skip deleted messages at start
294
 
295
      if Errors.Table (S).Deleted then
296
         Set_Next_Non_Deleted_Msg (S);
297
      end if;
298
 
299
      --  Figure out if we will place more than one error flag on this line
300
 
301
      T := S;
302
      while T /= No_Error_Msg
303
        and then Errors.Table (T).Line = Errors.Table (E).Line
304
        and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
305
      loop
306
         if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
307
            Mult_Flags := True;
308
         end if;
309
 
310
         Set_Next_Non_Deleted_Msg (T);
311
      end loop;
312
 
313
      --  Output the error flags. The circuit here makes sure that the tab
314
      --  characters in the original line are properly accounted for. The
315
      --  eight blanks at the start are to match the line number.
316
 
317
      if not Debug_Flag_2 then
318
         Write_Str ("        ");
319
         P := Line_Start (Errors.Table (E).Sptr);
320
         Flag_Num := 1;
321
 
322
         --  Loop through error messages for this line to place flags
323
 
324
         T := S;
325
         while T /= No_Error_Msg
326
           and then Errors.Table (T).Line = Errors.Table (E).Line
327
           and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
328
         loop
329
            --  Loop to output blanks till current flag position
330
 
331
            while P < Errors.Table (T).Sptr loop
332
               if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
333
                  Write_Char (ASCII.HT);
334
               else
335
                  Write_Char (' ');
336
               end if;
337
 
338
               P := P + 1;
339
            end loop;
340
 
341
            --  Output flag (unless already output, this happens if more
342
            --  than one error message occurs at the same flag position).
343
 
344
            if P = Errors.Table (T).Sptr then
345
               if (Flag_Num = 1 and then not Mult_Flags)
346
                 or else Flag_Num > 9
347
               then
348
                  Write_Char ('|');
349
               else
350
                  Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
351
               end if;
352
 
353
               P := P + 1;
354
            end if;
355
 
356
            Set_Next_Non_Deleted_Msg (T);
357
            Flag_Num := Flag_Num + 1;
358
         end loop;
359
 
360
         Write_Eol;
361
      end if;
362
 
363
      --  Now output the error messages
364
 
365
      T := S;
366
      while T /= No_Error_Msg
367
        and then Errors.Table (T).Line = Errors.Table (E).Line
368
        and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
369
      loop
370
         Write_Str ("        >>> ");
371
         Output_Msg_Text (T);
372
 
373
         if Debug_Flag_2 then
374
            while Column < 74 loop
375
               Write_Char (' ');
376
            end loop;
377
 
378
            Write_Str (" <<<");
379
         end if;
380
 
381
         Write_Eol;
382
         Set_Next_Non_Deleted_Msg (T);
383
      end loop;
384
 
385
      E := T;
386
   end Output_Error_Msgs;
387
 
388
   ------------------------
389
   -- Output_Line_Number --
390
   ------------------------
391
 
392
   procedure Output_Line_Number (L : Logical_Line_Number) is
393
      D     : Int;       -- next digit
394
      C     : Character; -- next character
395
      Z     : Boolean;   -- flag for zero suppress
396
      N, M  : Int;       -- temporaries
397
 
398
   begin
399
      if L = No_Line_Number then
400
         Write_Str ("        ");
401
 
402
      else
403
         Z := False;
404
         N := Int (L);
405
 
406
         M := 100_000;
407
         while M /= 0 loop
408
            D := Int (N / M);
409
            N := N rem M;
410
            M := M / 10;
411
 
412
            if D = 0 then
413
               if Z then
414
                  C := '0';
415
               else
416
                  C := ' ';
417
               end if;
418
            else
419
               Z := True;
420
               C := Character'Val (D + 48);
421
            end if;
422
 
423
            Write_Char (C);
424
         end loop;
425
 
426
         Write_Str (". ");
427
      end if;
428
   end Output_Line_Number;
429
 
430
   ---------------------
431
   -- Output_Msg_Text --
432
   ---------------------
433
 
434
   procedure Output_Msg_Text (E : Error_Msg_Id) is
435
      Offs : constant Nat := Column - 1;
436
      --  Offset to start of message, used for continuations
437
 
438
      Max : Integer;
439
      --  Maximum characters to output on next line
440
 
441
      Length : Nat;
442
      --  Maximum total length of lines
443
 
444
      Txt   : constant String_Ptr := Errors.Table (E).Text;
445
      Len   : constant Natural    := Txt'Length;
446
      Ptr   : Natural;
447
      Split : Natural;
448
      Start : Natural;
449
 
450
   begin
451
      if Error_Msg_Line_Length = 0 then
452
         Length := Nat'Last;
453
      else
454
         Length := Error_Msg_Line_Length;
455
      end if;
456
 
457
      Max := Integer (Length - Column + 1);
458
 
459
      --  For warning message, add "warning: " unless msg starts with "info: "
460
 
461
      if Errors.Table (E).Warn then
462
         if Len < 6 or else Txt (Txt'First .. Txt'First + 5) /= "info: " then
463
            Write_Str ("warning: ");
464
            Max := Max - 9;
465
         end if;
466
 
467
      --  No prefix needed for style message, since "(style)" is there already
468
 
469
      elsif Errors.Table (E).Style then
470
         null;
471
 
472
      --  All other cases, add "error: "
473
 
474
      elsif Opt.Unique_Error_Tag then
475
         Write_Str ("error: ");
476
         Max := Max - 7;
477
      end if;
478
 
479
      --  Here we have to split the message up into multiple lines
480
 
481
      Ptr := 1;
482
      loop
483
         --  Make sure we do not have ludicrously small line
484
 
485
         Max := Integer'Max (Max, 20);
486
 
487
         --  If remaining text fits, output it respecting LF and we are done
488
 
489
         if Len - Ptr < Max then
490
            for J in Ptr .. Len loop
491
               if Txt (J) = ASCII.LF then
492
                  Write_Eol;
493
                  Write_Spaces (Offs);
494
               else
495
                  Write_Char (Txt (J));
496
               end if;
497
            end loop;
498
 
499
            return;
500
 
501
            --  Line does not fit
502
 
503
         else
504
            Start := Ptr;
505
 
506
            --  First scan forward looking for a hard end of line
507
 
508
            for Scan in Ptr .. Ptr + Max - 1 loop
509
               if Txt (Scan) = ASCII.LF then
510
                  Split := Scan - 1;
511
                  Ptr := Scan + 1;
512
                  goto Continue;
513
               end if;
514
            end loop;
515
 
516
            --  Otherwise scan backwards looking for a space
517
 
518
            for Scan in reverse Ptr .. Ptr + Max - 1 loop
519
               if Txt (Scan) = ' ' then
520
                  Split := Scan - 1;
521
                  Ptr := Scan + 1;
522
                  goto Continue;
523
               end if;
524
            end loop;
525
 
526
            --  If we fall through, no space, so split line arbitrarily
527
 
528
            Split := Ptr + Max - 1;
529
            Ptr := Split + 1;
530
         end if;
531
 
532
         <<Continue>>
533
         if Start <= Split then
534
            Write_Line (Txt (Start .. Split));
535
            Write_Spaces (Offs);
536
         end if;
537
 
538
         Max := Integer (Length - Column + 1);
539
      end loop;
540
   end Output_Msg_Text;
541
 
542
   --------------------
543
   -- Purge_Messages --
544
   --------------------
545
 
546
   procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
547
      E : Error_Msg_Id;
548
 
549
      function To_Be_Purged (E : Error_Msg_Id) return Boolean;
550
      --  Returns True for a message that is to be purged. Also adjusts
551
      --  error counts appropriately.
552
 
553
      ------------------
554
      -- To_Be_Purged --
555
      ------------------
556
 
557
      function To_Be_Purged (E : Error_Msg_Id) return Boolean is
558
      begin
559
         if E /= No_Error_Msg
560
           and then Errors.Table (E).Sptr > From
561
           and then Errors.Table (E).Sptr < To
562
         then
563
            if Errors.Table (E).Warn or else Errors.Table (E).Style then
564
               Warnings_Detected := Warnings_Detected - 1;
565
 
566
            else
567
               Total_Errors_Detected := Total_Errors_Detected - 1;
568
 
569
               if Errors.Table (E).Serious then
570
                  Serious_Errors_Detected := Serious_Errors_Detected - 1;
571
               end if;
572
            end if;
573
 
574
            return True;
575
 
576
         else
577
            return False;
578
         end if;
579
      end To_Be_Purged;
580
 
581
   --  Start of processing for Purge_Messages
582
 
583
   begin
584
      while To_Be_Purged (First_Error_Msg) loop
585
         First_Error_Msg := Errors.Table (First_Error_Msg).Next;
586
      end loop;
587
 
588
      E := First_Error_Msg;
589
      while E /= No_Error_Msg loop
590
         while To_Be_Purged (Errors.Table (E).Next) loop
591
            Errors.Table (E).Next :=
592
              Errors.Table (Errors.Table (E).Next).Next;
593
         end loop;
594
 
595
         E := Errors.Table (E).Next;
596
      end loop;
597
   end Purge_Messages;
598
 
599
   ----------------
600
   -- Same_Error --
601
   ----------------
602
 
603
   function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
604
      Msg1 : constant String_Ptr := Errors.Table (M1).Text;
605
      Msg2 : constant String_Ptr := Errors.Table (M2).Text;
606
 
607
      Msg2_Len : constant Integer := Msg2'Length;
608
      Msg1_Len : constant Integer := Msg1'Length;
609
 
610
   begin
611
      return
612
        Msg1.all = Msg2.all
613
          or else
614
            (Msg1_Len - 10 > Msg2_Len
615
               and then
616
             Msg2.all = Msg1.all (1 .. Msg2_Len)
617
               and then
618
             Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
619
          or else
620
            (Msg2_Len - 10 > Msg1_Len
621
               and then
622
             Msg1.all = Msg2.all (1 .. Msg1_Len)
623
               and then
624
             Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
625
   end Same_Error;
626
 
627
   -------------------
628
   -- Set_Msg_Blank --
629
   -------------------
630
 
631
   procedure Set_Msg_Blank is
632
   begin
633
      if Msglen > 0
634
        and then Msg_Buffer (Msglen) /= ' '
635
        and then Msg_Buffer (Msglen) /= '('
636
        and then Msg_Buffer (Msglen) /= '-'
637
        and then not Manual_Quote_Mode
638
      then
639
         Set_Msg_Char (' ');
640
      end if;
641
   end Set_Msg_Blank;
642
 
643
   -------------------------------
644
   -- Set_Msg_Blank_Conditional --
645
   -------------------------------
646
 
647
   procedure Set_Msg_Blank_Conditional is
648
   begin
649
      if Msglen > 0
650
        and then Msg_Buffer (Msglen) /= ' '
651
        and then Msg_Buffer (Msglen) /= '('
652
        and then Msg_Buffer (Msglen) /= '"'
653
        and then not Manual_Quote_Mode
654
      then
655
         Set_Msg_Char (' ');
656
      end if;
657
   end Set_Msg_Blank_Conditional;
658
 
659
   ------------------
660
   -- Set_Msg_Char --
661
   ------------------
662
 
663
   procedure Set_Msg_Char (C : Character) is
664
   begin
665
 
666
      --  The check for message buffer overflow is needed to deal with cases
667
      --  where insertions get too long (in particular a child unit name can
668
      --  be very long).
669
 
670
      if Msglen < Max_Msg_Length then
671
         Msglen := Msglen + 1;
672
         Msg_Buffer (Msglen) := C;
673
      end if;
674
   end Set_Msg_Char;
675
 
676
   ---------------------------------
677
   -- Set_Msg_Insertion_File_Name --
678
   ---------------------------------
679
 
680
   procedure Set_Msg_Insertion_File_Name is
681
   begin
682
      if Error_Msg_File_1 = No_File then
683
         null;
684
 
685
      elsif Error_Msg_File_1 = Error_File_Name then
686
         Set_Msg_Blank;
687
         Set_Msg_Str ("<error>");
688
 
689
      else
690
         Set_Msg_Blank;
691
         Get_Name_String (Error_Msg_File_1);
692
         Set_Msg_Quote;
693
         Set_Msg_Name_Buffer;
694
         Set_Msg_Quote;
695
      end if;
696
 
697
      --  The following assignments ensure that the second and third {
698
      --  insertion characters will correspond to the Error_Msg_File_2 and
699
      --  Error_Msg_File_3 values and We suppress possible validity checks in
700
      --  case operating in -gnatVa mode, and Error_Msg_File_2 or
701
      --  Error_Msg_File_3 is not needed and has not been set.
702
 
703
      declare
704
         pragma Suppress (Range_Check);
705
      begin
706
         Error_Msg_File_1 := Error_Msg_File_2;
707
         Error_Msg_File_2 := Error_Msg_File_3;
708
      end;
709
   end Set_Msg_Insertion_File_Name;
710
 
711
   -----------------------------------
712
   -- Set_Msg_Insertion_Line_Number --
713
   -----------------------------------
714
 
715
   procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
716
      Sindex_Loc  : Source_File_Index;
717
      Sindex_Flag : Source_File_Index;
718
 
719
      procedure Set_At;
720
      --  Outputs "at " unless last characters in buffer are " from ". Certain
721
      --  messages read better with from than at.
722
 
723
      ------------
724
      -- Set_At --
725
      ------------
726
 
727
      procedure Set_At is
728
      begin
729
         if Msglen < 6
730
           or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
731
         then
732
            Set_Msg_Str ("at ");
733
         end if;
734
      end Set_At;
735
 
736
   --  Start of processing for Set_Msg_Insertion_Line_Number
737
 
738
   begin
739
      Set_Msg_Blank;
740
 
741
      if Loc = No_Location then
742
         Set_At;
743
         Set_Msg_Str ("unknown location");
744
 
745
      elsif Loc = System_Location then
746
         Set_Msg_Str ("in package System");
747
         Set_Msg_Insertion_Run_Time_Name;
748
 
749
      elsif Loc = Standard_Location then
750
         Set_Msg_Str ("in package Standard");
751
 
752
      elsif Loc = Standard_ASCII_Location then
753
         Set_Msg_Str ("in package Standard.ASCII");
754
 
755
      else
756
         --  Add "at file-name:" if reference is to other than the source
757
         --  file in which the error message is placed. Note that we check
758
         --  full file names, rather than just the source indexes, to
759
         --  deal with generic instantiations from the current file.
760
 
761
         Sindex_Loc  := Get_Source_File_Index (Loc);
762
         Sindex_Flag := Get_Source_File_Index (Flag);
763
 
764
         if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
765
            Set_At;
766
            Get_Name_String
767
              (Reference_Name (Get_Source_File_Index (Loc)));
768
            Set_Msg_Name_Buffer;
769
            Set_Msg_Char (':');
770
 
771
         --  If in current file, add text "at line "
772
 
773
         else
774
            Set_At;
775
            Set_Msg_Str ("line ");
776
         end if;
777
 
778
         --  Output line number for reference
779
 
780
         Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
781
 
782
         --  Deal with the instantiation case. We may have a reference to,
783
         --  e.g. a type, that is declared within a generic template, and
784
         --  what we are really referring to is the occurrence in an instance.
785
         --  In this case, the line number of the instantiation is also of
786
         --  interest, and we add a notation:
787
 
788
         --    , instance at xxx
789
 
790
         --  where xxx is a line number output using this same routine (and
791
         --  the recursion can go further if the instantiation is itself in
792
         --  a generic template).
793
 
794
         --  The flag location passed to us in this situation is indeed the
795
         --  line number within the template, but as described in Sinput.L
796
         --  (file sinput-l.ads, section "Handling Generic Instantiations")
797
         --  we can retrieve the location of the instantiation itself from
798
         --  this flag location value.
799
 
800
         --  Note: this processing is suppressed if Suppress_Instance_Location
801
         --  is set True. This is used to prevent redundant annotations of the
802
         --  location of the instantiation in the case where we are placing
803
         --  the messages on the instantiation in any case.
804
 
805
         if Instantiation (Sindex_Loc) /= No_Location
806
           and then not Suppress_Instance_Location
807
         then
808
            Set_Msg_Str (", instance ");
809
            Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
810
         end if;
811
      end if;
812
   end Set_Msg_Insertion_Line_Number;
813
 
814
   ----------------------------
815
   -- Set_Msg_Insertion_Name --
816
   ----------------------------
817
 
818
   procedure Set_Msg_Insertion_Name is
819
   begin
820
      if Error_Msg_Name_1 = No_Name then
821
         null;
822
 
823
      elsif Error_Msg_Name_1 = Error_Name then
824
         Set_Msg_Blank;
825
         Set_Msg_Str ("<error>");
826
 
827
      else
828
         Set_Msg_Blank_Conditional;
829
         Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
830
 
831
         --  Remove %s or %b at end. These come from unit names. If the
832
         --  caller wanted the (unit) or (body), then they would have used
833
         --  the $ insertion character. Certainly no error message should
834
         --  ever have %b or %s explicitly occurring.
835
 
836
         if Name_Len > 2
837
           and then Name_Buffer (Name_Len - 1) = '%'
838
           and then (Name_Buffer (Name_Len) = 'b'
839
                       or else
840
                     Name_Buffer (Name_Len) = 's')
841
         then
842
            Name_Len := Name_Len - 2;
843
         end if;
844
 
845
         --  Remove upper case letter at end, again, we should not be getting
846
         --  such names, and what we hope is that the remainder makes sense.
847
 
848
         if Name_Len > 1
849
           and then Name_Buffer (Name_Len) in 'A' .. 'Z'
850
         then
851
            Name_Len := Name_Len - 1;
852
         end if;
853
 
854
         --  If operator name or character literal name, just print it as is
855
         --  Also print as is if it ends in a right paren (case of x'val(nnn))
856
 
857
         if Name_Buffer (1) = '"'
858
           or else Name_Buffer (1) = '''
859
           or else Name_Buffer (Name_Len) = ')'
860
         then
861
            Set_Msg_Name_Buffer;
862
 
863
         --  Else output with surrounding quotes in proper casing mode
864
 
865
         else
866
            Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
867
            Set_Msg_Quote;
868
            Set_Msg_Name_Buffer;
869
            Set_Msg_Quote;
870
         end if;
871
      end if;
872
 
873
      --  The following assignments ensure that the second and third percent
874
      --  insertion characters will correspond to the Error_Msg_Name_2 and
875
      --  Error_Msg_Name_3 as required. We suppress possible validity checks in
876
      --  case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
877
      --  and has not been set.
878
 
879
      declare
880
         pragma Suppress (Range_Check);
881
      begin
882
         Error_Msg_Name_1 := Error_Msg_Name_2;
883
         Error_Msg_Name_2 := Error_Msg_Name_3;
884
      end;
885
   end Set_Msg_Insertion_Name;
886
 
887
   ------------------------------------
888
   -- Set_Msg_Insertion_Name_Literal --
889
   ------------------------------------
890
 
891
   procedure Set_Msg_Insertion_Name_Literal is
892
   begin
893
      if Error_Msg_Name_1 = No_Name then
894
         null;
895
 
896
      elsif Error_Msg_Name_1 = Error_Name then
897
         Set_Msg_Blank;
898
         Set_Msg_Str ("<error>");
899
 
900
      else
901
         Set_Msg_Blank;
902
         Get_Name_String (Error_Msg_Name_1);
903
         Set_Msg_Quote;
904
         Set_Msg_Name_Buffer;
905
         Set_Msg_Quote;
906
      end if;
907
 
908
      --  The following assignments ensure that the second and third % or %%
909
      --  insertion characters will correspond to the Error_Msg_Name_2 and
910
      --  Error_Msg_Name_3 values and We suppress possible validity checks in
911
      --  case operating in -gnatVa mode, and Error_Msg_Name_2 or
912
      --  Error_Msg_Name_3 is not needed and has not been set.
913
 
914
      declare
915
         pragma Suppress (Range_Check);
916
      begin
917
         Error_Msg_Name_1 := Error_Msg_Name_2;
918
         Error_Msg_Name_2 := Error_Msg_Name_3;
919
      end;
920
   end Set_Msg_Insertion_Name_Literal;
921
 
922
   -------------------------------------
923
   -- Set_Msg_Insertion_Reserved_Name --
924
   -------------------------------------
925
 
926
   procedure Set_Msg_Insertion_Reserved_Name is
927
   begin
928
      Set_Msg_Blank_Conditional;
929
      Get_Name_String (Error_Msg_Name_1);
930
      Set_Msg_Quote;
931
      Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
932
      Set_Msg_Name_Buffer;
933
      Set_Msg_Quote;
934
   end Set_Msg_Insertion_Reserved_Name;
935
 
936
   -------------------------------------
937
   -- Set_Msg_Insertion_Reserved_Word --
938
   -------------------------------------
939
 
940
   procedure Set_Msg_Insertion_Reserved_Word
941
     (Text : String;
942
      J    : in out Integer)
943
   is
944
   begin
945
      Set_Msg_Blank_Conditional;
946
      Name_Len := 0;
947
 
948
      while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
949
         Add_Char_To_Name_Buffer (Text (J));
950
         J := J + 1;
951
      end loop;
952
 
953
      --  Here is where we make the special exception for RM
954
 
955
      if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
956
         Set_Msg_Name_Buffer;
957
 
958
      --  We make a similar exception for Alfa
959
 
960
      elsif Name_Len = 4 and then Name_Buffer (1 .. 4) = "Alfa" then
961
         Set_Msg_Name_Buffer;
962
 
963
      --  Neither RM nor Alfa: case appropriately and add surrounding quotes
964
 
965
      else
966
         Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
967
         Set_Msg_Quote;
968
         Set_Msg_Name_Buffer;
969
         Set_Msg_Quote;
970
      end if;
971
   end Set_Msg_Insertion_Reserved_Word;
972
 
973
   -------------------------------------
974
   -- Set_Msg_Insertion_Run_Time_Name --
975
   -------------------------------------
976
 
977
   procedure Set_Msg_Insertion_Run_Time_Name is
978
   begin
979
      if Targparm.Run_Time_Name_On_Target /= No_Name then
980
         Set_Msg_Blank_Conditional;
981
         Set_Msg_Char ('(');
982
         Get_Name_String (Targparm.Run_Time_Name_On_Target);
983
         Set_Casing (Mixed_Case);
984
         Set_Msg_Str (Name_Buffer (1 .. Name_Len));
985
         Set_Msg_Char (')');
986
      end if;
987
   end Set_Msg_Insertion_Run_Time_Name;
988
 
989
   ----------------------------
990
   -- Set_Msg_Insertion_Uint --
991
   ----------------------------
992
 
993
   procedure Set_Msg_Insertion_Uint is
994
   begin
995
      Set_Msg_Blank;
996
      UI_Image (Error_Msg_Uint_1);
997
 
998
      for J in 1 .. UI_Image_Length loop
999
         Set_Msg_Char (UI_Image_Buffer (J));
1000
      end loop;
1001
 
1002
      --  The following assignment ensures that a second caret insertion
1003
      --  character will correspond to the Error_Msg_Uint_2 parameter. We
1004
      --  suppress possible validity checks in case operating in -gnatVa mode,
1005
      --  and Error_Msg_Uint_2 is not needed and has not been set.
1006
 
1007
      declare
1008
         pragma Suppress (Range_Check);
1009
      begin
1010
         Error_Msg_Uint_1 := Error_Msg_Uint_2;
1011
      end;
1012
   end Set_Msg_Insertion_Uint;
1013
 
1014
   -----------------
1015
   -- Set_Msg_Int --
1016
   -----------------
1017
 
1018
   procedure Set_Msg_Int (Line : Int) is
1019
   begin
1020
      if Line > 9 then
1021
         Set_Msg_Int (Line / 10);
1022
      end if;
1023
 
1024
      Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1025
   end Set_Msg_Int;
1026
 
1027
   -------------------------
1028
   -- Set_Msg_Name_Buffer --
1029
   -------------------------
1030
 
1031
   procedure Set_Msg_Name_Buffer is
1032
   begin
1033
      for J in 1 .. Name_Len loop
1034
         Set_Msg_Char (Name_Buffer (J));
1035
      end loop;
1036
   end Set_Msg_Name_Buffer;
1037
 
1038
   -------------------
1039
   -- Set_Msg_Quote --
1040
   -------------------
1041
 
1042
   procedure Set_Msg_Quote is
1043
   begin
1044
      if not Manual_Quote_Mode then
1045
         Set_Msg_Char ('"');
1046
      end if;
1047
   end Set_Msg_Quote;
1048
 
1049
   -----------------
1050
   -- Set_Msg_Str --
1051
   -----------------
1052
 
1053
   procedure Set_Msg_Str (Text : String) is
1054
   begin
1055
      for J in Text'Range loop
1056
         Set_Msg_Char (Text (J));
1057
      end loop;
1058
   end Set_Msg_Str;
1059
 
1060
   ------------------------------
1061
   -- Set_Next_Non_Deleted_Msg --
1062
   ------------------------------
1063
 
1064
   procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1065
   begin
1066
      if E = No_Error_Msg then
1067
         return;
1068
 
1069
      else
1070
         loop
1071
            E := Errors.Table (E).Next;
1072
            exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1073
         end loop;
1074
      end if;
1075
   end Set_Next_Non_Deleted_Msg;
1076
 
1077
   ------------------------------
1078
   -- Set_Specific_Warning_Off --
1079
   ------------------------------
1080
 
1081
   procedure Set_Specific_Warning_Off
1082
     (Loc    : Source_Ptr;
1083
      Msg    : String;
1084
      Config : Boolean;
1085
      Used   : Boolean := False)
1086
   is
1087
   begin
1088
      Specific_Warnings.Append
1089
        ((Start      => Loc,
1090
          Msg        => new String'(Msg),
1091
          Stop       => Source_Last (Current_Source_File),
1092
          Open       => True,
1093
          Used       => Used,
1094
          Config     => Config));
1095
   end Set_Specific_Warning_Off;
1096
 
1097
   -----------------------------
1098
   -- Set_Specific_Warning_On --
1099
   -----------------------------
1100
 
1101
   procedure Set_Specific_Warning_On
1102
     (Loc : Source_Ptr;
1103
      Msg : String;
1104
      Err : out Boolean)
1105
   is
1106
   begin
1107
      for J in 1 .. Specific_Warnings.Last loop
1108
         declare
1109
            SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1110
         begin
1111
            if Msg = SWE.Msg.all
1112
              and then Loc > SWE.Start
1113
              and then SWE.Open
1114
              and then Get_Source_File_Index (SWE.Start) =
1115
                       Get_Source_File_Index (Loc)
1116
            then
1117
               SWE.Stop := Loc;
1118
               SWE.Open := False;
1119
               Err := False;
1120
 
1121
               --  If a config pragma is specifically cancelled, consider
1122
               --  that it is no longer active as a configuration pragma.
1123
 
1124
               SWE.Config := False;
1125
               return;
1126
            end if;
1127
         end;
1128
      end loop;
1129
 
1130
      Err := True;
1131
   end Set_Specific_Warning_On;
1132
 
1133
   ---------------------------
1134
   -- Set_Warnings_Mode_Off --
1135
   ---------------------------
1136
 
1137
   procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1138
   begin
1139
      --  Don't bother with entries from instantiation copies, since we will
1140
      --  already have a copy in the template, which is what matters.
1141
 
1142
      if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1143
         return;
1144
      end if;
1145
 
1146
      --  If last entry in table already covers us, this is a redundant pragma
1147
      --  Warnings (Off) and can be ignored. This also handles the case where
1148
      --  all warnings are suppressed by command line switch.
1149
 
1150
      if Warnings.Last >= Warnings.First
1151
        and then Warnings.Table (Warnings.Last).Start <= Loc
1152
        and then Loc <= Warnings.Table (Warnings.Last).Stop
1153
      then
1154
         return;
1155
 
1156
      --  Otherwise establish a new entry, extending from the location of the
1157
      --  pragma to the end of the current source file. This ending point will
1158
      --  be adjusted by a subsequent pragma Warnings (On).
1159
 
1160
      else
1161
         Warnings.Increment_Last;
1162
         Warnings.Table (Warnings.Last).Start := Loc;
1163
         Warnings.Table (Warnings.Last).Stop :=
1164
           Source_Last (Current_Source_File);
1165
      end if;
1166
   end Set_Warnings_Mode_Off;
1167
 
1168
   --------------------------
1169
   -- Set_Warnings_Mode_On --
1170
   --------------------------
1171
 
1172
   procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1173
   begin
1174
      --  Don't bother with entries from instantiation copies, since we will
1175
      --  already have a copy in the template, which is what matters.
1176
 
1177
      if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1178
         return;
1179
      end if;
1180
 
1181
      --  Nothing to do unless command line switch to suppress all warnings
1182
      --  is off, and the last entry in the warnings table covers this
1183
      --  pragma Warnings (On), in which case adjust the end point.
1184
 
1185
      if (Warnings.Last >= Warnings.First
1186
           and then Warnings.Table (Warnings.Last).Start <= Loc
1187
           and then Loc <= Warnings.Table (Warnings.Last).Stop)
1188
        and then Warning_Mode /= Suppress
1189
      then
1190
         Warnings.Table (Warnings.Last).Stop := Loc;
1191
      end if;
1192
   end Set_Warnings_Mode_On;
1193
 
1194
   ------------------------------------
1195
   -- Test_Style_Warning_Serious_Msg --
1196
   ------------------------------------
1197
 
1198
   procedure Test_Style_Warning_Serious_Msg (Msg : String) is
1199
   begin
1200
      if Msg (Msg'First) = '\' then
1201
         return;
1202
      end if;
1203
 
1204
      Is_Serious_Error := True;
1205
      Is_Warning_Msg   := False;
1206
 
1207
      Is_Style_Msg :=
1208
        (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1209
 
1210
      if Is_Style_Msg then
1211
         Is_Serious_Error := False;
1212
      end if;
1213
 
1214
      for J in Msg'Range loop
1215
         if Msg (J) = '?'
1216
           and then (J = Msg'First or else Msg (J - 1) /= ''')
1217
         then
1218
            Is_Warning_Msg := True;
1219
 
1220
         elsif Msg (J) = '<'
1221
           and then (J = Msg'First or else Msg (J - 1) /= ''')
1222
         then
1223
            Is_Warning_Msg := Error_Msg_Warn;
1224
 
1225
         elsif Msg (J) = '|'
1226
           and then (J = Msg'First or else Msg (J - 1) /= ''')
1227
         then
1228
            Is_Serious_Error := False;
1229
         end if;
1230
      end loop;
1231
 
1232
      if Is_Warning_Msg or Is_Style_Msg then
1233
         Is_Serious_Error := False;
1234
      end if;
1235
   end Test_Style_Warning_Serious_Msg;
1236
 
1237
   --------------------------------
1238
   -- Validate_Specific_Warnings --
1239
   --------------------------------
1240
 
1241
   procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1242
   begin
1243
      for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1244
         declare
1245
            SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1246
         begin
1247
            if not SWE.Config then
1248
               if SWE.Open then
1249
                  Eproc.all
1250
                    ("?pragma Warnings Off with no matching Warnings On",
1251
                     SWE.Start);
1252
               elsif not SWE.Used then
1253
                  Eproc.all
1254
                    ("?no warning suppressed by this pragma", SWE.Start);
1255
               end if;
1256
            end if;
1257
         end;
1258
      end loop;
1259
   end Validate_Specific_Warnings;
1260
 
1261
   -------------------------------------
1262
   -- Warning_Specifically_Suppressed --
1263
   -------------------------------------
1264
 
1265
   function Warning_Specifically_Suppressed
1266
     (Loc : Source_Ptr;
1267
      Msg : String_Ptr) return Boolean
1268
   is
1269
      function Matches (S : String; P : String) return Boolean;
1270
      --  Returns true if the String S patches the pattern P, which can contain
1271
      --  wild card chars (*). The entire pattern must match the entire string.
1272
 
1273
      -------------
1274
      -- Matches --
1275
      -------------
1276
 
1277
      function Matches (S : String; P : String) return Boolean is
1278
         Slast : constant Natural := S'Last;
1279
         PLast : constant Natural := P'Last;
1280
 
1281
         SPtr : Natural := S'First;
1282
         PPtr : Natural := P'First;
1283
 
1284
      begin
1285
         --  Loop advancing through characters of string and pattern
1286
 
1287
         SPtr := S'First;
1288
         PPtr := P'First;
1289
         loop
1290
            --  Return True if pattern is a single asterisk
1291
 
1292
            if PPtr = PLast and then P (PPtr) = '*' then
1293
               return True;
1294
 
1295
            --  Return True if both pattern and string exhausted
1296
 
1297
            elsif PPtr > PLast and then SPtr > Slast then
1298
               return True;
1299
 
1300
            --  Return False, if one exhausted and not the other
1301
 
1302
            elsif PPtr > PLast or else SPtr > Slast then
1303
               return False;
1304
 
1305
            --  Case where pattern starts with asterisk
1306
 
1307
            elsif P (PPtr) = '*' then
1308
 
1309
               --  Try all possible starting positions in S for match with
1310
               --  the remaining characters of the pattern. This is the
1311
               --  recursive call that implements the scanner backup.
1312
 
1313
               for J in SPtr .. Slast loop
1314
                  if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
1315
                     return True;
1316
                  end if;
1317
               end loop;
1318
 
1319
               return False;
1320
 
1321
            --  Dealt with end of string and *, advance if we have a match
1322
 
1323
            elsif S (SPtr) = P (PPtr) then
1324
               SPtr := SPtr + 1;
1325
               PPtr := PPtr + 1;
1326
 
1327
            --  If first characters do not match, that's decisive
1328
 
1329
            else
1330
               return False;
1331
            end if;
1332
         end loop;
1333
      end Matches;
1334
 
1335
   --  Start of processing for Warning_Specifically_Suppressed
1336
 
1337
   begin
1338
      --  Loop through specific warning suppression entries
1339
 
1340
      for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1341
         declare
1342
            SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1343
 
1344
         begin
1345
            --  Pragma applies if it is a configuration pragma, or if the
1346
            --  location is in range of a specific non-configuration pragma.
1347
 
1348
            if SWE.Config
1349
              or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1350
            then
1351
               if Matches (Msg.all, SWE.Msg.all) then
1352
                  SWE.Used := True;
1353
                  return True;
1354
               end if;
1355
            end if;
1356
         end;
1357
      end loop;
1358
 
1359
      return False;
1360
   end Warning_Specifically_Suppressed;
1361
 
1362
   -------------------------
1363
   -- Warnings_Suppressed --
1364
   -------------------------
1365
 
1366
   function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1367
   begin
1368
      if Warning_Mode = Suppress then
1369
         return True;
1370
      end if;
1371
 
1372
      --  Loop through table of ON/OFF warnings
1373
 
1374
      for J in Warnings.First .. Warnings.Last loop
1375
         if Warnings.Table (J).Start <= Loc
1376
           and then Loc <= Warnings.Table (J).Stop
1377
         then
1378
            return True;
1379
         end if;
1380
      end loop;
1381
 
1382
      return False;
1383
   end Warnings_Suppressed;
1384
 
1385
end Erroutc;

powered by: WebSVN 2.1.0

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