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-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27-- Warning! Error messages can be generated during Gigi processing by direct 28-- calls to error message routines, so it is essential that the processing 29-- in this body be consistent with the requirements for the Gigi processing 30-- environment, and that in particular, no disallowed table expansion is 31-- allowed to occur. 32 33with Casing; use Casing; 34with Debug; use Debug; 35with Err_Vars; use Err_Vars; 36with Hostparm; 37with Namet; use Namet; 38with Opt; use Opt; 39with Output; use Output; 40with Sinput; use Sinput; 41with Snames; use Snames; 42with Targparm; use Targparm; 43with Table; 44with Types; use Types; 45with Uintp; use Uintp; 46 47package body Erroutc is 48 49 ----------------------- 50 -- Local Subprograms -- 51 ----------------------- 52 53 --------------- 54 -- Add_Class -- 55 --------------- 56 57 procedure Add_Class is 58 begin 59 if Class_Flag then 60 Class_Flag := False; 61 Set_Msg_Char ('''); 62 Get_Name_String (Name_Class); 63 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); 64 Set_Msg_Name_Buffer; 65 end if; 66 end Add_Class; 67 68 ---------------------- 69 -- Buffer_Ends_With -- 70 ---------------------- 71 72 function Buffer_Ends_With (S : String) return Boolean is 73 Len : constant Natural := S'Length; 74 75 begin 76 return 77 Msglen > Len 78 and then Msg_Buffer (Msglen - Len) = ' ' 79 and then Msg_Buffer (Msglen - Len + 1 .. Msglen) = S; 80 end Buffer_Ends_With; 81 82 ------------------- 83 -- Buffer_Remove -- 84 ------------------- 85 86 procedure Buffer_Remove (S : String) is 87 begin 88 if Buffer_Ends_With (S) then 89 Msglen := Msglen - S'Length; 90 end if; 91 end Buffer_Remove; 92 93 ----------------------------- 94 -- Check_Duplicate_Message -- 95 ----------------------------- 96 97 procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is 98 L1, L2 : Error_Msg_Id; 99 N1, N2 : Error_Msg_Id; 100 101 procedure Delete_Msg (Delete, Keep : Error_Msg_Id); 102 -- Called to delete message Delete, keeping message Keep. Marks 103 -- all messages of Delete with deleted flag set to True, and also 104 -- makes sure that for the error messages that are retained the 105 -- preferred message is the one retained (we prefer the shorter 106 -- one in the case where one has an Instance tag). Note that we 107 -- always know that Keep has at least as many continuations as 108 -- Delete (since we always delete the shorter sequence). 109 110 ---------------- 111 -- Delete_Msg -- 112 ---------------- 113 114 procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is 115 D, K : Error_Msg_Id; 116 117 begin 118 D := Delete; 119 K := Keep; 120 121 loop 122 Errors.Table (D).Deleted := True; 123 124 -- Adjust error message count 125 126 if Errors.Table (D).Warn or Errors.Table (D).Style then 127 Warnings_Detected := Warnings_Detected - 1; 128 else 129 Total_Errors_Detected := Total_Errors_Detected - 1; 130 131 if Errors.Table (D).Serious then 132 Serious_Errors_Detected := Serious_Errors_Detected - 1; 133 end if; 134 end if; 135 136 -- Substitute shorter of the two error messages 137 138 if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then 139 Errors.Table (K).Text := Errors.Table (D).Text; 140 end if; 141 142 D := Errors.Table (D).Next; 143 K := Errors.Table (K).Next; 144 145 if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then 146 return; 147 end if; 148 end loop; 149 end Delete_Msg; 150 151 -- Start of processing for Check_Duplicate_Message 152 153 begin 154 -- Both messages must be non-continuation messages and not deleted 155 156 if Errors.Table (M1).Msg_Cont 157 or else Errors.Table (M2).Msg_Cont 158 or else Errors.Table (M1).Deleted 159 or else Errors.Table (M2).Deleted 160 then 161 return; 162 end if; 163 164 -- Definitely not equal if message text does not match 165 166 if not Same_Error (M1, M2) then 167 return; 168 end if; 169 170 -- Same text. See if all continuations are also identical 171 172 L1 := M1; 173 L2 := M2; 174 175 loop 176 N1 := Errors.Table (L1).Next; 177 N2 := Errors.Table (L2).Next; 178 179 -- If M1 continuations have run out, we delete M1, either the 180 -- messages have the same number of continuations, or M2 has 181 -- more and we prefer the one with more anyway. 182 183 if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then 184 Delete_Msg (M1, M2); 185 return; 186 187 -- If M2 continuatins have run out, we delete M2 188 189 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then 190 Delete_Msg (M2, M1); 191 return; 192 193 -- Otherwise see if continuations are the same, if not, keep both 194 -- sequences, a curious case, but better to keep everything! 195 196 elsif not Same_Error (N1, N2) then 197 return; 198 199 -- If continuations are the same, continue scan 200 201 else 202 L1 := N1; 203 L2 := N2; 204 end if; 205 end loop; 206 end Check_Duplicate_Message; 207 208 ------------------------ 209 -- Compilation_Errors -- 210 ------------------------ 211 212 function Compilation_Errors return Boolean is 213 begin 214 return Total_Errors_Detected /= 0 215 or else (Warnings_Detected /= 0 216 and then Warning_Mode = Treat_As_Error); 217 end Compilation_Errors; 218 219 ------------------ 220 -- Debug_Output -- 221 ------------------ 222 223 procedure Debug_Output (N : Node_Id) is 224 begin 225 if Debug_Flag_1 then 226 Write_Str ("*** following error message posted on node id = #"); 227 Write_Int (Int (N)); 228 Write_Str (" ***"); 229 Write_Eol; 230 end if; 231 end Debug_Output; 232 233 ---------- 234 -- dmsg -- 235 ---------- 236 237 procedure dmsg (Id : Error_Msg_Id) is 238 E : Error_Msg_Object renames Errors.Table (Id); 239 240 begin 241 w ("Dumping error message, Id = ", Int (Id)); 242 w (" Text = ", E.Text.all); 243 w (" Next = ", Int (E.Next)); 244 w (" Sfile = ", Int (E.Sfile)); 245 246 Write_Str 247 (" Sptr = "); 248 Write_Location (E.Sptr); 249 Write_Eol; 250 251 Write_Str 252 (" Optr = "); 253 Write_Location (E.Optr); 254 Write_Eol; 255 256 w (" Line = ", Int (E.Line)); 257 w (" Col = ", Int (E.Col)); 258 w (" Warn = ", E.Warn); 259 w (" Style = ", E.Style); 260 w (" Serious = ", E.Serious); 261 w (" Uncond = ", E.Uncond); 262 w (" Msg_Cont = ", E.Msg_Cont); 263 w (" Deleted = ", E.Deleted); 264 265 Write_Eol; 266 end dmsg; 267 268 ------------------ 269 -- Get_Location -- 270 ------------------ 271 272 function Get_Location (E : Error_Msg_Id) return Source_Ptr is 273 begin 274 return Errors.Table (E).Sptr; 275 end Get_Location; 276 277 ---------------- 278 -- Get_Msg_Id -- 279 ---------------- 280 281 function Get_Msg_Id return Error_Msg_Id is 282 begin 283 return Cur_Msg; 284 end Get_Msg_Id; 285 286 ----------------------- 287 -- Output_Error_Msgs -- 288 ----------------------- 289 290 procedure Output_Error_Msgs (E : in out Error_Msg_Id) is 291 P : Source_Ptr; 292 T : Error_Msg_Id; 293 S : Error_Msg_Id; 294 295 Flag_Num : Pos; 296 Mult_Flags : Boolean := False; 297 298 begin 299 S := E; 300 301 -- Skip deleted messages at start 302 303 if Errors.Table (S).Deleted then 304 Set_Next_Non_Deleted_Msg (S); 305 end if; 306 307 -- Figure out if we will place more than one error flag on this line 308 309 T := S; 310 while T /= No_Error_Msg 311 and then Errors.Table (T).Line = Errors.Table (E).Line 312 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile 313 loop 314 if Errors.Table (T).Sptr > Errors.Table (E).Sptr then 315 Mult_Flags := True; 316 end if; 317 318 Set_Next_Non_Deleted_Msg (T); 319 end loop; 320 321 -- Output the error flags. The circuit here makes sure that the tab 322 -- characters in the original line are properly accounted for. The 323 -- eight blanks at the start are to match the line number. 324 325 if not Debug_Flag_2 then 326 Write_Str (" "); 327 P := Line_Start (Errors.Table (E).Sptr); 328 Flag_Num := 1; 329 330 -- Loop through error messages for this line to place flags 331 332 T := S; 333 while T /= No_Error_Msg 334 and then Errors.Table (T).Line = Errors.Table (E).Line 335 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile 336 loop 337 -- Loop to output blanks till current flag position 338 339 while P < Errors.Table (T).Sptr loop 340 if Source_Text (Errors.Table (T).Sfile) (P) = ASCII.HT then 341 Write_Char (ASCII.HT); 342 else 343 Write_Char (' '); 344 end if; 345 346 P := P + 1; 347 end loop; 348 349 -- Output flag (unless already output, this happens if more 350 -- than one error message occurs at the same flag position). 351 352 if P = Errors.Table (T).Sptr then 353 if (Flag_Num = 1 and then not Mult_Flags) 354 or else Flag_Num > 9 355 then 356 Write_Char ('|'); 357 else 358 Write_Char (Character'Val (Character'Pos ('0') + Flag_Num)); 359 end if; 360 361 P := P + 1; 362 end if; 363 364 Set_Next_Non_Deleted_Msg (T); 365 Flag_Num := Flag_Num + 1; 366 end loop; 367 368 Write_Eol; 369 end if; 370 371 -- Now output the error messages 372 373 T := S; 374 while T /= No_Error_Msg 375 and then Errors.Table (T).Line = Errors.Table (E).Line 376 and then Errors.Table (T).Sfile = Errors.Table (E).Sfile 377 378 loop 379 Write_Str (" >>> "); 380 Output_Msg_Text (T); 381 382 if Debug_Flag_2 then 383 while Column < 74 loop 384 Write_Char (' '); 385 end loop; 386 387 Write_Str (" <<<"); 388 end if; 389 390 Write_Eol; 391 Set_Next_Non_Deleted_Msg (T); 392 end loop; 393 394 E := T; 395 end Output_Error_Msgs; 396 397 ------------------------ 398 -- Output_Line_Number -- 399 ------------------------ 400 401 procedure Output_Line_Number (L : Logical_Line_Number) is 402 D : Int; -- next digit 403 C : Character; -- next character 404 Z : Boolean; -- flag for zero suppress 405 N, M : Int; -- temporaries 406 407 begin 408 if L = No_Line_Number then 409 Write_Str (" "); 410 411 else 412 Z := False; 413 N := Int (L); 414 415 M := 100_000; 416 while M /= 0 loop 417 D := Int (N / M); 418 N := N rem M; 419 M := M / 10; 420 421 if D = 0 then 422 if Z then 423 C := '0'; 424 else 425 C := ' '; 426 end if; 427 else 428 Z := True; 429 C := Character'Val (D + 48); 430 end if; 431 432 Write_Char (C); 433 end loop; 434 435 Write_Str (". "); 436 end if; 437 end Output_Line_Number; 438 439 --------------------- 440 -- Output_Msg_Text -- 441 --------------------- 442 443 procedure Output_Msg_Text (E : Error_Msg_Id) is 444 begin 445 if Errors.Table (E).Warn then 446 Write_Str ("warning: "); 447 448 elsif Errors.Table (E).Style then 449 null; 450 451 elsif Opt.Unique_Error_Tag then 452 Write_Str ("error: "); 453 end if; 454 455 Write_Str (Errors.Table (E).Text.all); 456 end Output_Msg_Text; 457 458 -------------------- 459 -- Purge_Messages -- 460 -------------------- 461 462 procedure Purge_Messages (From : Source_Ptr; To : Source_Ptr) is 463 E : Error_Msg_Id; 464 465 function To_Be_Purged (E : Error_Msg_Id) return Boolean; 466 -- Returns True for a message that is to be purged. Also adjusts 467 -- error counts appropriately. 468 469 function To_Be_Purged (E : Error_Msg_Id) return Boolean is 470 begin 471 if E /= No_Error_Msg 472 and then Errors.Table (E).Sptr > From 473 and then Errors.Table (E).Sptr < To 474 then 475 if Errors.Table (E).Warn or Errors.Table (E).Style then 476 Warnings_Detected := Warnings_Detected - 1; 477 else 478 Total_Errors_Detected := Total_Errors_Detected - 1; 479 480 if Errors.Table (E).Serious then 481 Serious_Errors_Detected := Serious_Errors_Detected - 1; 482 end if; 483 end if; 484 485 return True; 486 487 else 488 return False; 489 end if; 490 end To_Be_Purged; 491 492 -- Start of processing for Purge_Messages 493 494 begin 495 while To_Be_Purged (First_Error_Msg) loop 496 First_Error_Msg := Errors.Table (First_Error_Msg).Next; 497 end loop; 498 499 E := First_Error_Msg; 500 while E /= No_Error_Msg loop 501 while To_Be_Purged (Errors.Table (E).Next) loop 502 Errors.Table (E).Next := 503 Errors.Table (Errors.Table (E).Next).Next; 504 end loop; 505 506 E := Errors.Table (E).Next; 507 end loop; 508 end Purge_Messages; 509 510 ---------------- 511 -- Same_Error -- 512 ---------------- 513 514 function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is 515 Msg1 : constant String_Ptr := Errors.Table (M1).Text; 516 Msg2 : constant String_Ptr := Errors.Table (M2).Text; 517 518 Msg2_Len : constant Integer := Msg2'Length; 519 Msg1_Len : constant Integer := Msg1'Length; 520 521 begin 522 return 523 Msg1.all = Msg2.all 524 or else 525 (Msg1_Len - 10 > Msg2_Len 526 and then 527 Msg2.all = Msg1.all (1 .. Msg2_Len) 528 and then 529 Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance") 530 or else 531 (Msg2_Len - 10 > Msg1_Len 532 and then 533 Msg1.all = Msg2.all (1 .. Msg1_Len) 534 and then 535 Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance"); 536 end Same_Error; 537 538 ------------------- 539 -- Set_Msg_Blank -- 540 ------------------- 541 542 procedure Set_Msg_Blank is 543 begin 544 if Msglen > 0 545 and then Msg_Buffer (Msglen) /= ' ' 546 and then Msg_Buffer (Msglen) /= '(' 547 and then not Manual_Quote_Mode 548 then 549 Set_Msg_Char (' '); 550 end if; 551 end Set_Msg_Blank; 552 553 ------------------------------- 554 -- Set_Msg_Blank_Conditional -- 555 ------------------------------- 556 557 procedure Set_Msg_Blank_Conditional is 558 begin 559 if Msglen > 0 560 and then Msg_Buffer (Msglen) /= ' ' 561 and then Msg_Buffer (Msglen) /= '(' 562 and then Msg_Buffer (Msglen) /= '"' 563 and then not Manual_Quote_Mode 564 then 565 Set_Msg_Char (' '); 566 end if; 567 end Set_Msg_Blank_Conditional; 568 569 ------------------ 570 -- Set_Msg_Char -- 571 ------------------ 572 573 procedure Set_Msg_Char (C : Character) is 574 begin 575 576 -- The check for message buffer overflow is needed to deal with cases 577 -- where insertions get too long (in particular a child unit name can 578 -- be very long). 579 580 if Msglen < Max_Msg_Length then 581 Msglen := Msglen + 1; 582 Msg_Buffer (Msglen) := C; 583 end if; 584 end Set_Msg_Char; 585 586 --------------------------------- 587 -- Set_Msg_Insertion_File_Name -- 588 --------------------------------- 589 590 procedure Set_Msg_Insertion_File_Name is 591 begin 592 if Error_Msg_Name_1 = No_Name then 593 null; 594 595 elsif Error_Msg_Name_1 = Error_Name then 596 Set_Msg_Blank; 597 Set_Msg_Str ("<error>"); 598 599 else 600 Set_Msg_Blank; 601 Get_Name_String (Error_Msg_Name_1); 602 Set_Msg_Quote; 603 Set_Msg_Name_Buffer; 604 Set_Msg_Quote; 605 end if; 606 607 -- The following assignments ensure that the second and third percent 608 -- insertion characters will correspond to the Error_Msg_Name_2 and 609 -- Error_Msg_Name_3 as required. 610 611 Error_Msg_Name_1 := Error_Msg_Name_2; 612 Error_Msg_Name_2 := Error_Msg_Name_3; 613 end Set_Msg_Insertion_File_Name; 614 615 ----------------------------------- 616 -- Set_Msg_Insertion_Line_Number -- 617 ----------------------------------- 618 619 procedure Set_Msg_Insertion_Line_Number (Loc, Flag : Source_Ptr) is 620 Sindex_Loc : Source_File_Index; 621 Sindex_Flag : Source_File_Index; 622 623 begin 624 Set_Msg_Blank; 625 626 if Loc = No_Location then 627 Set_Msg_Str ("at unknown location"); 628 629 elsif Loc = System_Location then 630 Set_Msg_Str ("in package System"); 631 Set_Msg_Insertion_Run_Time_Name; 632 633 elsif Loc = Standard_Location then 634 Set_Msg_Str ("in package Standard"); 635 636 elsif Loc = Standard_ASCII_Location then 637 Set_Msg_Str ("in package Standard.ASCII"); 638 639 else 640 -- Add "at file-name:" if reference is to other than the source 641 -- file in which the error message is placed. Note that we check 642 -- full file names, rather than just the source indexes, to 643 -- deal with generic instantiations from the current file. 644 645 Sindex_Loc := Get_Source_File_Index (Loc); 646 Sindex_Flag := Get_Source_File_Index (Flag); 647 648 if Full_File_Name (Sindex_Loc) /= Full_File_Name (Sindex_Flag) then 649 Set_Msg_Str ("at "); 650 Get_Name_String 651 (Reference_Name (Get_Source_File_Index (Loc))); 652 Set_Msg_Name_Buffer; 653 Set_Msg_Char (':'); 654 655 -- If in current file, add text "at line " 656 657 else 658 Set_Msg_Str ("at line "); 659 end if; 660 661 -- Output line number for reference 662 663 Set_Msg_Int (Int (Get_Logical_Line_Number (Loc))); 664 665 -- Deal with the instantiation case. We may have a reference to, 666 -- e.g. a type, that is declared within a generic template, and 667 -- what we are really referring to is the occurrence in an instance. 668 -- In this case, the line number of the instantiation is also of 669 -- interest, and we add a notation: 670 671 -- , instance at xxx 672 673 -- where xxx is a line number output using this same routine (and 674 -- the recursion can go further if the instantiation is itself in 675 -- a generic template). 676 677 -- The flag location passed to us in this situation is indeed the 678 -- line number within the template, but as described in Sinput.L 679 -- (file sinput-l.ads, section "Handling Generic Instantiations") 680 -- we can retrieve the location of the instantiation itself from 681 -- this flag location value. 682 683 -- Note: this processing is suppressed if Suppress_Instance_Location 684 -- is set True. This is used to prevent redundant annotations of the 685 -- location of the instantiation in the case where we are placing 686 -- the messages on the instantiation in any case. 687 688 if Instantiation (Sindex_Loc) /= No_Location 689 and then not Suppress_Instance_Location 690 then 691 Set_Msg_Str (", instance "); 692 Set_Msg_Insertion_Line_Number (Instantiation (Sindex_Loc), Flag); 693 end if; 694 end if; 695 end Set_Msg_Insertion_Line_Number; 696 697 ---------------------------- 698 -- Set_Msg_Insertion_Name -- 699 ---------------------------- 700 701 procedure Set_Msg_Insertion_Name is 702 begin 703 if Error_Msg_Name_1 = No_Name then 704 null; 705 706 elsif Error_Msg_Name_1 = Error_Name then 707 Set_Msg_Blank; 708 Set_Msg_Str ("<error>"); 709 710 else 711 Set_Msg_Blank_Conditional; 712 Get_Unqualified_Decoded_Name_String (Error_Msg_Name_1); 713 714 -- Remove %s or %b at end. These come from unit names. If the 715 -- caller wanted the (unit) or (body), then they would have used 716 -- the $ insertion character. Certainly no error message should 717 -- ever have %b or %s explicitly occurring. 718 719 if Name_Len > 2 720 and then Name_Buffer (Name_Len - 1) = '%' 721 and then (Name_Buffer (Name_Len) = 'b' 722 or else 723 Name_Buffer (Name_Len) = 's') 724 then 725 Name_Len := Name_Len - 2; 726 end if; 727 728 -- Remove upper case letter at end, again, we should not be getting 729 -- such names, and what we hope is that the remainder makes sense. 730 731 if Name_Len > 1 732 and then Name_Buffer (Name_Len) in 'A' .. 'Z' 733 then 734 Name_Len := Name_Len - 1; 735 end if; 736 737 -- If operator name or character literal name, just print it as is 738 -- Also print as is if it ends in a right paren (case of x'val(nnn)) 739 740 if Name_Buffer (1) = '"' 741 or else Name_Buffer (1) = ''' 742 or else Name_Buffer (Name_Len) = ')' 743 then 744 Set_Msg_Name_Buffer; 745 746 -- Else output with surrounding quotes in proper casing mode 747 748 else 749 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); 750 Set_Msg_Quote; 751 Set_Msg_Name_Buffer; 752 Set_Msg_Quote; 753 end if; 754 end if; 755 756 -- The following assignments ensure that the second and third percent 757 -- insertion characters will correspond to the Error_Msg_Name_2 and 758 -- Error_Msg_Name_3 as required. 759 760 Error_Msg_Name_1 := Error_Msg_Name_2; 761 Error_Msg_Name_2 := Error_Msg_Name_3; 762 end Set_Msg_Insertion_Name; 763 764 ------------------------------------- 765 -- Set_Msg_Insertion_Reserved_Name -- 766 ------------------------------------- 767 768 procedure Set_Msg_Insertion_Reserved_Name is 769 begin 770 Set_Msg_Blank_Conditional; 771 Get_Name_String (Error_Msg_Name_1); 772 Set_Msg_Quote; 773 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); 774 Set_Msg_Name_Buffer; 775 Set_Msg_Quote; 776 end Set_Msg_Insertion_Reserved_Name; 777 778 ------------------------------------- 779 -- Set_Msg_Insertion_Reserved_Word -- 780 ------------------------------------- 781 782 procedure Set_Msg_Insertion_Reserved_Word 783 (Text : String; 784 J : in out Integer) 785 is 786 begin 787 Set_Msg_Blank_Conditional; 788 Name_Len := 0; 789 790 while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop 791 Name_Len := Name_Len + 1; 792 Name_Buffer (Name_Len) := Text (J); 793 J := J + 1; 794 end loop; 795 796 Set_Casing (Keyword_Casing (Flag_Source), All_Lower_Case); 797 Set_Msg_Quote; 798 Set_Msg_Name_Buffer; 799 Set_Msg_Quote; 800 end Set_Msg_Insertion_Reserved_Word; 801 802 ------------------------------------- 803 -- Set_Msg_Insertion_Run_Time_Name -- 804 ------------------------------------- 805 806 procedure Set_Msg_Insertion_Run_Time_Name is 807 begin 808 if Targparm.Run_Time_Name_On_Target /= No_Name then 809 Set_Msg_Blank_Conditional; 810 Set_Msg_Char ('('); 811 Get_Name_String (Targparm.Run_Time_Name_On_Target); 812 Set_Casing (Mixed_Case); 813 Set_Msg_Str (Name_Buffer (1 .. Name_Len)); 814 Set_Msg_Char (')'); 815 end if; 816 end Set_Msg_Insertion_Run_Time_Name; 817 818 ---------------------------- 819 -- Set_Msg_Insertion_Uint -- 820 ---------------------------- 821 822 procedure Set_Msg_Insertion_Uint is 823 begin 824 Set_Msg_Blank; 825 UI_Image (Error_Msg_Uint_1); 826 827 for J in 1 .. UI_Image_Length loop 828 Set_Msg_Char (UI_Image_Buffer (J)); 829 end loop; 830 831 -- The following assignment ensures that a second carret insertion 832 -- character will correspond to the Error_Msg_Uint_2 parameter. 833 834 Error_Msg_Uint_1 := Error_Msg_Uint_2; 835 end Set_Msg_Insertion_Uint; 836 837 ----------------- 838 -- Set_Msg_Int -- 839 ----------------- 840 841 procedure Set_Msg_Int (Line : Int) is 842 begin 843 if Line > 9 then 844 Set_Msg_Int (Line / 10); 845 end if; 846 847 Set_Msg_Char (Character'Val (Character'Pos ('0') + (Line rem 10))); 848 end Set_Msg_Int; 849 850 ------------------------- 851 -- Set_Msg_Name_Buffer -- 852 ------------------------- 853 854 procedure Set_Msg_Name_Buffer is 855 begin 856 for J in 1 .. Name_Len loop 857 Set_Msg_Char (Name_Buffer (J)); 858 end loop; 859 end Set_Msg_Name_Buffer; 860 861 ------------------- 862 -- Set_Msg_Quote -- 863 ------------------- 864 865 procedure Set_Msg_Quote is 866 begin 867 if not Manual_Quote_Mode then 868 Set_Msg_Char ('"'); 869 end if; 870 end Set_Msg_Quote; 871 872 ----------------- 873 -- Set_Msg_Str -- 874 ----------------- 875 876 procedure Set_Msg_Str (Text : String) is 877 begin 878 for J in Text'Range loop 879 Set_Msg_Char (Text (J)); 880 end loop; 881 end Set_Msg_Str; 882 883 ------------------------------ 884 -- Set_Next_Non_Deleted_Msg -- 885 ------------------------------ 886 887 procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is 888 begin 889 if E = No_Error_Msg then 890 return; 891 892 else 893 loop 894 E := Errors.Table (E).Next; 895 exit when E = No_Error_Msg or else not Errors.Table (E).Deleted; 896 end loop; 897 end if; 898 end Set_Next_Non_Deleted_Msg; 899 900 --------------------------- 901 -- Set_Warnings_Mode_Off -- 902 --------------------------- 903 904 procedure Set_Warnings_Mode_Off (Loc : Source_Ptr) is 905 begin 906 -- Don't bother with entries from instantiation copies, since we 907 -- will already have a copy in the template, which is what matters 908 909 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then 910 return; 911 end if; 912 913 -- If last entry in table already covers us, this is a redundant 914 -- pragma Warnings (Off) and can be ignored. This also handles the 915 -- case where all warnings are suppressed by command line switch. 916 917 if Warnings.Last >= Warnings.First 918 and then Warnings.Table (Warnings.Last).Start <= Loc 919 and then Loc <= Warnings.Table (Warnings.Last).Stop 920 then 921 return; 922 923 -- Otherwise establish a new entry, extending from the location of 924 -- the pragma to the end of the current source file. This ending 925 -- point will be adjusted by a subsequent pragma Warnings (On). 926 927 else 928 Warnings.Increment_Last; 929 Warnings.Table (Warnings.Last).Start := Loc; 930 Warnings.Table (Warnings.Last).Stop := 931 Source_Last (Current_Source_File); 932 end if; 933 end Set_Warnings_Mode_Off; 934 935 -------------------------- 936 -- Set_Warnings_Mode_On -- 937 -------------------------- 938 939 procedure Set_Warnings_Mode_On (Loc : Source_Ptr) is 940 begin 941 -- Don't bother with entries from instantiation copies, since we 942 -- will already have a copy in the template, which is what matters 943 944 if Instantiation (Get_Source_File_Index (Loc)) /= No_Location then 945 return; 946 end if; 947 948 -- Nothing to do unless command line switch to suppress all warnings 949 -- is off, and the last entry in the warnings table covers this 950 -- pragma Warnings (On), in which case adjust the end point. 951 952 if (Warnings.Last >= Warnings.First 953 and then Warnings.Table (Warnings.Last).Start <= Loc 954 and then Loc <= Warnings.Table (Warnings.Last).Stop) 955 and then Warning_Mode /= Suppress 956 then 957 Warnings.Table (Warnings.Last).Stop := Loc; 958 end if; 959 end Set_Warnings_Mode_On; 960 961 ------------------------------------ 962 -- Test_Style_Warning_Serious_Msg -- 963 ------------------------------------ 964 965 procedure Test_Style_Warning_Serious_Msg (Msg : String) is 966 begin 967 if Msg (Msg'First) = '\' then 968 return; 969 end if; 970 971 Is_Serious_Error := True; 972 Is_Warning_Msg := False; 973 974 Is_Style_Msg := 975 (Msg'Length > 7 976 and then Msg (Msg'First .. Msg'First + 6) = "(style)"); 977 978 for J in Msg'Range loop 979 if Msg (J) = '?' 980 and then (J = Msg'First or else Msg (J - 1) /= ''') 981 then 982 Is_Warning_Msg := True; 983 984 elsif Msg (J) = '|' 985 and then (J = Msg'First or else Msg (J - 1) /= ''') 986 then 987 Is_Serious_Error := False; 988 end if; 989 end loop; 990 991 if Is_Warning_Msg or else Is_Style_Msg then 992 Is_Serious_Error := False; 993 end if; 994 end Test_Style_Warning_Serious_Msg; 995 996 ------------------------- 997 -- Warnings_Suppressed -- 998 ------------------------- 999 1000 function Warnings_Suppressed (Loc : Source_Ptr) return Boolean is 1001 begin 1002 for J in Warnings.First .. Warnings.Last loop 1003 if Warnings.Table (J).Start <= Loc 1004 and then Loc <= Warnings.Table (J).Stop 1005 then 1006 return True; 1007 end if; 1008 end loop; 1009 1010 return False; 1011 end Warnings_Suppressed; 1012 1013end Erroutc; 1014