projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
sem_aggr.adb (Resolve_Array_Aggregate): Identify duplicated cases.
[gcc.git] / gcc / ada / erroutc.adb
1 ------------------------------------------------------------------------------
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-2013, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 -- Warning! Error messages can be generated during Gigi processing by direct
27 -- calls to error message routines, so it is essential that the processing
28 -- in this body be consistent with the requirements for the Gigi processing
29 -- environment, and that in particular, no disallowed table expansion is
30 -- allowed to occur.
31
32 with Atree; use Atree;
33 with Casing; use Casing;
34 with Csets; use Csets;
35 with Debug; use Debug;
36 with Err_Vars; use Err_Vars;
37 with Namet; use Namet;
38 with Opt; use Opt;
39 with Output; use Output;
40 with Sinput; use Sinput;
41 with Snames; use Snames;
42 with Targparm; use Targparm;
43 with Uintp; use Uintp;
44
45 package body Erroutc is
46
47 ---------------
48 -- Add_Class --
49 ---------------
50
51 procedure Add_Class is
52 begin
53 if Class_Flag then
54 Class_Flag := False;
55 Set_Msg_Char (''');
56 Get_Name_String (Name_Class);
57 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
58 Set_Msg_Name_Buffer;
59 end if;
60 end Add_Class;
61
62 ----------------------
63 -- Buffer_Ends_With --
64 ----------------------
65
66 function Buffer_Ends_With (S : String) return Boolean is
67 Len : constant Natural := S'Length;
68 begin
69 return
70 Msglen > Len
71 and then Msg_Buffer (Msglen - Len) = ' '
72 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S;
73 end Buffer_Ends_With;
74
75 -------------------
76 -- Buffer_Remove --
77 -------------------
78
79 procedure Buffer_Remove (S : String) is
80 begin
81 if Buffer_Ends_With (S) then
82 Msglen := Msglen - S'Length;
83 end if;
84 end Buffer_Remove;
85
86 -----------------------------
87 -- Check_Duplicate_Message --
88 -----------------------------
89
90 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is
91 L1, L2 : Error_Msg_Id;
92 N1, N2 : Error_Msg_Id;
93
94 procedure Delete_Msg (Delete, Keep : Error_Msg_Id);
95 -- Called to delete message Delete, keeping message Keep. Marks
96 -- all messages of Delete with deleted flag set to True, and also
97 -- makes sure that for the error messages that are retained the
98 -- preferred message is the one retained (we prefer the shorter
99 -- one in the case where one has an Instance tag). Note that we
100 -- always know that Keep has at least as many continuations as
101 -- Delete (since we always delete the shorter sequence).
102
103 ----------------
104 -- Delete_Msg --
105 ----------------
106
107 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is
108 D, K : Error_Msg_Id;
109
110 begin
111 D := Delete;
112 K := Keep;
113
114 loop
115 Errors.Table (D).Deleted := True;
116
117 -- Adjust error message count
118
119 if Errors.Table (D).Warn or else Errors.Table (D).Style then
120 Warnings_Detected := Warnings_Detected - 1;
121
122 else
123 Total_Errors_Detected := Total_Errors_Detected - 1;
124
125 if Errors.Table (D).Serious then
126 Serious_Errors_Detected := Serious_Errors_Detected - 1;
127 end if;
128 end if;
129
130 -- Substitute shorter of the two error messages
131
132 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then
133 Errors.Table (K).Text := Errors.Table (D).Text;
134 end if;
135
136 D := Errors.Table (D).Next;
137 K := Errors.Table (K).Next;
138
139 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then
140 return;
141 end if;
142 end loop;
143 end Delete_Msg;
144
145 -- Start of processing for Check_Duplicate_Message
146
147 begin
148 -- Both messages must be non-continuation messages and not deleted
149
150 if Errors.Table (M1).Msg_Cont
151 or else Errors.Table (M2).Msg_Cont
152 or else Errors.Table (M1).Deleted
153 or else Errors.Table (M2).Deleted
154 then
155 return;
156 end if;
157
158 -- Definitely not equal if message text does not match
159
160 if not Same_Error (M1, M2) then
161 return;
162 end if;
163
164 -- Same text. See if all continuations are also identical
165
166 L1 := M1;
167 L2 := M2;
168
169 loop
170 N1 := Errors.Table (L1).Next;
171 N2 := Errors.Table (L2).Next;
172
173 -- If M1 continuations have run out, we delete M1, either the
174 -- messages have the same number of continuations, or M2 has
175 -- more and we prefer the one with more anyway.
176
177 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then
178 Delete_Msg (M1, M2);
179 return;
180
181 -- If M2 continuations have run out, we delete M2
182
183 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then
184 Delete_Msg (M2, M1);
185 return;
186
187 -- Otherwise see if continuations are the same, if not, keep both
188 -- sequences, a curious case, but better to keep everything!
189
190 elsif not Same_Error (N1, N2) then
191 return;
192
193 -- If continuations are the same, continue scan
194
195 else
196 L1 := N1;
197 L2 := N2;
198 end if;
199 end loop;
200 end Check_Duplicate_Message;
201
202 ------------------------
203 -- Compilation_Errors --
204 ------------------------
205
206 function Compilation_Errors return Boolean is
207 begin
208 return Total_Errors_Detected /= 0
209 or else (Warnings_Detected /= 0
210 and then Warning_Mode = Treat_As_Error);
211 end Compilation_Errors;
212
213 ------------------
214 -- Debug_Output --
215 ------------------
216
217 procedure Debug_Output (N : Node_Id) is
218 begin
219 if Debug_Flag_1 then
220 Write_Str ("*** following error message posted on node id = #");
221 Write_Int (Int (N));
222 Write_Str (" ***");
223 Write_Eol;
224 end if;
225 end Debug_Output;
226
227 ----------
228 -- dmsg --
229 ----------
230
231 procedure dmsg (Id : Error_Msg_Id) is
232 E : Error_Msg_Object renames Errors.Table (Id);
233
234 begin
235 w ("Dumping error message, Id = ", Int (Id));
236 w (" Text = ", E.Text.all);
237 w (" Next = ", Int (E.Next));
238 w (" Sfile = ", Int (E.Sfile));
239
240 Write_Str
241 (" Sptr = ");
242 Write_Location (E.Sptr);
243 Write_Eol;
244
245 Write_Str
246 (" Optr = ");
247 Write_Location (E.Optr);
248 Write_Eol;
249
250 w (" Line = ", Int (E.Line));
251 w (" Col = ", Int (E.Col));
252 w (" Warn = ", E.Warn);
253 w (" Style = ", E.Style);
254 w (" Serious = ", E.Serious);
255 w (" Uncond = ", E.Uncond);
256 w (" Msg_Cont = ", E.Msg_Cont);
257 w (" Deleted = ", E.Deleted);
258
259 Write_Eol;
260 end dmsg;
261
262 ------------------
263 -- Get_Location --
264 ------------------
265
266 function Get_Location (E : Error_Msg_Id) return Source_Ptr is
267 begin
268 return Errors.Table (E).Sptr;
269 end Get_Location;
270
271 ----------------
272 -- Get_Msg_Id --
273 ----------------
274
275 function Get_Msg_Id return Error_Msg_Id is
276 begin
277 return Cur_Msg;
278 end Get_Msg_Id;
279
280 -----------------------
281 -- Output_Error_Msgs --
282 -----------------------
283
284 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is
285 P : Source_Ptr;
286 T : Error_Msg_Id;
287 S : Error_Msg_Id;
288
289 Flag_Num : Pos;
290 Mult_Flags : Boolean := False;
291
292 begin
293 S := E;
294
295 -- Skip deleted messages at start
296
297 if Errors.Table (S).Deleted then
298 Set_Next_Non_Deleted_Msg (S);
299 end if;
300
301 -- Figure out if we will place more than one error flag on this line
302
303 T := S;
304 while T /= No_Error_Msg
305 and then Errors.Table (T).Line = Errors.Table (E).Line
306 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
307 loop
308 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then
309 Mult_Flags := True;
310 end if;
311
312 Set_Next_Non_Deleted_Msg (T);
313 end loop;
314
315 -- Output the error flags. The circuit here makes sure that the tab
316 -- characters in the original line are properly accounted for. The
317 -- eight blanks at the start are to match the line number.
318
319 if not Debug_Flag_2 then
320 Write_Str (" ");
321 P := Line_Start (Errors.Table (E).Sptr);
322 Flag_Num := 1;
323
324 -- Loop through error messages for this line to place flags
325
326 T := S;
327 while T /= No_Error_Msg
328 and then Errors.Table (T).Line = Errors.Table (E).Line
329 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
330 loop
331 -- Loop to output blanks till current flag position
332
333 while P < Errors.Table (T).Sptr loop
334 if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then
335 Write_Char (ASCII.HT);
336 else
337 Write_Char (' ');
338 end if;
339
340 P := P + 1;
341 end loop;
342
343 -- Output flag (unless already output, this happens if more
344 -- than one error message occurs at the same flag position).
345
346 if P = Errors.Table (T).Sptr then
347 if (Flag_Num = 1 and then not Mult_Flags)
348 or else Flag_Num > 9
349 then
350 Write_Char ('|');
351 else
352 Write_Char (Character'Val (Character'Pos ('0') + Flag_Num));
353 end if;
354
355 P := P + 1;
356 end if;
357
358 Set_Next_Non_Deleted_Msg (T);
359 Flag_Num := Flag_Num + 1;
360 end loop;
361
362 Write_Eol;
363 end if;
364
365 -- Now output the error messages
366
367 T := S;
368 while T /= No_Error_Msg
369 and then Errors.Table (T).Line = Errors.Table (E).Line
370 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile
371 loop
372 Write_Str (" >>> ");
373 Output_Msg_Text (T);
374
375 if Debug_Flag_2 then
376 while Column < 74 loop
377 Write_Char (' ');
378 end loop;
379
380 Write_Str (" <<<");
381 end if;
382
383 Write_Eol;
384 Set_Next_Non_Deleted_Msg (T);
385 end loop;
386
387 E := T;
388 end Output_Error_Msgs;
389
390 ------------------------
391 -- Output_Line_Number --
392 ------------------------
393
394 procedure Output_Line_Number (L : Logical_Line_Number) is
395 D : Int; -- next digit
396 C : Character; -- next character
397 Z : Boolean; -- flag for zero suppress
398 N, M : Int; -- temporaries
399
400 begin
401 if L = No_Line_Number then
402 Write_Str (" ");
403
404 else
405 Z := False;
406 N := Int (L);
407
408 M := 100_000;
409 while M /= 0 loop
410 D := Int (N / M);
411 N := N rem M;
412 M := M / 10;
413
414 if D = 0 then
415 if Z then
416 C := '0';
417 else
418 C := ' ';
419 end if;
420 else
421 Z := True;
422 C := Character'Val (D + 48);
423 end if;
424
425 Write_Char (C);
426 end loop;
427
428 Write_Str (". ");
429 end if;
430 end Output_Line_Number;
431
432 ---------------------
433 -- Output_Msg_Text --
434 ---------------------
435
436 procedure Output_Msg_Text (E : Error_Msg_Id) is
437 Offs : constant Nat := Column - 1;
438 -- Offset to start of message, used for continuations
439
440 Max : Integer;
441 -- Maximum characters to output on next line
442
443 Length : Nat;
444 -- Maximum total length of lines
445
446 Text : constant String_Ptr := Errors.Table (E).Text;
447 Warn : constant Boolean := Errors.Table (E).Warn;
448 Warn_Chr : constant Character := Errors.Table (E).Warn_Chr;
449 Warn_Tag : String_Ptr;
450 Ptr : Natural;
451 Split : Natural;
452 Start : Natural;
453
454 function Get_VMS_Warn_String (W : Character) return String;
455 -- On VMS, given a warning character W, returns VMS command string
456 -- that corresponds to that warning character
457
458 -------------------------
459 -- Get_VMS_Warn_String --
460 -------------------------
461
462 function Get_VMS_Warn_String (W : Character) return String is
463 S, E : Natural;
464 -- Start and end of VMS_QUALIFIER below
465
466 P : Natural;
467 -- Scans through string
468
469 -- The following is a copy of the S_GCC_Warn string from the package
470 -- VMS_Data. If we made that package part of the compiler sources
471 -- we could just with it and avoid the duplication ???
472
473 V : constant String := "/WARNINGS=" &
474 "DEFAULT " &
475 "!-gnatws,!-gnatwe " &
476 "ALL " &
477 "-gnatwa " &
478 "EVERY " &
479 "-gnatw.e " &
480 "OPTIONAL " &
481 "-gnatwa " &
482 "NOOPTIONAL " &
483 "-gnatwA " &
484 "NOALL " &
485 "-gnatwA " &
486 "ALL_GCC " &
487 "-Wall " &
488 "FAILING_ASSERTIONS " &
489 "-gnatw.a " &
490 "NO_FAILING_ASSERTIONS " &
491 "-gnatw.A " &
492 "BAD_FIXED_VALUES " &
493 "-gnatwb " &
494 "NO_BAD_FIXED_VALUES " &
495 "-gnatwB " &
496 "BIASED_REPRESENTATION " &
497 "-gnatw.b " &
498 "NO_BIASED_REPRESENTATION " &
499 "-gnatw.B " &
500 "CONDITIONALS " &
501 "-gnatwc " &
502 "NOCONDITIONALS " &
503 "-gnatwC " &
504 "MISSING_COMPONENT_CLAUSES " &
505 "-gnatw.c " &
506 "NOMISSING_COMPONENT_CLAUSES " &
507 "-gnatw.C " &
508 "IMPLICIT_DEREFERENCE " &
509 "-gnatwd " &
510 "NO_IMPLICIT_DEREFERENCE " &
511 "-gnatwD " &
512 "TAG_WARNINGS " &
513 "-gnatw.d " &
514 "NOTAG_WARNINGS " &
515 "-gnatw.D " &
516 "ERRORS " &
517 "-gnatwe " &
518 "UNREFERENCED_FORMALS " &
519 "-gnatwf " &
520 "NOUNREFERENCED_FORMALS " &
521 "-gnatwF " &
522 "UNRECOGNIZED_PRAGMAS " &
523 "-gnatwg " &
524 "NOUNRECOGNIZED_PRAGMAS " &
525 "-gnatwG " &
526 "HIDING " &
527 "-gnatwh " &
528 "NOHIDING " &
529 "-gnatwH " &
530 "AVOIDGAPS " &
531 "-gnatw.h " &
532 "NOAVOIDGAPS " &
533 "-gnatw.H " &
534 "IMPLEMENTATION " &
535 "-gnatwi " &
536 "NOIMPLEMENTATION " &
537 "-gnatwI " &
538 "OBSOLESCENT " &
539 "-gnatwj " &
540 "NOOBSOLESCENT " &
541 "-gnatwJ " &
542 "CONSTANT_VARIABLES " &
543 "-gnatwk " &
544 "NOCONSTANT_VARIABLES " &
545 "-gnatwK " &
546 "STANDARD_REDEFINITION " &
547 "-gnatw.k " &
548 "NOSTANDARD_REDEFINITION " &
549 "-gnatw.K " &
550 "ELABORATION " &
551 "-gnatwl " &
552 "NOELABORATION " &
553 "-gnatwL " &
554 "MODIFIED_UNREF " &
555 "-gnatwm " &
556 "NOMODIFIED_UNREF " &
557 "-gnatwM " &
558 "SUSPICIOUS_MODULUS " &
559 "-gnatw.m " &
560 "NOSUSPICIOUS_MODULUS " &
561 "-gnatw.M " &
562 "NORMAL " &
563 "-gnatwn " &
564 "OVERLAYS " &
565 "-gnatwo " &
566 "NOOVERLAYS " &
567 "-gnatwO " &
568 "OUT_PARAM_UNREF " &
569 "-gnatw.o " &
570 "NOOUT_PARAM_UNREF " &
571 "-gnatw.O " &
572 "INEFFECTIVE_INLINE " &
573 "-gnatwp " &
574 "NOINEFFECTIVE_INLINE " &
575 "-gnatwP " &
576 "MISSING_PARENS " &
577 "-gnatwq " &
578 "PARAMETER_ORDER " &
579 "-gnatw.p " &
580 "NOPARAMETER_ORDER " &
581 "-gnatw.P " &
582 "NOMISSING_PARENS " &
583 "-gnatwQ " &
584 "REDUNDANT " &
585 "-gnatwr " &
586 "NOREDUNDANT " &
587 "-gnatwR " &
588 "OBJECT_RENAMES " &
589 "-gnatw.r " &
590 "NOOBJECT_RENAMES " &
591 "-gnatw.R " &
592 "SUPPRESS " &
593 "-gnatws " &
594 "OVERRIDING_SIZE " &
595 "-gnatw.s " &
596 "NOOVERRIDING_SIZE " &
597 "-gnatw.S " &
598 "DELETED_CODE " &
599 "-gnatwt " &
600 "NODELETED_CODE " &
601 "-gnatwT " &
602 "UNINITIALIZED " &
603 "-Wuninitialized " &
604 "UNUSED " &
605 "-gnatwu " &
606 "NOUNUSED " &
607 "-gnatwU " &
608 "UNORDERED_ENUMERATIONS " &
609 "-gnatw.u " &
610 "NOUNORDERED_ENUMERATIONS " &
611 "-gnatw.U " &
612 "VARIABLES_UNINITIALIZED " &
613 "-gnatwv " &
614 "NOVARIABLES_UNINITIALIZED " &
615 "-gnatwV " &
616 "REVERSE_BIT_ORDER " &
617 "-gnatw.v " &
618 "NOREVERSE_BIT_ORDER " &
619 "-gnatw.V " &
620 "LOWBOUND_ASSUMED " &
621 "-gnatww " &
622 "NOLOWBOUND_ASSUMED " &
623 "-gnatwW " &
624 "WARNINGS_OFF_PRAGMAS " &
625 "-gnatw.w " &
626 "NO_WARNINGS_OFF_PRAGMAS " &
627 "-gnatw.W " &
628 "IMPORT_EXPORT_PRAGMAS " &
629 "-gnatwx " &
630 "NOIMPORT_EXPORT_PRAGMAS " &
631 "-gnatwX " &
632 "LOCAL_RAISE_HANDLING " &
633 "-gnatw.x " &
634 "NOLOCAL_RAISE_HANDLING " &
635 "-gnatw.X " &
636 "ADA_2005_COMPATIBILITY " &
637 "-gnatwy " &
638 "NOADA_2005_COMPATIBILITY " &
639 "-gnatwY " &
640 "UNCHECKED_CONVERSIONS " &
641 "-gnatwz " &
642 "NOUNCHECKED_CONVERSIONS " &
643 "-gnatwZ";
644
645 -- Start of processing for Get_VMS_Warn_String
646
647 begin
648 -- This function works by inspecting the string S_GCC_Warn in the
649 -- package VMS_Data. We are looking for
650
651 -- space VMS_QUALIFIER space -gnatwq
652
653 -- where q is the lower case letter W if W is lower case, and the
654 -- two character string .W if W is upper case. If we find a match
655 -- we return VMS_QUALIFIER, otherwise we return empty (this should
656 -- be an error, but no point in bombing over something so trivial).
657
658 P := 1;
659
660 -- Loop through entries in S_GCC_Warn
661
662 loop
663 -- Scan to next blank
664
665 loop
666 if P >= V'Last - 1 then
667 return "";
668 end if;
669
670 exit when V (P) = ' ' and then V (P + 1) in 'A' .. 'Z';
671 P := P + 1;
672 end loop;
673
674 P := P + 1;
675 S := P;
676
677 -- Scan to blank at end of VMS_QUALIFIER
678
679 loop
680 if P >= V'Last then
681 return "";
682 end if;
683
684 exit when V (P) = ' ';
685 P := P + 1;
686 end loop;
687
688 E := P - 1;
689
690 -- See if this entry matches, and if so, return it
691
692 if V (P + 1 .. P + 6) = "-gnatw"
693 and then
694 ((W in 'a' .. 'z' and then V (P + 7) = W)
695 or else
696 (V (P + 7) = '.' and then Fold_Upper (V (P + 8)) = W))
697 then
698 return V (S .. E);
699 end if;
700 end loop;
701 end Get_VMS_Warn_String;
702
703 -- Start of processing for Output_Msg_Text
704
705 begin
706 -- Add warning doc tag if needed
707
708 if Warn and then Warn_Chr /= ' ' then
709 if Warn_Chr = '?' then
710 Warn_Tag := new String'(" [enabled by default]");
711
712 elsif OpenVMS_On_Target then
713 declare
714 Qual : constant String := Get_VMS_Warn_String (Warn_Chr);
715 begin
716 if Qual = "" then
717 Warn_Tag := new String'(Qual);
718 else
719 Warn_Tag := new String'(" [" & Qual & ']');
720 end if;
721 end;
722
723 elsif Warn_Chr in 'a' .. 'z' then
724 Warn_Tag := new String'(" [-gnatw" & Warn_Chr & ']');
725
726 else pragma Assert (Warn_Chr in 'A' .. 'Z');
727 Warn_Tag := new String'(" [-gnatw." & Fold_Lower (Warn_Chr) & ']');
728 end if;
729
730 else
731 Warn_Tag := new String'("");
732 end if;
733
734 -- Set error message line length
735
736 if Error_Msg_Line_Length = 0 then
737 Length := Nat'Last;
738 else
739 Length := Error_Msg_Line_Length;
740 end if;
741
742 Max := Integer (Length - Column + 1);
743
744 declare
745 Txt : constant String := Text.all & Warn_Tag.all;
746 Len : constant Natural := Txt'Length;
747
748 begin
749 -- For warning, add "warning: " unless msg starts with "info: "
750
751 if Errors.Table (E).Warn then
752 if Len < 6
753 or else Txt (Txt'First .. Txt'First + 5) /= "info: "
754 then
755 Write_Str ("warning: ");
756 Max := Max - 9;
757 end if;
758
759 -- No prefix needed for style message, "(style)" is there already
760
761 elsif Errors.Table (E).Style then
762 null;
763
764 -- All other cases, add "error: "
765
766 elsif Opt.Unique_Error_Tag then
767 Write_Str ("error: ");
768 Max := Max - 7;
769 end if;
770
771 -- Here we have to split the message up into multiple lines
772
773 Ptr := 1;
774 loop
775 -- Make sure we do not have ludicrously small line
776
777 Max := Integer'Max (Max, 20);
778
779 -- If remaining text fits, output it respecting LF and we are done
780
781 if Len - Ptr < Max then
782 for J in Ptr .. Len loop
783 if Txt (J) = ASCII.LF then
784 Write_Eol;
785 Write_Spaces (Offs);
786 else
787 Write_Char (Txt (J));
788 end if;
789 end loop;
790
791 return;
792
793 -- Line does not fit
794
795 else
796 Start := Ptr;
797
798 -- First scan forward looking for a hard end of line
799
800 for Scan in Ptr .. Ptr + Max - 1 loop
801 if Txt (Scan) = ASCII.LF then
802 Split := Scan - 1;
803 Ptr := Scan + 1;
804 goto Continue;
805 end if;
806 end loop;
807
808 -- Otherwise scan backwards looking for a space
809
810 for Scan in reverse Ptr .. Ptr + Max - 1 loop
811 if Txt (Scan) = ' ' then
812 Split := Scan - 1;
813 Ptr := Scan + 1;
814 goto Continue;
815 end if;
816 end loop;
817
818 -- If we fall through, no space, so split line arbitrarily
819
820 Split := Ptr + Max - 1;
821 Ptr := Split + 1;
822 end if;
823
824 <<Continue>>
825 if Start <= Split then
826 Write_Line (Txt (Start .. Split));
827 Write_Spaces (Offs);
828 end if;
829
830 Max := Integer (Length - Column + 1);
831 end loop;
832 end;
833 end Output_Msg_Text;
834
835 --------------------
836 -- Purge_Messages --
837 --------------------
838
839 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is
840 E : Error_Msg_Id;
841
842 function To_Be_Purged (E : Error_Msg_Id) return Boolean;
843 -- Returns True for a message that is to be purged. Also adjusts
844 -- error counts appropriately.
845
846 ------------------
847 -- To_Be_Purged --
848 ------------------
849
850 function To_Be_Purged (E : Error_Msg_Id) return Boolean is
851 begin
852 if E /= No_Error_Msg
853 and then Errors.Table (E).Sptr > From
854 and then Errors.Table (E).Sptr < To
855 then
856 if Errors.Table (E).Warn or else Errors.Table (E).Style then
857 Warnings_Detected := Warnings_Detected - 1;
858
859 else
860 Total_Errors_Detected := Total_Errors_Detected - 1;
861
862 if Errors.Table (E).Serious then
863 Serious_Errors_Detected := Serious_Errors_Detected - 1;
864 end if;
865 end if;
866
867 return True;
868
869 else
870 return False;
871 end if;
872 end To_Be_Purged;
873
874 -- Start of processing for Purge_Messages
875
876 begin
877 while To_Be_Purged (First_Error_Msg) loop
878 First_Error_Msg := Errors.Table (First_Error_Msg).Next;
879 end loop;
880
881 E := First_Error_Msg;
882 while E /= No_Error_Msg loop
883 while To_Be_Purged (Errors.Table (E).Next) loop
884 Errors.Table (E).Next :=
885 Errors.Table (Errors.Table (E).Next).Next;
886 end loop;
887
888 E := Errors.Table (E).Next;
889 end loop;
890 end Purge_Messages;
891
892 ----------------
893 -- Same_Error --
894 ----------------
895
896 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is
897 Msg1 : constant String_Ptr := Errors.Table (M1).Text;
898 Msg2 : constant String_Ptr := Errors.Table (M2).Text;
899
900 Msg2_Len : constant Integer := Msg2'Length;
901 Msg1_Len : constant Integer := Msg1'Length;
902
903 begin
904 return
905 Msg1.all = Msg2.all
906 or else
907 (Msg1_Len - 10 > Msg2_Len
908 and then
909 Msg2.all = Msg1.all (1 .. Msg2_Len)
910 and then
911 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance")
912 or else
913 (Msg2_Len - 10 > Msg1_Len
914 and then
915 Msg1.all = Msg2.all (1 .. Msg1_Len)
916 and then
917 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance");
918 end Same_Error;
919
920 -------------------
921 -- Set_Msg_Blank --
922 -------------------
923
924 procedure Set_Msg_Blank is
925 begin
926 if Msglen > 0
927 and then Msg_Buffer (Msglen) /= ' '
928 and then Msg_Buffer (Msglen) /= '('
929 and then Msg_Buffer (Msglen) /= '-'
930 and then not Manual_Quote_Mode
931 then
932 Set_Msg_Char (' ');
933 end if;
934 end Set_Msg_Blank;
935
936 -------------------------------
937 -- Set_Msg_Blank_Conditional --
938 -------------------------------
939
940 procedure Set_Msg_Blank_Conditional is
941 begin
942 if Msglen > 0
943 and then Msg_Buffer (Msglen) /= ' '
944 and then Msg_Buffer (Msglen) /= '('
945 and then Msg_Buffer (Msglen) /= '"'
946 and then not Manual_Quote_Mode
947 then
948 Set_Msg_Char (' ');
949 end if;
950 end Set_Msg_Blank_Conditional;
951
952 ------------------
953 -- Set_Msg_Char --
954 ------------------
955
956 procedure Set_Msg_Char (C : Character) is
957 begin
958
959 -- The check for message buffer overflow is needed to deal with cases
960 -- where insertions get too long (in particular a child unit name can
961 -- be very long).
962
963 if Msglen < Max_Msg_Length then
964 Msglen := Msglen + 1;
965 Msg_Buffer (Msglen) := C;
966 end if;
967 end Set_Msg_Char;
968
969 ---------------------------------
970 -- Set_Msg_Insertion_File_Name --
971 ---------------------------------
972
973 procedure Set_Msg_Insertion_File_Name is
974 begin
975 if Error_Msg_File_1 = No_File then
976 null;
977
978 elsif Error_Msg_File_1 = Error_File_Name then
979 Set_Msg_Blank;
980 Set_Msg_Str ("<error>");
981
982 else
983 Set_Msg_Blank;
984 Get_Name_String (Error_Msg_File_1);
985 Set_Msg_Quote;
986 Set_Msg_Name_Buffer;
987 Set_Msg_Quote;
988 end if;
989
990 -- The following assignments ensure that the second and third {
991 -- insertion characters will correspond to the Error_Msg_File_2 and
992 -- Error_Msg_File_3 values and We suppress possible validity checks in
993 -- case operating in -gnatVa mode, and Error_Msg_File_2 or
994 -- Error_Msg_File_3 is not needed and has not been set.
995
996 declare
997 pragma Suppress (Range_Check);
998 begin
999 Error_Msg_File_1 := Error_Msg_File_2;
1000 Error_Msg_File_2 := Error_Msg_File_3;
1001 end;
1002 end Set_Msg_Insertion_File_Name;
1003
1004 -----------------------------------
1005 -- Set_Msg_Insertion_Line_Number --
1006 -----------------------------------
1007
1008 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is
1009 Sindex_Loc : Source_File_Index;
1010 Sindex_Flag : Source_File_Index;
1011
1012 procedure Set_At;
1013 -- Outputs "at " unless last characters in buffer are " from ". Certain
1014 -- messages read better with from than at.
1015
1016 ------------
1017 -- Set_At --
1018 ------------
1019
1020 procedure Set_At is
1021 begin
1022 if Msglen < 6
1023 or else Msg_Buffer (Msglen - 5 .. Msglen) /= " from "
1024 then
1025 Set_Msg_Str ("at ");
1026 end if;
1027 end Set_At;
1028
1029 -- Start of processing for Set_Msg_Insertion_Line_Number
1030
1031 begin
1032 Set_Msg_Blank;
1033
1034 if Loc = No_Location then
1035 Set_At;
1036 Set_Msg_Str ("unknown location");
1037
1038 elsif Loc = System_Location then
1039 Set_Msg_Str ("in package System");
1040 Set_Msg_Insertion_Run_Time_Name;
1041
1042 elsif Loc = Standard_Location then
1043 Set_Msg_Str ("in package Standard");
1044
1045 elsif Loc = Standard_ASCII_Location then
1046 Set_Msg_Str ("in package Standard.ASCII");
1047
1048 else
1049 -- Add "at file-name:" if reference is to other than the source
1050 -- file in which the error message is placed. Note that we check
1051 -- full file names, rather than just the source indexes, to
1052 -- deal with generic instantiations from the current file.
1053
1054 Sindex_Loc := Get_Source_File_Index (Loc);
1055 Sindex_Flag := Get_Source_File_Index (Flag);
1056
1057 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then
1058 Set_At;
1059 Get_Name_String
1060 (Reference_Name (Get_Source_File_Index (Loc)));
1061 Set_Msg_Name_Buffer;
1062 Set_Msg_Char (':');
1063
1064 -- If in current file, add text "at line "
1065
1066 else
1067 Set_At;
1068 Set_Msg_Str ("line ");
1069 end if;
1070
1071 -- Output line number for reference
1072
1073 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc)));
1074
1075 -- Deal with the instantiation case. We may have a reference to,
1076 -- e.g. a type, that is declared within a generic template, and
1077 -- what we are really referring to is the occurrence in an instance.
1078 -- In this case, the line number of the instantiation is also of
1079 -- interest, and we add a notation:
1080
1081 -- , instance at xxx
1082
1083 -- where xxx is a line number output using this same routine (and
1084 -- the recursion can go further if the instantiation is itself in
1085 -- a generic template).
1086
1087 -- The flag location passed to us in this situation is indeed the
1088 -- line number within the template, but as described in Sinput.L
1089 -- (file sinput-l.ads, section "Handling Generic Instantiations")
1090 -- we can retrieve the location of the instantiation itself from
1091 -- this flag location value.
1092
1093 -- Note: this processing is suppressed if Suppress_Instance_Location
1094 -- is set True. This is used to prevent redundant annotations of the
1095 -- location of the instantiation in the case where we are placing
1096 -- the messages on the instantiation in any case.
1097
1098 if Instantiation (Sindex_Loc) /= No_Location
1099 and then not Suppress_Instance_Location
1100 then
1101 Set_Msg_Str (", instance ");
1102 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag);
1103 end if;
1104 end if;
1105 end Set_Msg_Insertion_Line_Number;
1106
1107 ----------------------------
1108 -- Set_Msg_Insertion_Name --
1109 ----------------------------
1110
1111 procedure Set_Msg_Insertion_Name is
1112 begin
1113 if Error_Msg_Name_1 = No_Name then
1114 null;
1115
1116 elsif Error_Msg_Name_1 = Error_Name then
1117 Set_Msg_Blank;
1118 Set_Msg_Str ("<error>");
1119
1120 else
1121 Set_Msg_Blank_Conditional;
1122 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1);
1123
1124 -- Remove %s or %b at end. These come from unit names. If the
1125 -- caller wanted the (unit) or (body), then they would have used
1126 -- the $ insertion character. Certainly no error message should
1127 -- ever have %b or %s explicitly occurring.
1128
1129 if Name_Len > 2
1130 and then Name_Buffer (Name_Len - 1) = '%'
1131 and then (Name_Buffer (Name_Len) = 'b'
1132 or else
1133 Name_Buffer (Name_Len) = 's')
1134 then
1135 Name_Len := Name_Len - 2;
1136 end if;
1137
1138 -- Remove upper case letter at end, again, we should not be getting
1139 -- such names, and what we hope is that the remainder makes sense.
1140
1141 if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then
1142 Name_Len := Name_Len - 1;
1143 end if;
1144
1145 -- If operator name or character literal name, just print it as is
1146 -- Also print as is if it ends in a right paren (case of x'val(nnn))
1147
1148 if Name_Buffer (1) = '"'
1149 or else Name_Buffer (1) = '''
1150 or else Name_Buffer (Name_Len) = ')'
1151 then
1152 Set_Msg_Name_Buffer;
1153
1154 -- Else output with surrounding quotes in proper casing mode
1155
1156 else
1157 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
1158 Set_Msg_Quote;
1159 Set_Msg_Name_Buffer;
1160 Set_Msg_Quote;
1161 end if;
1162 end if;
1163
1164 -- The following assignments ensure that the second and third percent
1165 -- insertion characters will correspond to the Error_Msg_Name_2 and
1166 -- Error_Msg_Name_3 as required. We suppress possible validity checks in
1167 -- case operating in -gnatVa mode, and Error_Msg_Name_1/2 is not needed
1168 -- and has not been set.
1169
1170 declare
1171 pragma Suppress (Range_Check);
1172 begin
1173 Error_Msg_Name_1 := Error_Msg_Name_2;
1174 Error_Msg_Name_2 := Error_Msg_Name_3;
1175 end;
1176 end Set_Msg_Insertion_Name;
1177
1178 ------------------------------------
1179 -- Set_Msg_Insertion_Name_Literal --
1180 ------------------------------------
1181
1182 procedure Set_Msg_Insertion_Name_Literal is
1183 begin
1184 if Error_Msg_Name_1 = No_Name then
1185 null;
1186
1187 elsif Error_Msg_Name_1 = Error_Name then
1188 Set_Msg_Blank;
1189 Set_Msg_Str ("<error>");
1190
1191 else
1192 Set_Msg_Blank;
1193 Get_Name_String (Error_Msg_Name_1);
1194 Set_Msg_Quote;
1195 Set_Msg_Name_Buffer;
1196 Set_Msg_Quote;
1197 end if;
1198
1199 -- The following assignments ensure that the second and third % or %%
1200 -- insertion characters will correspond to the Error_Msg_Name_2 and
1201 -- Error_Msg_Name_3 values and We suppress possible validity checks in
1202 -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
1203 -- Error_Msg_Name_3 is not needed and has not been set.
1204
1205 declare
1206 pragma Suppress (Range_Check);
1207 begin
1208 Error_Msg_Name_1 := Error_Msg_Name_2;
1209 Error_Msg_Name_2 := Error_Msg_Name_3;
1210 end;
1211 end Set_Msg_Insertion_Name_Literal;
1212
1213 -------------------------------------
1214 -- Set_Msg_Insertion_Reserved_Name --
1215 -------------------------------------
1216
1217 procedure Set_Msg_Insertion_Reserved_Name is
1218 begin
1219 Set_Msg_Blank_Conditional;
1220 Get_Name_String (Error_Msg_Name_1);
1221 Set_Msg_Quote;
1222 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1223 Set_Msg_Name_Buffer;
1224 Set_Msg_Quote;
1225 end Set_Msg_Insertion_Reserved_Name;
1226
1227 -------------------------------------
1228 -- Set_Msg_Insertion_Reserved_Word --
1229 -------------------------------------
1230
1231 procedure Set_Msg_Insertion_Reserved_Word
1232 (Text : String;
1233 J : in out Integer)
1234 is
1235 begin
1236 Set_Msg_Blank_Conditional;
1237 Name_Len := 0;
1238
1239 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop
1240 Add_Char_To_Name_Buffer (Text (J));
1241 J := J + 1;
1242 end loop;
1243
1244 -- Here is where we make the special exception for RM
1245
1246 if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then
1247 Set_Msg_Name_Buffer;
1248
1249 -- We make a similar exception for SPARK
1250
1251 elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then
1252 Set_Msg_Name_Buffer;
1253
1254 -- Neither RM nor SPARK: case appropriately and add surrounding quotes
1255
1256 else
1257 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case);
1258 Set_Msg_Quote;
1259 Set_Msg_Name_Buffer;
1260 Set_Msg_Quote;
1261 end if;
1262 end Set_Msg_Insertion_Reserved_Word;
1263
1264 -------------------------------------
1265 -- Set_Msg_Insertion_Run_Time_Name --
1266 -------------------------------------
1267
1268 procedure Set_Msg_Insertion_Run_Time_Name is
1269 begin
1270 if Targparm.Run_Time_Name_On_Target /= No_Name then
1271 Set_Msg_Blank_Conditional;
1272 Set_Msg_Char ('(');
1273 Get_Name_String (Targparm.Run_Time_Name_On_Target);
1274 Set_Casing (Mixed_Case);
1275 Set_Msg_Str (Name_Buffer (1 .. Name_Len));
1276 Set_Msg_Char (')');
1277 end if;
1278 end Set_Msg_Insertion_Run_Time_Name;
1279
1280 ----------------------------
1281 -- Set_Msg_Insertion_Uint --
1282 ----------------------------
1283
1284 procedure Set_Msg_Insertion_Uint is
1285 begin
1286 Set_Msg_Blank;
1287 UI_Image (Error_Msg_Uint_1);
1288
1289 for J in 1 .. UI_Image_Length loop
1290 Set_Msg_Char (UI_Image_Buffer (J));
1291 end loop;
1292
1293 -- The following assignment ensures that a second caret insertion
1294 -- character will correspond to the Error_Msg_Uint_2 parameter. We
1295 -- suppress possible validity checks in case operating in -gnatVa mode,
1296 -- and Error_Msg_Uint_2 is not needed and has not been set.
1297
1298 declare
1299 pragma Suppress (Range_Check);
1300 begin
1301 Error_Msg_Uint_1 := Error_Msg_Uint_2;
1302 end;
1303 end Set_Msg_Insertion_Uint;
1304
1305 -----------------
1306 -- Set_Msg_Int --
1307 -----------------
1308
1309 procedure Set_Msg_Int (Line : Int) is
1310 begin
1311 if Line > 9 then
1312 Set_Msg_Int (Line / 10);
1313 end if;
1314
1315 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10)));
1316 end Set_Msg_Int;
1317
1318 -------------------------
1319 -- Set_Msg_Name_Buffer --
1320 -------------------------
1321
1322 procedure Set_Msg_Name_Buffer is
1323 begin
1324 for J in 1 .. Name_Len loop
1325 Set_Msg_Char (Name_Buffer (J));
1326 end loop;
1327 end Set_Msg_Name_Buffer;
1328
1329 -------------------
1330 -- Set_Msg_Quote --
1331 -------------------
1332
1333 procedure Set_Msg_Quote is
1334 begin
1335 if not Manual_Quote_Mode then
1336 Set_Msg_Char ('"');
1337 end if;
1338 end Set_Msg_Quote;
1339
1340 -----------------
1341 -- Set_Msg_Str --
1342 -----------------
1343
1344 procedure Set_Msg_Str (Text : String) is
1345 begin
1346 for J in Text'Range loop
1347 Set_Msg_Char (Text (J));
1348 end loop;
1349 end Set_Msg_Str;
1350
1351 ------------------------------
1352 -- Set_Next_Non_Deleted_Msg --
1353 ------------------------------
1354
1355 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is
1356 begin
1357 if E = No_Error_Msg then
1358 return;
1359
1360 else
1361 loop
1362 E := Errors.Table (E).Next;
1363 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted;
1364 end loop;
1365 end if;
1366 end Set_Next_Non_Deleted_Msg;
1367
1368 ------------------------------
1369 -- Set_Specific_Warning_Off --
1370 ------------------------------
1371
1372 procedure Set_Specific_Warning_Off
1373 (Loc : Source_Ptr;
1374 Msg : String;
1375 Config : Boolean;
1376 Used : Boolean := False)
1377 is
1378 begin
1379 Specific_Warnings.Append
1380 ((Start => Loc,
1381 Msg => new String'(Msg),
1382 Stop => Source_Last (Current_Source_File),
1383 Open => True,
1384 Used => Used,
1385 Config => Config));
1386 end Set_Specific_Warning_Off;
1387
1388 -----------------------------
1389 -- Set_Specific_Warning_On --
1390 -----------------------------
1391
1392 procedure Set_Specific_Warning_On
1393 (Loc : Source_Ptr;
1394 Msg : String;
1395 Err : out Boolean)
1396 is
1397 begin
1398 for J in 1 .. Specific_Warnings.Last loop
1399 declare
1400 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1401 begin
1402 if Msg = SWE.Msg.all
1403 and then Loc > SWE.Start
1404 and then SWE.Open
1405 and then Get_Source_File_Index (SWE.Start) =
1406 Get_Source_File_Index (Loc)
1407 then
1408 SWE.Stop := Loc;
1409 SWE.Open := False;
1410 Err := False;
1411
1412 -- If a config pragma is specifically cancelled, consider
1413 -- that it is no longer active as a configuration pragma.
1414
1415 SWE.Config := False;
1416 return;
1417 end if;
1418 end;
1419 end loop;
1420
1421 Err := True;
1422 end Set_Specific_Warning_On;
1423
1424 ---------------------------
1425 -- Set_Warnings_Mode_Off --
1426 ---------------------------
1427
1428 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is
1429 begin
1430 -- Don't bother with entries from instantiation copies, since we will
1431 -- already have a copy in the template, which is what matters.
1432
1433 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1434 return;
1435 end if;
1436
1437 -- If last entry in table already covers us, this is a redundant pragma
1438 -- Warnings (Off) and can be ignored. This also handles the case where
1439 -- all warnings are suppressed by command line switch.
1440
1441 if Warnings.Last >= Warnings.First
1442 and then Warnings.Table (Warnings.Last).Start <= Loc
1443 and then Loc <= Warnings.Table (Warnings.Last).Stop
1444 then
1445 return;
1446
1447 -- Otherwise establish a new entry, extending from the location of the
1448 -- pragma to the end of the current source file. This ending point will
1449 -- be adjusted by a subsequent pragma Warnings (On).
1450
1451 else
1452 Warnings.Increment_Last;
1453 Warnings.Table (Warnings.Last).Start := Loc;
1454 Warnings.Table (Warnings.Last).Stop :=
1455 Source_Last (Current_Source_File);
1456 end if;
1457 end Set_Warnings_Mode_Off;
1458
1459 --------------------------
1460 -- Set_Warnings_Mode_On --
1461 --------------------------
1462
1463 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is
1464 begin
1465 -- Don't bother with entries from instantiation copies, since we will
1466 -- already have a copy in the template, which is what matters.
1467
1468 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then
1469 return;
1470 end if;
1471
1472 -- Nothing to do unless command line switch to suppress all warnings
1473 -- is off, and the last entry in the warnings table covers this
1474 -- pragma Warnings (On), in which case adjust the end point.
1475
1476 if (Warnings.Last >= Warnings.First
1477 and then Warnings.Table (Warnings.Last).Start <= Loc
1478 and then Loc <= Warnings.Table (Warnings.Last).Stop)
1479 and then Warning_Mode /= Suppress
1480 then
1481 Warnings.Table (Warnings.Last).Stop := Loc;
1482 end if;
1483 end Set_Warnings_Mode_On;
1484
1485 ------------------------------------
1486 -- Test_Style_Warning_Serious_Msg --
1487 ------------------------------------
1488
1489 procedure Test_Style_Warning_Serious_Unconditional_Msg (Msg : String) is
1490 begin
1491 -- Nothing to do for continuation line
1492
1493 if Msg (Msg'First) = '\' then
1494 return;
1495 end if;
1496
1497 -- Set initial values of globals (may be changed during scan)
1498
1499 Is_Serious_Error := True;
1500 Is_Unconditional_Msg := False;
1501 Is_Warning_Msg := False;
1502 Has_Double_Exclam := False;
1503
1504 Is_Style_Msg :=
1505 (Msg'Length > 7 and then Msg (Msg'First .. Msg'First + 6) = "(style)");
1506
1507 for J in Msg'Range loop
1508 if Msg (J) = '?'
1509 and then (J = Msg'First or else Msg (J - 1) /= ''')
1510 then
1511 Is_Warning_Msg := True;
1512 Warning_Msg_Char := ' ';
1513
1514 elsif Msg (J) = '!'
1515 and then (J = Msg'First or else Msg (J - 1) /= ''')
1516 then
1517 Is_Unconditional_Msg := True;
1518 Warning_Msg_Char := ' ';
1519
1520 if J < Msg'Last and then Msg (J + 1) = '!' then
1521 Has_Double_Exclam := True;
1522 end if;
1523
1524 elsif Msg (J) = '<'
1525 and then (J = Msg'First or else Msg (J - 1) /= ''')
1526 then
1527 Is_Warning_Msg := Error_Msg_Warn;
1528 Warning_Msg_Char := ' ';
1529
1530 elsif Msg (J) = '|'
1531 and then (J = Msg'First or else Msg (J - 1) /= ''')
1532 then
1533 Is_Serious_Error := False;
1534 end if;
1535 end loop;
1536
1537 if Is_Warning_Msg or Is_Style_Msg then
1538 Is_Serious_Error := False;
1539 end if;
1540 end Test_Style_Warning_Serious_Unconditional_Msg;
1541
1542 --------------------------------
1543 -- Validate_Specific_Warnings --
1544 --------------------------------
1545
1546 procedure Validate_Specific_Warnings (Eproc : Error_Msg_Proc) is
1547 begin
1548 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1549 declare
1550 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1551
1552 begin
1553 if not SWE.Config then
1554
1555 -- Warn for unmatched Warnings (Off, ...)
1556
1557 if SWE.Open then
1558 Eproc.all
1559 ("?pragma Warnings Off with no matching Warnings On",
1560 SWE.Start);
1561
1562 -- Warn for ineffective Warnings (Off, ..)
1563
1564 elsif not SWE.Used
1565
1566 -- Do not issue this warning for -Wxxx messages since the
1567 -- back-end doesn't report the information.
1568
1569 and then not
1570 (SWE.Msg'Length > 2 and then SWE.Msg (1 .. 2) = "-W")
1571 then
1572 Eproc.all
1573 ("?no warning suppressed by this pragma", SWE.Start);
1574 end if;
1575 end if;
1576 end;
1577 end loop;
1578 end Validate_Specific_Warnings;
1579
1580 -------------------------------------
1581 -- Warning_Specifically_Suppressed --
1582 -------------------------------------
1583
1584 function Warning_Specifically_Suppressed
1585 (Loc : Source_Ptr;
1586 Msg : String_Ptr) return Boolean
1587 is
1588 function Matches (S : String; P : String) return Boolean;
1589 -- Returns true if the String S patches the pattern P, which can contain
1590 -- wild card chars (*). The entire pattern must match the entire string.
1591
1592 -------------
1593 -- Matches --
1594 -------------
1595
1596 function Matches (S : String; P : String) return Boolean is
1597 Slast : constant Natural := S'Last;
1598 PLast : constant Natural := P'Last;
1599
1600 SPtr : Natural := S'First;
1601 PPtr : Natural := P'First;
1602
1603 begin
1604 -- Loop advancing through characters of string and pattern
1605
1606 SPtr := S'First;
1607 PPtr := P'First;
1608 loop
1609 -- Return True if pattern is a single asterisk
1610
1611 if PPtr = PLast and then P (PPtr) = '*' then
1612 return True;
1613
1614 -- Return True if both pattern and string exhausted
1615
1616 elsif PPtr > PLast and then SPtr > Slast then
1617 return True;
1618
1619 -- Return False, if one exhausted and not the other
1620
1621 elsif PPtr > PLast or else SPtr > Slast then
1622 return False;
1623
1624 -- Case where pattern starts with asterisk
1625
1626 elsif P (PPtr) = '*' then
1627
1628 -- Try all possible starting positions in S for match with
1629 -- the remaining characters of the pattern. This is the
1630 -- recursive call that implements the scanner backup.
1631
1632 for J in SPtr .. Slast loop
1633 if Matches (S (J .. Slast), P (PPtr + 1 .. PLast)) then
1634 return True;
1635 end if;
1636 end loop;
1637
1638 return False;
1639
1640 -- Dealt with end of string and *, advance if we have a match
1641
1642 elsif S (SPtr) = P (PPtr) then
1643 SPtr := SPtr + 1;
1644 PPtr := PPtr + 1;
1645
1646 -- If first characters do not match, that's decisive
1647
1648 else
1649 return False;
1650 end if;
1651 end loop;
1652 end Matches;
1653
1654 -- Start of processing for Warning_Specifically_Suppressed
1655
1656 begin
1657 -- Loop through specific warning suppression entries
1658
1659 for J in Specific_Warnings.First .. Specific_Warnings.Last loop
1660 declare
1661 SWE : Specific_Warning_Entry renames Specific_Warnings.Table (J);
1662
1663 begin
1664 -- Pragma applies if it is a configuration pragma, or if the
1665 -- location is in range of a specific non-configuration pragma.
1666
1667 if SWE.Config
1668 or else (SWE.Start <= Loc and then Loc <= SWE.Stop)
1669 then
1670 if Matches (Msg.all, SWE.Msg.all) then
1671 SWE.Used := True;
1672 return True;
1673 end if;
1674 end if;
1675 end;
1676 end loop;
1677
1678 return False;
1679 end Warning_Specifically_Suppressed;
1680
1681 -------------------------
1682 -- Warnings_Suppressed --
1683 -------------------------
1684
1685 function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is
1686 begin
1687 if Warning_Mode = Suppress then
1688 return True;
1689 end if;
1690
1691 -- Loop through table of ON/OFF warnings
1692
1693 for J in Warnings.First .. Warnings.Last loop
1694 if Warnings.Table (J).Start <= Loc
1695 and then Loc <= Warnings.Table (J).Stop
1696 then
1697 return True;
1698 end if;
1699 end loop;
1700
1701 return False;
1702 end Warnings_Suppressed;
1703
1704 end Erroutc;