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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [erroutc.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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