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