1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- E R R O U T -- 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 Atree; use Atree; 34with Casing; use Casing; 35with Csets; use Csets; 36with Debug; use Debug; 37with Einfo; use Einfo; 38with Erroutc; use Erroutc; 39with Fname; use Fname; 40with Lib; use Lib; 41with Namet; use Namet; 42with Opt; use Opt; 43with Nlists; use Nlists; 44with Output; use Output; 45with Scans; use Scans; 46with Sinput; use Sinput; 47with Sinfo; use Sinfo; 48with Snames; use Snames; 49with Stand; use Stand; 50with Style; 51with Uintp; use Uintp; 52with Uname; use Uname; 53 54with Unchecked_Conversion; 55 56package body Errout is 57 58 Errors_Must_Be_Ignored : Boolean := False; 59 -- Set to True by procedure Set_Ignore_Errors (True), when calls to 60 -- error message procedures should be ignored (when parsing irrelevant 61 -- text in sources being preprocessed). 62 63 Warn_On_Instance : Boolean; 64 -- Flag set true for warning message to be posted on instance 65 66 ------------------------------------ 67 -- Table of Non-Instance Messages -- 68 ------------------------------------ 69 70 -- This table contains an entry for every error message processed by the 71 -- Error_Msg routine that is not posted on generic (or inlined) instance. 72 -- As explained in further detail in the Error_Msg procedure body, this 73 -- table is used to avoid posting redundant messages on instances. 74 75 type NIM_Record is record 76 Msg : String_Ptr; 77 Loc : Source_Ptr; 78 end record; 79 -- Type used to store text and location of one message 80 81 package Non_Instance_Msgs is new Table.Table ( 82 Table_Component_Type => NIM_Record, 83 Table_Index_Type => Int, 84 Table_Low_Bound => 1, 85 Table_Initial => 100, 86 Table_Increment => 100, 87 Table_Name => "Non_Instance_Msgs"); 88 89 ----------------------- 90 -- Local Subprograms -- 91 ----------------------- 92 93 procedure Error_Msg_Internal 94 (Msg : String; 95 Sptr : Source_Ptr; 96 Optr : Source_Ptr; 97 Msg_Cont : Boolean); 98 -- This is the low level routine used to post messages after dealing with 99 -- the issue of messages placed on instantiations (which get broken up 100 -- into separate calls in Error_Msg). Sptr is the location on which the 101 -- flag will be placed in the output. In the case where the flag is on 102 -- the template, this points directly to the template, not to one of the 103 -- instantiation copies of the template. Optr is the original location 104 -- used to flag the error, and this may indeed point to an instantiation 105 -- copy. So typically we can see Optr pointing to the template location 106 -- in an instantiation copy when Sptr points to the source location of 107 -- the actual instantiation (i.e the line with the new). Msg_Cont is 108 -- set true if this is a continuation message. 109 110 function No_Warnings (N : Node_Or_Entity_Id) return Boolean; 111 -- Determines if warnings should be suppressed for the given node 112 113 function OK_Node (N : Node_Id) return Boolean; 114 -- Determines if a node is an OK node to place an error message on (return 115 -- True) or if the error message should be suppressed (return False). A 116 -- message is suppressed if the node already has an error posted on it, 117 -- or if it refers to an Etype that has an error posted on it, or if 118 -- it references an Entity that has an error posted on it. 119 120 procedure Output_Source_Line 121 (L : Physical_Line_Number; 122 Sfile : Source_File_Index; 123 Errs : Boolean); 124 -- Outputs text of source line L, in file S, together with preceding line 125 -- number, as described above for Output_Line_Number. The Errs parameter 126 -- indicates if there are errors attached to the line, which forces 127 -- listing on, even in the presence of pragma List (Off). 128 129 procedure Set_Msg_Insertion_Column; 130 -- Handle column number insertion (@ insertion character) 131 132 procedure Set_Msg_Insertion_Node; 133 -- Handle node (name from node) insertion (& insertion character) 134 135 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr); 136 -- Handle type reference (right brace insertion character). Flag is the 137 -- location of the flag, which is provided for the internal call to 138 -- Set_Msg_Insertion_Line_Number, 139 140 procedure Set_Msg_Insertion_Unit_Name; 141 -- Handle unit name insertion ($ insertion character) 142 143 procedure Set_Msg_Node (Node : Node_Id); 144 -- Add the sequence of characters for the name associated with the 145 -- given node to the current message. 146 147 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); 148 -- Add a sequence of characters to the current message. The characters may 149 -- be one of the special insertion characters (see documentation in spec). 150 -- Flag is the location at which the error is to be posted, which is used 151 -- to determine whether or not the # insertion needs a file name. The 152 -- variables Msg_Buffer, Msglen, Is_Style_Msg, Is_Warning_Msg, and 153 -- Is_Unconditional_Msg are set on return. 154 155 procedure Set_Posted (N : Node_Id); 156 -- Sets the Error_Posted flag on the given node, and all its parents 157 -- that are subexpressions and then on the parent non-subexpression 158 -- construct that contains the original expression (this reduces the 159 -- number of cascaded messages). Note that this call only has an effect 160 -- for a serious error. For a non-serious error, it has no effect. 161 162 procedure Set_Qualification (N : Nat; E : Entity_Id); 163 -- Outputs up to N levels of qualification for the given entity. For 164 -- example, the entity A.B.C.D will output B.C. if N = 2. 165 166 function Special_Msg_Delete 167 (Msg : String; 168 N : Node_Or_Entity_Id; 169 E : Node_Or_Entity_Id) 170 return Boolean; 171 -- This function is called from Error_Msg_NEL, passing the message Msg, 172 -- node N on which the error is to be posted, and the entity or node E 173 -- to be used for an & insertion in the message if any. The job of this 174 -- procedure is to test for certain cascaded messages that we would like 175 -- to suppress. If the message is to be suppressed then we return True. 176 -- If the message should be generated (the normal case) False is returned. 177 178 procedure Unwind_Internal_Type (Ent : in out Entity_Id); 179 -- This procedure is given an entity id for an internal type, i.e. 180 -- a type with an internal name. It unwinds the type to try to get 181 -- to something reasonably printable, generating prefixes like 182 -- "subtype of", "access to", etc along the way in the buffer. The 183 -- value in Ent on return is the final name to be printed. Hopefully 184 -- this is not an internal name, but in some internal name cases, it 185 -- is an internal name, and has to be printed anyway (although in this 186 -- case the message has been killed if possible). The global variable 187 -- Class_Flag is set to True if the resulting entity should have 188 -- 'Class appended to its name (see Add_Class procedure), and is 189 -- otherwise unchanged. 190 191 ----------------------- 192 -- Change_Error_Text -- 193 ----------------------- 194 195 procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is 196 Save_Next : Error_Msg_Id; 197 Err_Id : Error_Msg_Id := Error_Id; 198 199 begin 200 Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr); 201 Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen)); 202 203 -- If in immediate error message mode, output modified error message now 204 -- This is just a bit tricky, because we want to output just a single 205 -- message, and the messages we modified is already linked in. We solve 206 -- this by temporarily resetting its forward pointer to empty. 207 208 if Debug_Flag_OO then 209 Save_Next := Errors.Table (Error_Id).Next; 210 Errors.Table (Error_Id).Next := No_Error_Msg; 211 Write_Eol; 212 Output_Source_Line 213 (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True); 214 Output_Error_Msgs (Err_Id); 215 Errors.Table (Error_Id).Next := Save_Next; 216 end if; 217 end Change_Error_Text; 218 219 --------------- 220 -- Error_Msg -- 221 --------------- 222 223 -- Error_Msg posts a flag at the given location, except that if the 224 -- Flag_Location points within a generic template and corresponds 225 -- to an instantiation of this generic template, then the actual 226 -- message will be posted on the generic instantiation, along with 227 -- additional messages referencing the generic declaration. 228 229 procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is 230 Sindex : Source_File_Index; 231 -- Source index for flag location 232 233 Orig_Loc : Source_Ptr; 234 -- Original location of Flag_Location (i.e. location in original 235 -- template in instantiation case, otherwise unchanged). 236 237 begin 238 -- It is a fatal error to issue an error message when scanning from 239 -- the internal source buffer (see Sinput for further documentation) 240 241 pragma Assert (Sinput.Source /= Internal_Source_Ptr); 242 243 -- Return if all errors are to be ignored 244 245 if Errors_Must_Be_Ignored then 246 return; 247 end if; 248 249 -- If we already have messages, and we are trying to place a message 250 -- at No_Location or in package Standard, then just ignore the attempt 251 -- since we assume that what is happening is some cascaded junk. Note 252 -- that this is safe in the sense that proceeding will surely bomb. 253 254 if Flag_Location < First_Source_Ptr 255 and then Total_Errors_Detected > 0 256 then 257 return; 258 end if; 259 260 -- Start procesing of new message 261 262 Sindex := Get_Source_File_Index (Flag_Location); 263 Test_Style_Warning_Serious_Msg (Msg); 264 Orig_Loc := Original_Location (Flag_Location); 265 266 -- If the current location is in an instantiation, the issue arises 267 -- of whether to post the message on the template or the instantiation. 268 269 -- The way we decide is to see if we have posted the same message 270 -- on the template when we compiled the template (the template is 271 -- always compiled before any instantiations). For this purpose, 272 -- we use a separate table of messages. The reason we do this is 273 -- twofold: 274 275 -- First, the messages can get changed by various processing 276 -- including the insertion of tokens etc, making it hard to 277 -- do the comparison. 278 279 -- Second, we will suppress a warning on a template if it is 280 -- not in the current extended source unit. That's reasonable 281 -- and means we don't want the warning on the instantiation 282 -- here either, but it does mean that the main error table 283 -- would not in any case include the message. 284 285 if Flag_Location = Orig_Loc then 286 Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location)); 287 Warn_On_Instance := False; 288 289 -- Here we have an instance message 290 291 else 292 -- Delete if debug flag off, and this message duplicates a 293 -- message already posted on the corresponding template 294 295 if not Debug_Flag_GG then 296 for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop 297 if Msg = Non_Instance_Msgs.Table (J).Msg.all 298 and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc 299 then 300 return; 301 end if; 302 end loop; 303 end if; 304 305 -- No duplicate, so error/warning will be posted on instance 306 307 Warn_On_Instance := Is_Warning_Msg; 308 end if; 309 310 -- Ignore warning message that is suppressed. Note that style 311 -- checks are not considered warning messages for this purpose 312 313 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) then 314 return; 315 end if; 316 317 -- The idea at this stage is that we have two kinds of messages. 318 319 -- First, we have those that are to be placed as requested at 320 -- Flag_Location. This includes messages that have nothing to 321 -- do with generics, and also messages placed on generic templates 322 -- that reflect an error in the template itself. For such messages 323 -- we simply call Error_Msg_Internal to place the message in the 324 -- requested location. 325 326 if Instantiation (Sindex) = No_Location then 327 Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False); 328 return; 329 end if; 330 331 -- If we are trying to flag an error in an instantiation, we may have 332 -- a generic contract violation. What we generate in this case is: 333 334 -- instantiation error at ... 335 -- original error message 336 337 -- or 338 339 -- warning: in instantiation at 340 -- warning: original warning message 341 342 -- All these messages are posted at the location of the top level 343 -- instantiation. If there are nested instantiations, then the 344 -- instantiation error message can be repeated, pointing to each 345 -- of the relevant instantiations. 346 347 -- Note: the instantiation mechanism is also shared for inlining 348 -- of subprogram bodies when front end inlining is done. In this 349 -- case the messages have the form: 350 351 -- in inlined body at ... 352 -- original error message 353 354 -- or 355 356 -- warning: in inlined body at 357 -- warning: original warning message 358 359 -- OK, this is the case where we have an instantiation error, and 360 -- we need to generate the error on the instantiation, rather than 361 -- on the template. 362 363 declare 364 Actual_Error_Loc : Source_Ptr; 365 -- Location of outer level instantiation in instantiation case, or 366 -- just a copy of Flag_Location in the normal case. This is the 367 -- location where all error messages will actually be posted. 368 369 Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc; 370 -- Save possible location set for caller's message. We need to 371 -- use Error_Msg_Sloc for the location of the instantiation error 372 -- but we have to preserve a possible original value. 373 374 X : Source_File_Index; 375 376 Msg_Cont_Status : Boolean; 377 -- Used to label continuation lines in instantiation case with 378 -- proper Msg_Cont status. 379 380 begin 381 -- Loop to find highest level instantiation, where all error 382 -- messages will be placed. 383 384 X := Sindex; 385 loop 386 Actual_Error_Loc := Instantiation (X); 387 X := Get_Source_File_Index (Actual_Error_Loc); 388 exit when Instantiation (X) = No_Location; 389 end loop; 390 391 -- Since we are generating the messages at the instantiation 392 -- point in any case, we do not want the references to the 393 -- bad lines in the instance to be annotated with the location 394 -- of the instantiation. 395 396 Suppress_Instance_Location := True; 397 Msg_Cont_Status := False; 398 399 -- Loop to generate instantiation messages 400 401 Error_Msg_Sloc := Flag_Location; 402 X := Get_Source_File_Index (Flag_Location); 403 404 while Instantiation (X) /= No_Location loop 405 406 -- Suppress instantiation message on continuation lines 407 408 if Msg (Msg'First) /= '\' then 409 410 -- Case of inlined body 411 412 if Inlined_Body (X) then 413 if Is_Warning_Msg then 414 Error_Msg_Internal 415 ("?in inlined body #", 416 Actual_Error_Loc, Flag_Location, Msg_Cont_Status); 417 418 else 419 Error_Msg_Internal 420 ("error in inlined body #", 421 Actual_Error_Loc, Flag_Location, Msg_Cont_Status); 422 end if; 423 424 -- Case of generic instantiation 425 426 else 427 if Is_Warning_Msg then 428 Error_Msg_Internal 429 ("?in instantiation #", 430 Actual_Error_Loc, Flag_Location, Msg_Cont_Status); 431 432 else 433 Error_Msg_Internal 434 ("instantiation error #", 435 Actual_Error_Loc, Flag_Location, Msg_Cont_Status); 436 end if; 437 end if; 438 end if; 439 440 Error_Msg_Sloc := Instantiation (X); 441 X := Get_Source_File_Index (Error_Msg_Sloc); 442 Msg_Cont_Status := True; 443 end loop; 444 445 Suppress_Instance_Location := False; 446 Error_Msg_Sloc := Save_Error_Msg_Sloc; 447 448 -- Here we output the original message on the outer instantiation 449 450 Error_Msg_Internal 451 (Msg, Actual_Error_Loc, Flag_Location, Msg_Cont_Status); 452 end; 453 end Error_Msg; 454 455 ------------------ 456 -- Error_Msg_AP -- 457 ------------------ 458 459 procedure Error_Msg_AP (Msg : String) is 460 S1 : Source_Ptr; 461 C : Character; 462 463 begin 464 -- If we had saved the Scan_Ptr value after scanning the previous 465 -- token, then we would have exactly the right place for putting 466 -- the flag immediately at hand. However, that would add at least 467 -- two instructions to a Scan call *just* to service the possibility 468 -- of an Error_Msg_AP call. So instead we reconstruct that value. 469 470 -- We have two possibilities, start with Prev_Token_Ptr and skip over 471 -- the current token, which is made harder by the possibility that this 472 -- token may be in error, or start with Token_Ptr and work backwards. 473 -- We used to take the second approach, but it's hard because of 474 -- comments, and harder still because things that look like comments 475 -- can appear inside strings. So now we take the first approach. 476 477 -- Note: in the case where there is no previous token, Prev_Token_Ptr 478 -- is set to Source_First, which is a reasonable position for the 479 -- error flag in this situation. 480 481 S1 := Prev_Token_Ptr; 482 C := Source (S1); 483 484 -- If the previous token is a string literal, we need a special approach 485 -- since there may be white space inside the literal and we don't want 486 -- to stop on that white space. 487 488 if Prev_Token = Tok_String_Literal then 489 loop 490 S1 := S1 + 1; 491 492 if Source (S1) = C then 493 S1 := S1 + 1; 494 exit when Source (S1) /= C; 495 elsif Source (S1) in Line_Terminator then 496 exit; 497 end if; 498 end loop; 499 500 -- Character literal also needs special handling 501 502 elsif Prev_Token = Tok_Char_Literal then 503 S1 := S1 + 3; 504 505 -- Otherwise we search forward for the end of the current token, marked 506 -- by a line terminator, white space, a comment symbol or if we bump 507 -- into the following token (i.e. the current token) 508 509 else 510 while Source (S1) not in Line_Terminator 511 and then Source (S1) /= ' ' 512 and then Source (S1) /= ASCII.HT 513 and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-') 514 and then S1 /= Token_Ptr 515 loop 516 S1 := S1 + 1; 517 end loop; 518 end if; 519 520 -- S1 is now set to the location for the flag 521 522 Error_Msg (Msg, S1); 523 524 end Error_Msg_AP; 525 526 ------------------ 527 -- Error_Msg_BC -- 528 ------------------ 529 530 procedure Error_Msg_BC (Msg : String) is 531 begin 532 -- If we are at end of file, post the flag after the previous token 533 534 if Token = Tok_EOF then 535 Error_Msg_AP (Msg); 536 537 -- If we are at start of file, post the flag at the current token 538 539 elsif Token_Ptr = Source_First (Current_Source_File) then 540 Error_Msg_SC (Msg); 541 542 -- If the character before the current token is a space or a horizontal 543 -- tab, then we place the flag on this character (in the case of a tab 544 -- we would really like to place it in the "last" character of the tab 545 -- space, but that it too much trouble to worry about). 546 547 elsif Source (Token_Ptr - 1) = ' ' 548 or else Source (Token_Ptr - 1) = ASCII.HT 549 then 550 Error_Msg (Msg, Token_Ptr - 1); 551 552 -- If there is no space or tab before the current token, then there is 553 -- no room to place the flag before the token, so we place it on the 554 -- token instead (this happens for example at the start of a line). 555 556 else 557 Error_Msg (Msg, Token_Ptr); 558 end if; 559 end Error_Msg_BC; 560 561 ------------------- 562 -- Error_Msg_CRT -- 563 ------------------- 564 565 procedure Error_Msg_CRT (Feature : String; N : Node_Id) is 566 CNRT : constant String := " not allowed in no run time mode"; 567 CCRT : constant String := " not supported by configuration>"; 568 569 S : String (1 .. Feature'Length + 1 + CCRT'Length); 570 L : Natural; 571 572 573 begin 574 S (1) := '|'; 575 S (2 .. Feature'Length + 1) := Feature; 576 L := Feature'Length + 2; 577 578 if No_Run_Time_Mode then 579 S (L .. L + CNRT'Length - 1) := CNRT; 580 L := L + CNRT'Length - 1; 581 582 else pragma Assert (Configurable_Run_Time_Mode); 583 S (L .. L + CCRT'Length - 1) := CCRT; 584 L := L + CCRT'Length - 1; 585 end if; 586 587 Error_Msg_N (S (1 .. L), N); 588 Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1; 589 end Error_Msg_CRT; 590 591 ----------------- 592 -- Error_Msg_F -- 593 ----------------- 594 595 procedure Error_Msg_F (Msg : String; N : Node_Id) is 596 SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); 597 SF : constant Source_Ptr := Source_First (SI); 598 F : Node_Id; 599 S : Source_Ptr; 600 601 begin 602 F := First_Node (N); 603 S := Sloc (F); 604 605 -- The following circuit is a bit subtle. When we have parenthesized 606 -- expressions, then the Sloc will not record the location of the 607 -- paren, but we would like to post the flag on the paren. So what 608 -- we do is to crawl up the tree from the First_Node, adjusting the 609 -- Sloc value for any parentheses we know are present. Yes, we know 610 -- this circuit is not 100% reliable (e.g. because we don't record 611 -- all possible paren level valoues), but this is only for an error 612 -- message so it is good enough. 613 614 Node_Loop : loop 615 Paren_Loop : for J in 1 .. Paren_Count (F) loop 616 617 -- We don't look more than 12 characters behind the current 618 -- location, and in any case not past the front of the source. 619 620 Search_Loop : for K in 1 .. 12 loop 621 exit Search_Loop when S = SF; 622 623 if Source_Text (SI) (S - 1) = '(' then 624 S := S - 1; 625 exit Search_Loop; 626 627 elsif Source_Text (SI) (S - 1) <= ' ' then 628 S := S - 1; 629 630 else 631 exit Search_Loop; 632 end if; 633 end loop Search_Loop; 634 end loop Paren_Loop; 635 636 exit Node_Loop when F = N; 637 F := Parent (F); 638 exit Node_Loop when Nkind (F) not in N_Subexpr; 639 end loop Node_Loop; 640 641 Error_Msg_NEL (Msg, N, N, S); 642 end Error_Msg_F; 643 644 ------------------ 645 -- Error_Msg_FE -- 646 ------------------ 647 648 procedure Error_Msg_FE 649 (Msg : String; 650 N : Node_Id; 651 E : Node_Or_Entity_Id) 652 is 653 begin 654 Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N))); 655 end Error_Msg_FE; 656 657 ------------------------ 658 -- Error_Msg_Internal -- 659 ------------------------ 660 661 procedure Error_Msg_Internal 662 (Msg : String; 663 Sptr : Source_Ptr; 664 Optr : Source_Ptr; 665 Msg_Cont : Boolean) 666 is 667 Next_Msg : Error_Msg_Id; 668 -- Pointer to next message at insertion point 669 670 Prev_Msg : Error_Msg_Id; 671 -- Pointer to previous message at insertion point 672 673 Temp_Msg : Error_Msg_Id; 674 675 procedure Handle_Serious_Error; 676 -- Internal procedure to do all error message handling for a serious 677 -- error message, other than bumping the error counts and arranging 678 -- for the message to be output. 679 680 -------------------------- 681 -- Handle_Serious_Error -- 682 -------------------------- 683 684 procedure Handle_Serious_Error is 685 begin 686 -- Turn off code generation if not done already 687 688 if Operating_Mode = Generate_Code then 689 Operating_Mode := Check_Semantics; 690 Expander_Active := False; 691 end if; 692 693 -- Set the fatal error flag in the unit table unless we are 694 -- in Try_Semantics mode. This stops the semantics from being 695 -- performed if we find a serious error. This is skipped if we 696 -- are currently dealing with the configuration pragma file. 697 698 if not Try_Semantics 699 and then Current_Source_Unit /= No_Unit 700 then 701 Set_Fatal_Error (Get_Source_Unit (Sptr)); 702 end if; 703 end Handle_Serious_Error; 704 705 -- Start of processing for Error_Msg_Internal 706 707 begin 708 if Raise_Exception_On_Error /= 0 then 709 raise Error_Msg_Exception; 710 end if; 711 712 Continuation := Msg_Cont; 713 Suppress_Message := False; 714 Kill_Message := False; 715 Set_Msg_Text (Msg, Sptr); 716 717 -- Kill continuation if parent message killed 718 719 if Continuation and Last_Killed then 720 return; 721 end if; 722 723 -- Return without doing anything if message is suppressed 724 725 if Suppress_Message 726 and not All_Errors_Mode 727 and not (Msg (Msg'Last) = '!') 728 then 729 if not Continuation then 730 Last_Killed := True; 731 end if; 732 733 return; 734 end if; 735 736 -- Return without doing anything if message is killed and this 737 -- is not the first error message. The philosophy is that if we 738 -- get a weird error message and we already have had a message, 739 -- then we hope the weird message is a junk cascaded message 740 741 if Kill_Message 742 and then not All_Errors_Mode 743 and then Total_Errors_Detected /= 0 744 then 745 if not Continuation then 746 Last_Killed := True; 747 end if; 748 749 return; 750 end if; 751 752 -- Special check for warning message to see if it should be output 753 754 if Is_Warning_Msg then 755 756 -- Immediate return if warning message and warnings are suppressed 757 758 if Warnings_Suppressed (Optr) 759 or else Warnings_Suppressed (Sptr) 760 then 761 Cur_Msg := No_Error_Msg; 762 return; 763 end if; 764 765 -- If the flag location is in the main extended source unit 766 -- then for sure we want the warning since it definitely belongs 767 768 if In_Extended_Main_Source_Unit (Sptr) then 769 null; 770 771 -- If the flag location is not in the main extended source 772 -- unit then we want to eliminate the warning. 773 774 elsif In_Extended_Main_Code_Unit (Sptr) 775 and then Warn_On_Instance 776 then 777 null; 778 779 -- Keep warning if debug flag G set 780 781 elsif Debug_Flag_GG then 782 null; 783 784 -- Here is where we delete a warning from a with'ed unit 785 786 else 787 Cur_Msg := No_Error_Msg; 788 return; 789 end if; 790 end if; 791 792 -- If message is to be ignored in special ignore message mode, this is 793 -- where we do this special processing, bypassing message output. 794 795 if Ignore_Errors_Enable > 0 then 796 if Is_Serious_Error then 797 Handle_Serious_Error; 798 end if; 799 800 return; 801 end if; 802 803 -- Otherwise build error message object for new message 804 805 Errors.Increment_Last; 806 Cur_Msg := Errors.Last; 807 Errors.Table (Cur_Msg).Text := new String'(Msg_Buffer (1 .. Msglen)); 808 Errors.Table (Cur_Msg).Next := No_Error_Msg; 809 Errors.Table (Cur_Msg).Sptr := Sptr; 810 Errors.Table (Cur_Msg).Optr := Optr; 811 Errors.Table (Cur_Msg).Sfile := Get_Source_File_Index (Sptr); 812 Errors.Table (Cur_Msg).Line := Get_Physical_Line_Number (Sptr); 813 Errors.Table (Cur_Msg).Col := Get_Column_Number (Sptr); 814 Errors.Table (Cur_Msg).Warn := Is_Warning_Msg; 815 Errors.Table (Cur_Msg).Style := Is_Style_Msg; 816 Errors.Table (Cur_Msg).Serious := Is_Serious_Error; 817 Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg; 818 Errors.Table (Cur_Msg).Msg_Cont := Continuation; 819 Errors.Table (Cur_Msg).Deleted := False; 820 821 -- If immediate errors mode set, output error message now. Also output 822 -- now if the -d1 debug flag is set (so node number message comes out 823 -- just before actual error message) 824 825 if Debug_Flag_OO or else Debug_Flag_1 then 826 Write_Eol; 827 Output_Source_Line (Errors.Table (Cur_Msg).Line, 828 Errors.Table (Cur_Msg).Sfile, True); 829 Temp_Msg := Cur_Msg; 830 Output_Error_Msgs (Temp_Msg); 831 832 -- If not in immediate errors mode, then we insert the message in the 833 -- error chain for later output by Finalize. The messages are sorted 834 -- first by unit (main unit comes first), and within a unit by source 835 -- location (earlier flag location first in the chain). 836 837 else 838 -- First a quick check, does this belong at the very end of the 839 -- chain of error messages. This saves a lot of time in the 840 -- normal case if there are lots of messages. 841 842 if Last_Error_Msg /= No_Error_Msg 843 and then Errors.Table (Cur_Msg).Sfile = 844 Errors.Table (Last_Error_Msg).Sfile 845 and then (Sptr > Errors.Table (Last_Error_Msg).Sptr 846 or else 847 (Sptr = Errors.Table (Last_Error_Msg).Sptr 848 and then 849 Optr > Errors.Table (Last_Error_Msg).Optr)) 850 then 851 Prev_Msg := Last_Error_Msg; 852 Next_Msg := No_Error_Msg; 853 854 -- Otherwise do a full sequential search for the insertion point 855 856 else 857 Prev_Msg := No_Error_Msg; 858 Next_Msg := First_Error_Msg; 859 while Next_Msg /= No_Error_Msg loop 860 exit when 861 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; 862 863 if Errors.Table (Cur_Msg).Sfile = 864 Errors.Table (Next_Msg).Sfile 865 then 866 exit when Sptr < Errors.Table (Next_Msg).Sptr 867 or else 868 (Sptr = Errors.Table (Next_Msg).Sptr 869 and then 870 Optr < Errors.Table (Next_Msg).Optr); 871 end if; 872 873 Prev_Msg := Next_Msg; 874 Next_Msg := Errors.Table (Next_Msg).Next; 875 end loop; 876 end if; 877 878 -- Now we insert the new message in the error chain. The insertion 879 -- point for the message is after Prev_Msg and before Next_Msg. 880 881 -- The possible insertion point for the new message is after Prev_Msg 882 -- and before Next_Msg. However, this is where we do a special check 883 -- for redundant parsing messages, defined as messages posted on the 884 -- same line. The idea here is that probably such messages are junk 885 -- from the parser recovering. In full errors mode, we don't do this 886 -- deletion, but otherwise such messages are discarded at this stage. 887 888 if Prev_Msg /= No_Error_Msg 889 and then Errors.Table (Prev_Msg).Line = 890 Errors.Table (Cur_Msg).Line 891 and then Errors.Table (Prev_Msg).Sfile = 892 Errors.Table (Cur_Msg).Sfile 893 and then Compiler_State = Parsing 894 and then not All_Errors_Mode 895 then 896 -- Don't delete unconditional messages and at this stage, 897 -- don't delete continuation lines (we attempted to delete 898 -- those earlier if the parent message was deleted. 899 900 if not Errors.Table (Cur_Msg).Uncond 901 and then not Continuation 902 then 903 -- Don't delete if prev msg is warning and new msg is 904 -- an error. This is because we don't want a real error 905 -- masked by a warning. In all other cases (that is parse 906 -- errors for the same line that are not unconditional) 907 -- we do delete the message. This helps to avoid 908 -- junk extra messages from cascaded parsing errors 909 910 if not (Errors.Table (Prev_Msg).Warn 911 or 912 Errors.Table (Prev_Msg).Style) 913 or else 914 (Errors.Table (Cur_Msg).Warn 915 or 916 Errors.Table (Cur_Msg).Style) 917 then 918 -- All tests passed, delete the message by simply 919 -- returning without any further processing. 920 921 if not Continuation then 922 Last_Killed := True; 923 end if; 924 925 return; 926 end if; 927 end if; 928 end if; 929 930 -- Come here if message is to be inserted in the error chain 931 932 if not Continuation then 933 Last_Killed := False; 934 end if; 935 936 if Prev_Msg = No_Error_Msg then 937 First_Error_Msg := Cur_Msg; 938 else 939 Errors.Table (Prev_Msg).Next := Cur_Msg; 940 end if; 941 942 Errors.Table (Cur_Msg).Next := Next_Msg; 943 944 if Next_Msg = No_Error_Msg then 945 Last_Error_Msg := Cur_Msg; 946 end if; 947 end if; 948 949 -- Bump appropriate statistics count 950 951 if Errors.Table (Cur_Msg).Warn 952 or else Errors.Table (Cur_Msg).Style 953 then 954 Warnings_Detected := Warnings_Detected + 1; 955 else 956 Total_Errors_Detected := Total_Errors_Detected + 1; 957 958 if Errors.Table (Cur_Msg).Serious then 959 Serious_Errors_Detected := Serious_Errors_Detected + 1; 960 Handle_Serious_Error; 961 end if; 962 end if; 963 964 -- Terminate if max errors reached 965 966 if Total_Errors_Detected + Warnings_Detected = Maximum_Errors then 967 raise Unrecoverable_Error; 968 end if; 969 970 end Error_Msg_Internal; 971 972 ----------------- 973 -- Error_Msg_N -- 974 ----------------- 975 976 procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is 977 begin 978 Error_Msg_NEL (Msg, N, N, Sloc (N)); 979 end Error_Msg_N; 980 981 ------------------ 982 -- Error_Msg_NE -- 983 ------------------ 984 985 procedure Error_Msg_NE 986 (Msg : String; 987 N : Node_Or_Entity_Id; 988 E : Node_Or_Entity_Id) 989 is 990 begin 991 Error_Msg_NEL (Msg, N, E, Sloc (N)); 992 end Error_Msg_NE; 993 994 ------------------- 995 -- Error_Msg_NEL -- 996 ------------------- 997 998 procedure Error_Msg_NEL 999 (Msg : String; 1000 N : Node_Or_Entity_Id; 1001 E : Node_Or_Entity_Id; 1002 Flag_Location : Source_Ptr) 1003 is 1004 begin 1005 if Special_Msg_Delete (Msg, N, E) then 1006 return; 1007 end if; 1008 1009 Test_Style_Warning_Serious_Msg (Msg); 1010 1011 -- Special handling for warning messages 1012 1013 if Is_Warning_Msg then 1014 1015 -- Suppress if no warnings set for either entity or node 1016 1017 if No_Warnings (N) or else No_Warnings (E) then 1018 return; 1019 end if; 1020 1021 -- Suppress if inside loop that is known to be null 1022 1023 declare 1024 P : Node_Id; 1025 1026 begin 1027 P := Parent (N); 1028 while Present (P) loop 1029 if Nkind (P) = N_Loop_Statement and then Is_Null_Loop (P) then 1030 return; 1031 end if; 1032 1033 P := Parent (P); 1034 end loop; 1035 end; 1036 end if; 1037 1038 -- Test for message to be output 1039 1040 if All_Errors_Mode 1041 or else Msg (Msg'Last) = '!' 1042 or else OK_Node (N) 1043 or else (Msg (Msg'First) = '\' and not Last_Killed) 1044 then 1045 Debug_Output (N); 1046 Error_Msg_Node_1 := E; 1047 Error_Msg (Msg, Flag_Location); 1048 1049 else 1050 Last_Killed := True; 1051 end if; 1052 1053 if not Is_Warning_Msg and then not Is_Style_Msg then 1054 Set_Posted (N); 1055 end if; 1056 end Error_Msg_NEL; 1057 1058 ------------------ 1059 -- Error_Msg_NW -- 1060 ------------------ 1061 1062 procedure Error_Msg_NW 1063 (Eflag : Boolean; 1064 Msg : String; 1065 N : Node_Or_Entity_Id) 1066 is 1067 begin 1068 if Eflag and then In_Extended_Main_Source_Unit (N) then 1069 Error_Msg_NEL (Msg, N, N, Sloc (N)); 1070 end if; 1071 end Error_Msg_NW; 1072 1073 ----------------- 1074 -- Error_Msg_S -- 1075 ----------------- 1076 1077 procedure Error_Msg_S (Msg : String) is 1078 begin 1079 Error_Msg (Msg, Scan_Ptr); 1080 end Error_Msg_S; 1081 1082 ------------------ 1083 -- Error_Msg_SC -- 1084 ------------------ 1085 1086 procedure Error_Msg_SC (Msg : String) is 1087 begin 1088 -- If we are at end of file, post the flag after the previous token 1089 1090 if Token = Tok_EOF then 1091 Error_Msg_AP (Msg); 1092 1093 -- For all other cases the message is posted at the current token 1094 -- pointer position 1095 1096 else 1097 Error_Msg (Msg, Token_Ptr); 1098 end if; 1099 end Error_Msg_SC; 1100 1101 ------------------ 1102 -- Error_Msg_SP -- 1103 ------------------ 1104 1105 procedure Error_Msg_SP (Msg : String) is 1106 begin 1107 -- Note: in the case where there is no previous token, Prev_Token_Ptr 1108 -- is set to Source_First, which is a reasonable position for the 1109 -- error flag in this situation 1110 1111 Error_Msg (Msg, Prev_Token_Ptr); 1112 end Error_Msg_SP; 1113 1114 -------------- 1115 -- Finalize -- 1116 -------------- 1117 1118 procedure Finalize is 1119 Cur : Error_Msg_Id; 1120 Nxt : Error_Msg_Id; 1121 E, F : Error_Msg_Id; 1122 Err_Flag : Boolean; 1123 1124 begin 1125 -- Reset current error source file if the main unit has a pragma 1126 -- Source_Reference. This ensures outputting the proper name of 1127 -- the source file in this situation. 1128 1129 if Num_SRef_Pragmas (Main_Source_File) /= 0 then 1130 Current_Error_Source_File := No_Source_File; 1131 end if; 1132 1133 -- Eliminate any duplicated error messages from the list. This is 1134 -- done after the fact to avoid problems with Change_Error_Text. 1135 1136 Cur := First_Error_Msg; 1137 while Cur /= No_Error_Msg loop 1138 Nxt := Errors.Table (Cur).Next; 1139 1140 F := Nxt; 1141 while F /= No_Error_Msg 1142 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr 1143 loop 1144 Check_Duplicate_Message (Cur, F); 1145 F := Errors.Table (F).Next; 1146 end loop; 1147 1148 Cur := Nxt; 1149 end loop; 1150 1151 -- Brief Error mode 1152 1153 if Brief_Output or (not Full_List and not Verbose_Mode) then 1154 E := First_Error_Msg; 1155 Set_Standard_Error; 1156 1157 while E /= No_Error_Msg loop 1158 if not Errors.Table (E).Deleted and then not Debug_Flag_KK then 1159 if Full_Path_Name_For_Brief_Errors then 1160 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); 1161 else 1162 Write_Name (Reference_Name (Errors.Table (E).Sfile)); 1163 end if; 1164 1165 Write_Char (':'); 1166 Write_Int (Int (Physical_To_Logical 1167 (Errors.Table (E).Line, 1168 Errors.Table (E).Sfile))); 1169 Write_Char (':'); 1170 1171 if Errors.Table (E).Col < 10 then 1172 Write_Char ('0'); 1173 end if; 1174 1175 Write_Int (Int (Errors.Table (E).Col)); 1176 Write_Str (": "); 1177 Output_Msg_Text (E); 1178 Write_Eol; 1179 end if; 1180 1181 E := Errors.Table (E).Next; 1182 end loop; 1183 1184 Set_Standard_Output; 1185 end if; 1186 1187 -- Full source listing case 1188 1189 if Full_List then 1190 List_Pragmas_Index := 1; 1191 List_Pragmas_Mode := True; 1192 E := First_Error_Msg; 1193 Write_Eol; 1194 1195 -- First list initial main source file with its error messages 1196 1197 for N in 1 .. Last_Source_Line (Main_Source_File) loop 1198 Err_Flag := 1199 E /= No_Error_Msg 1200 and then Errors.Table (E).Line = N 1201 and then Errors.Table (E).Sfile = Main_Source_File; 1202 1203 Output_Source_Line (N, Main_Source_File, Err_Flag); 1204 1205 if Err_Flag then 1206 Output_Error_Msgs (E); 1207 1208 if not Debug_Flag_2 then 1209 Write_Eol; 1210 end if; 1211 end if; 1212 1213 end loop; 1214 1215 -- Then output errors, if any, for subsidiary units 1216 1217 while E /= No_Error_Msg 1218 and then Errors.Table (E).Sfile /= Main_Source_File 1219 loop 1220 Write_Eol; 1221 Output_Source_Line 1222 (Errors.Table (E).Line, Errors.Table (E).Sfile, True); 1223 Output_Error_Msgs (E); 1224 end loop; 1225 end if; 1226 1227 -- Verbose mode (error lines only with error flags) 1228 1229 if Verbose_Mode and not Full_List then 1230 E := First_Error_Msg; 1231 1232 -- Loop through error lines 1233 1234 while E /= No_Error_Msg loop 1235 Write_Eol; 1236 Output_Source_Line 1237 (Errors.Table (E).Line, Errors.Table (E).Sfile, True); 1238 Output_Error_Msgs (E); 1239 end loop; 1240 end if; 1241 1242 -- Output error summary if verbose or full list mode 1243 1244 if Verbose_Mode or else Full_List then 1245 1246 -- Extra blank line if error messages or source listing were output 1247 1248 if Total_Errors_Detected + Warnings_Detected > 0 1249 or else Full_List 1250 then 1251 Write_Eol; 1252 end if; 1253 1254 -- Message giving number of lines read and number of errors detected. 1255 -- This normally goes to Standard_Output. The exception is when brief 1256 -- mode is not set, verbose mode (or full list mode) is set, and 1257 -- there are errors. In this case we send the message to standard 1258 -- error to make sure that *something* appears on standard error in 1259 -- an error situation. 1260 1261 -- Formerly, only the "# errors" suffix was sent to stderr, whereas 1262 -- "# lines:" appeared on stdout. This caused problems on VMS when 1263 -- the stdout buffer was flushed, giving an extra line feed after 1264 -- the prefix. 1265 1266 if Total_Errors_Detected + Warnings_Detected /= 0 1267 and then not Brief_Output 1268 and then (Verbose_Mode or Full_List) 1269 then 1270 Set_Standard_Error; 1271 end if; 1272 1273 -- Message giving total number of lines 1274 1275 Write_Str (" "); 1276 Write_Int (Num_Source_Lines (Main_Source_File)); 1277 1278 if Num_Source_Lines (Main_Source_File) = 1 then 1279 Write_Str (" line: "); 1280 else 1281 Write_Str (" lines: "); 1282 end if; 1283 1284 if Total_Errors_Detected = 0 then 1285 Write_Str ("No errors"); 1286 1287 elsif Total_Errors_Detected = 1 then 1288 Write_Str ("1 error"); 1289 1290 else 1291 Write_Int (Total_Errors_Detected); 1292 Write_Str (" errors"); 1293 end if; 1294 1295 if Warnings_Detected /= 0 then 1296 Write_Str (", "); 1297 Write_Int (Warnings_Detected); 1298 Write_Str (" warning"); 1299 1300 if Warnings_Detected /= 1 then 1301 Write_Char ('s'); 1302 end if; 1303 1304 if Warning_Mode = Treat_As_Error then 1305 Write_Str (" (treated as error"); 1306 1307 if Warnings_Detected /= 1 then 1308 Write_Char ('s'); 1309 end if; 1310 1311 Write_Char (')'); 1312 end if; 1313 end if; 1314 1315 Write_Eol; 1316 Set_Standard_Output; 1317 end if; 1318 1319 if Maximum_Errors /= 0 1320 and then Total_Errors_Detected + Warnings_Detected = Maximum_Errors 1321 then 1322 Set_Standard_Error; 1323 Write_Str ("fatal error: maximum errors reached"); 1324 Write_Eol; 1325 Set_Standard_Output; 1326 end if; 1327 1328 if Warning_Mode = Treat_As_Error then 1329 Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; 1330 Warnings_Detected := 0; 1331 end if; 1332 end Finalize; 1333 1334 ---------------- 1335 -- First_Node -- 1336 ---------------- 1337 1338 function First_Node (C : Node_Id) return Node_Id is 1339 L : constant Source_Ptr := Sloc (C); 1340 Sfile : constant Source_File_Index := Get_Source_File_Index (L); 1341 Earliest : Node_Id; 1342 Eloc : Source_Ptr; 1343 Discard : Traverse_Result; 1344 1345 pragma Warnings (Off, Discard); 1346 1347 function Test_Earlier (N : Node_Id) return Traverse_Result; 1348 -- Function applied to every node in the construct 1349 1350 function Search_Tree_First is new Traverse_Func (Test_Earlier); 1351 -- Create traversal function 1352 1353 ------------------ 1354 -- Test_Earlier -- 1355 ------------------ 1356 1357 function Test_Earlier (N : Node_Id) return Traverse_Result is 1358 Loc : constant Source_Ptr := Sloc (N); 1359 1360 begin 1361 -- Check for earlier. The tests for being in the same file ensures 1362 -- against strange cases of foreign code somehow being present. We 1363 -- don't want wild placement of messages if that happens, so it is 1364 -- best to just ignore this situation. 1365 1366 if Loc < Eloc 1367 and then Get_Source_File_Index (Loc) = Sfile 1368 then 1369 Earliest := N; 1370 Eloc := Loc; 1371 end if; 1372 1373 return OK_Orig; 1374 end Test_Earlier; 1375 1376 -- Start of processing for First_Node 1377 1378 begin 1379 Earliest := Original_Node (C); 1380 Eloc := Sloc (Earliest); 1381 Discard := Search_Tree_First (Original_Node (C)); 1382 return Earliest; 1383 end First_Node; 1384 1385 1386 ---------------- 1387 -- Initialize -- 1388 ---------------- 1389 1390 procedure Initialize is 1391 begin 1392 Errors.Init; 1393 First_Error_Msg := No_Error_Msg; 1394 Last_Error_Msg := No_Error_Msg; 1395 Serious_Errors_Detected := 0; 1396 Total_Errors_Detected := 0; 1397 Warnings_Detected := 0; 1398 Cur_Msg := No_Error_Msg; 1399 List_Pragmas.Init; 1400 1401 -- Initialize warnings table, if all warnings are suppressed, supply 1402 -- an initial dummy entry covering all possible source locations. 1403 1404 Warnings.Init; 1405 1406 if Warning_Mode = Suppress then 1407 Warnings.Increment_Last; 1408 Warnings.Table (Warnings.Last).Start := Source_Ptr'First; 1409 Warnings.Table (Warnings.Last).Stop := Source_Ptr'Last; 1410 end if; 1411 1412 -- Set the error nodes to Empty to avoid uninitialized variable 1413 -- references for saves/restores/moves. 1414 1415 Error_Msg_Node_1 := Empty; 1416 Error_Msg_Node_2 := Empty; 1417 end Initialize; 1418 1419 ----------------- 1420 -- No_Warnings -- 1421 ----------------- 1422 1423 function No_Warnings (N : Node_Or_Entity_Id) return Boolean is 1424 begin 1425 if Error_Posted (N) then 1426 return True; 1427 1428 elsif Nkind (N) in N_Entity and then Warnings_Off (N) then 1429 return True; 1430 1431 elsif Is_Entity_Name (N) 1432 and then Present (Entity (N)) 1433 and then Warnings_Off (Entity (N)) 1434 then 1435 return True; 1436 1437 else 1438 return False; 1439 end if; 1440 end No_Warnings; 1441 1442 ------------- 1443 -- OK_Node -- 1444 ------------- 1445 1446 function OK_Node (N : Node_Id) return Boolean is 1447 K : constant Node_Kind := Nkind (N); 1448 1449 begin 1450 if Error_Posted (N) then 1451 return False; 1452 1453 elsif K in N_Has_Etype 1454 and then Present (Etype (N)) 1455 and then Error_Posted (Etype (N)) 1456 then 1457 return False; 1458 1459 elsif (K in N_Op 1460 or else K = N_Attribute_Reference 1461 or else K = N_Character_Literal 1462 or else K = N_Expanded_Name 1463 or else K = N_Identifier 1464 or else K = N_Operator_Symbol) 1465 and then Present (Entity (N)) 1466 and then Error_Posted (Entity (N)) 1467 then 1468 return False; 1469 else 1470 return True; 1471 end if; 1472 end OK_Node; 1473 1474 ------------------------ 1475 -- Output_Source_Line -- 1476 ------------------------ 1477 1478 procedure Output_Source_Line 1479 (L : Physical_Line_Number; 1480 Sfile : Source_File_Index; 1481 Errs : Boolean) 1482 is 1483 S : Source_Ptr; 1484 C : Character; 1485 1486 Line_Number_Output : Boolean := False; 1487 -- Set True once line number is output 1488 1489 begin 1490 if Sfile /= Current_Error_Source_File then 1491 Write_Str ("==============Error messages for "); 1492 1493 case Sinput.File_Type (Sfile) is 1494 when Sinput.Src => 1495 Write_Str ("source"); 1496 1497 when Sinput.Config => 1498 Write_Str ("configuration pragmas"); 1499 1500 when Sinput.Def => 1501 Write_Str ("symbol definition"); 1502 1503 when Sinput.Preproc => 1504 Write_Str ("preprocessing data"); 1505 end case; 1506 1507 Write_Str (" file: "); 1508 Write_Name (Full_File_Name (Sfile)); 1509 Write_Eol; 1510 1511 if Num_SRef_Pragmas (Sfile) > 0 then 1512 Write_Str ("--------------Line numbers from file: "); 1513 Write_Name (Full_Ref_Name (Sfile)); 1514 Write_Str (" (starting at line "); 1515 Write_Int (Int (First_Mapped_Line (Sfile))); 1516 Write_Char (')'); 1517 Write_Eol; 1518 end if; 1519 1520 Current_Error_Source_File := Sfile; 1521 end if; 1522 1523 if Errs or List_Pragmas_Mode then 1524 Output_Line_Number (Physical_To_Logical (L, Sfile)); 1525 Line_Number_Output := True; 1526 end if; 1527 1528 S := Line_Start (L, Sfile); 1529 1530 loop 1531 C := Source_Text (Sfile) (S); 1532 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; 1533 1534 -- Deal with matching entry in List_Pragmas table 1535 1536 if Full_List 1537 and then List_Pragmas_Index <= List_Pragmas.Last 1538 and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc 1539 then 1540 case List_Pragmas.Table (List_Pragmas_Index).Ptyp is 1541 when Page => 1542 Write_Char (C); 1543 1544 -- Ignore if on line with errors so that error flags 1545 -- get properly listed with the error line . 1546 1547 if not Errs then 1548 Write_Char (ASCII.FF); 1549 end if; 1550 1551 when List_On => 1552 List_Pragmas_Mode := True; 1553 1554 if not Line_Number_Output then 1555 Output_Line_Number (Physical_To_Logical (L, Sfile)); 1556 Line_Number_Output := True; 1557 end if; 1558 1559 Write_Char (C); 1560 1561 when List_Off => 1562 Write_Char (C); 1563 List_Pragmas_Mode := False; 1564 end case; 1565 1566 List_Pragmas_Index := List_Pragmas_Index + 1; 1567 1568 -- Normal case (no matching entry in List_Pragmas table) 1569 1570 else 1571 if Errs or List_Pragmas_Mode then 1572 Write_Char (C); 1573 end if; 1574 end if; 1575 1576 S := S + 1; 1577 end loop; 1578 1579 if Line_Number_Output then 1580 Write_Eol; 1581 end if; 1582 end Output_Source_Line; 1583 1584 ----------------------------- 1585 -- Remove_Warning_Messages -- 1586 ----------------------------- 1587 1588 procedure Remove_Warning_Messages (N : Node_Id) is 1589 1590 function Check_For_Warning (N : Node_Id) return Traverse_Result; 1591 -- This function checks one node for a possible warning message. 1592 1593 function Check_All_Warnings is new 1594 Traverse_Func (Check_For_Warning); 1595 -- This defines the traversal operation 1596 1597 ----------------------- 1598 -- Check_For_Warning -- 1599 ----------------------- 1600 1601 function Check_For_Warning (N : Node_Id) return Traverse_Result is 1602 Loc : constant Source_Ptr := Sloc (N); 1603 E : Error_Msg_Id; 1604 1605 function To_Be_Removed (E : Error_Msg_Id) return Boolean; 1606 -- Returns True for a message that is to be removed. Also adjusts 1607 -- warning count appropriately. 1608 1609 ------------------- 1610 -- To_Be_Removed -- 1611 ------------------- 1612 1613 function To_Be_Removed (E : Error_Msg_Id) return Boolean is 1614 begin 1615 if E /= No_Error_Msg 1616 and then Errors.Table (E).Optr = Loc 1617 and then (Errors.Table (E).Warn or Errors.Table (E).Style) 1618 then 1619 Warnings_Detected := Warnings_Detected - 1; 1620 return True; 1621 else 1622 return False; 1623 end if; 1624 end To_Be_Removed; 1625 1626 -- Start of processing for Check_For_Warnings 1627 1628 begin 1629 while To_Be_Removed (First_Error_Msg) loop 1630 First_Error_Msg := Errors.Table (First_Error_Msg).Next; 1631 end loop; 1632 1633 if First_Error_Msg = No_Error_Msg then 1634 Last_Error_Msg := No_Error_Msg; 1635 end if; 1636 1637 E := First_Error_Msg; 1638 while E /= No_Error_Msg loop 1639 while To_Be_Removed (Errors.Table (E).Next) loop 1640 Errors.Table (E).Next := 1641 Errors.Table (Errors.Table (E).Next).Next; 1642 1643 if Errors.Table (E).Next = No_Error_Msg then 1644 Last_Error_Msg := E; 1645 end if; 1646 end loop; 1647 1648 E := Errors.Table (E).Next; 1649 end loop; 1650 1651 if Nkind (N) = N_Raise_Constraint_Error 1652 and then Original_Node (N) /= N 1653 and then No (Condition (N)) 1654 then 1655 -- Warnings may have been posted on subexpressions of 1656 -- the original tree. We place the original node back 1657 -- on the tree to remove those warnings, whose sloc 1658 -- do not match those of any node in the current tree. 1659 -- Given that we are in unreachable code, this modification 1660 -- to the tree is harmless. 1661 1662 declare 1663 Status : Traverse_Result; 1664 1665 begin 1666 if Is_List_Member (N) then 1667 Set_Condition (N, Original_Node (N)); 1668 Status := Check_All_Warnings (Condition (N)); 1669 else 1670 Rewrite (N, Original_Node (N)); 1671 Status := Check_All_Warnings (N); 1672 end if; 1673 1674 return Status; 1675 end; 1676 1677 else 1678 return OK; 1679 end if; 1680 end Check_For_Warning; 1681 1682 -- Start of processing for Remove_Warning_Messages 1683 1684 begin 1685 if Warnings_Detected /= 0 then 1686 declare 1687 Discard : Traverse_Result; 1688 pragma Warnings (Off, Discard); 1689 1690 begin 1691 Discard := Check_All_Warnings (N); 1692 end; 1693 end if; 1694 end Remove_Warning_Messages; 1695 1696 procedure Remove_Warning_Messages (L : List_Id) is 1697 Stat : Node_Id; 1698 begin 1699 if Is_Non_Empty_List (L) then 1700 Stat := First (L); 1701 1702 while Present (Stat) loop 1703 Remove_Warning_Messages (Stat); 1704 Next (Stat); 1705 end loop; 1706 end if; 1707 end Remove_Warning_Messages; 1708 1709 --------------------------- 1710 -- Set_Identifier_Casing -- 1711 --------------------------- 1712 1713 procedure Set_Identifier_Casing 1714 (Identifier_Name : System.Address; 1715 File_Name : System.Address) 1716 is 1717 type Big_String is array (Positive) of Character; 1718 type Big_String_Ptr is access all Big_String; 1719 1720 function To_Big_String_Ptr is new Unchecked_Conversion 1721 (System.Address, Big_String_Ptr); 1722 1723 Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name); 1724 File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name); 1725 Flen : Natural; 1726 1727 Desired_Case : Casing_Type := Mixed_Case; 1728 -- Casing required for result. Default value of Mixed_Case is used if 1729 -- for some reason we cannot find the right file name in the table. 1730 1731 1732 begin 1733 -- Get length of file name 1734 1735 Flen := 0; 1736 while File (Flen + 1) /= ASCII.NUL loop 1737 Flen := Flen + 1; 1738 end loop; 1739 1740 -- Loop through file names to find matching one. This is a bit slow, 1741 -- but we only do it in error situations so it is not so terrible. 1742 -- Note that if the loop does not exit, then the desired case will 1743 -- be left set to Mixed_Case, this can happen if the name was not 1744 -- in canonical form, and gets canonicalized on VMS. Possibly we 1745 -- could fix this by unconditinally canonicalizing these names ??? 1746 1747 for J in 1 .. Last_Source_File loop 1748 Get_Name_String (Full_Debug_Name (J)); 1749 1750 if Name_Len = Flen 1751 and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen)) 1752 then 1753 Desired_Case := Identifier_Casing (J); 1754 exit; 1755 end if; 1756 end loop; 1757 1758 -- Copy identifier as given to Name_Buffer 1759 1760 for J in Name_Buffer'Range loop 1761 Name_Buffer (J) := Ident (J); 1762 1763 if Name_Buffer (J) = ASCII.Nul then 1764 Name_Len := J - 1; 1765 exit; 1766 end if; 1767 end loop; 1768 1769 Set_Casing (Desired_Case); 1770 end Set_Identifier_Casing; 1771 1772 ----------------------- 1773 -- Set_Ignore_Errors -- 1774 ----------------------- 1775 1776 procedure Set_Ignore_Errors (To : Boolean) is 1777 begin 1778 Errors_Must_Be_Ignored := To; 1779 end Set_Ignore_Errors; 1780 1781 ------------------------------ 1782 -- Set_Msg_Insertion_Column -- 1783 ------------------------------ 1784 1785 procedure Set_Msg_Insertion_Column is 1786 begin 1787 if Style.RM_Column_Check then 1788 Set_Msg_Str (" in column "); 1789 Set_Msg_Int (Int (Error_Msg_Col) + 1); 1790 end if; 1791 end Set_Msg_Insertion_Column; 1792 1793 ---------------------------- 1794 -- Set_Msg_Insertion_Node -- 1795 ---------------------------- 1796 1797 procedure Set_Msg_Insertion_Node is 1798 begin 1799 Suppress_Message := 1800 Error_Msg_Node_1 = Error 1801 or else Error_Msg_Node_1 = Any_Type; 1802 1803 if Error_Msg_Node_1 = Empty then 1804 Set_Msg_Blank_Conditional; 1805 Set_Msg_Str ("<empty>"); 1806 1807 elsif Error_Msg_Node_1 = Error then 1808 Set_Msg_Blank; 1809 Set_Msg_Str ("<error>"); 1810 1811 elsif Error_Msg_Node_1 = Standard_Void_Type then 1812 Set_Msg_Blank; 1813 Set_Msg_Str ("procedure name"); 1814 1815 else 1816 Set_Msg_Blank_Conditional; 1817 1818 -- Skip quotes for operator case 1819 1820 if Nkind (Error_Msg_Node_1) in N_Op then 1821 Set_Msg_Node (Error_Msg_Node_1); 1822 1823 else 1824 Set_Msg_Quote; 1825 Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1); 1826 Set_Msg_Node (Error_Msg_Node_1); 1827 Set_Msg_Quote; 1828 end if; 1829 end if; 1830 1831 -- The following assignment ensures that a second ampersand insertion 1832 -- character will correspond to the Error_Msg_Node_2 parameter. 1833 1834 Error_Msg_Node_1 := Error_Msg_Node_2; 1835 end Set_Msg_Insertion_Node; 1836 1837 -------------------------------------- 1838 -- Set_Msg_Insertion_Type_Reference -- 1839 -------------------------------------- 1840 1841 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is 1842 Ent : Entity_Id; 1843 1844 begin 1845 Set_Msg_Blank; 1846 1847 if Error_Msg_Node_1 = Standard_Void_Type then 1848 Set_Msg_Str ("package or procedure name"); 1849 return; 1850 1851 elsif Error_Msg_Node_1 = Standard_Exception_Type then 1852 Set_Msg_Str ("exception name"); 1853 return; 1854 1855 elsif Error_Msg_Node_1 = Any_Access 1856 or else Error_Msg_Node_1 = Any_Array 1857 or else Error_Msg_Node_1 = Any_Boolean 1858 or else Error_Msg_Node_1 = Any_Character 1859 or else Error_Msg_Node_1 = Any_Composite 1860 or else Error_Msg_Node_1 = Any_Discrete 1861 or else Error_Msg_Node_1 = Any_Fixed 1862 or else Error_Msg_Node_1 = Any_Integer 1863 or else Error_Msg_Node_1 = Any_Modular 1864 or else Error_Msg_Node_1 = Any_Numeric 1865 or else Error_Msg_Node_1 = Any_Real 1866 or else Error_Msg_Node_1 = Any_Scalar 1867 or else Error_Msg_Node_1 = Any_String 1868 then 1869 Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1)); 1870 Set_Msg_Name_Buffer; 1871 return; 1872 1873 elsif Error_Msg_Node_1 = Universal_Real then 1874 Set_Msg_Str ("type universal real"); 1875 return; 1876 1877 elsif Error_Msg_Node_1 = Universal_Integer then 1878 Set_Msg_Str ("type universal integer"); 1879 return; 1880 1881 elsif Error_Msg_Node_1 = Universal_Fixed then 1882 Set_Msg_Str ("type universal fixed"); 1883 return; 1884 end if; 1885 1886 -- Special case of anonymous array 1887 1888 if Nkind (Error_Msg_Node_1) in N_Entity 1889 and then Is_Array_Type (Error_Msg_Node_1) 1890 and then Present (Related_Array_Object (Error_Msg_Node_1)) 1891 then 1892 Set_Msg_Str ("type of "); 1893 Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1)); 1894 Set_Msg_Str (" declared"); 1895 Set_Msg_Insertion_Line_Number 1896 (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag); 1897 return; 1898 end if; 1899 1900 -- If we fall through, it is not a special case, so first output 1901 -- the name of the type, preceded by private for a private type 1902 1903 if Is_Private_Type (Error_Msg_Node_1) then 1904 Set_Msg_Str ("private type "); 1905 else 1906 Set_Msg_Str ("type "); 1907 end if; 1908 1909 Ent := Error_Msg_Node_1; 1910 1911 if Is_Internal_Name (Chars (Ent)) then 1912 Unwind_Internal_Type (Ent); 1913 end if; 1914 1915 -- Types in Standard are displayed as "Standard.name" 1916 1917 if Sloc (Ent) <= Standard_Location then 1918 Set_Msg_Quote; 1919 Set_Msg_Str ("Standard."); 1920 Set_Msg_Node (Ent); 1921 Add_Class; 1922 Set_Msg_Quote; 1923 1924 -- Types in other language defined units are displayed as 1925 -- "package-name.type-name" 1926 1927 elsif 1928 Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Ent))) 1929 then 1930 Get_Unqualified_Decoded_Name_String 1931 (Unit_Name (Get_Source_Unit (Ent))); 1932 Name_Len := Name_Len - 2; 1933 Set_Msg_Quote; 1934 Set_Casing (Mixed_Case); 1935 Set_Msg_Name_Buffer; 1936 Set_Msg_Char ('.'); 1937 Set_Casing (Mixed_Case); 1938 Set_Msg_Node (Ent); 1939 Add_Class; 1940 Set_Msg_Quote; 1941 1942 -- All other types display as "type name" defined at line xxx 1943 -- possibly qualified if qualification is requested. 1944 1945 else 1946 Set_Msg_Quote; 1947 Set_Qualification (Error_Msg_Qual_Level, Ent); 1948 Set_Msg_Node (Ent); 1949 Add_Class; 1950 Set_Msg_Quote; 1951 end if; 1952 1953 -- If the original type did not come from a predefined 1954 -- file, add the location where the type was defined. 1955 1956 if Sloc (Error_Msg_Node_1) > Standard_Location 1957 and then 1958 not Is_Predefined_File_Name 1959 (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1))) 1960 then 1961 Set_Msg_Str (" defined"); 1962 Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag); 1963 1964 -- If it did come from a predefined file, deal with the case where 1965 -- this was a file with a generic instantiation from elsewhere. 1966 1967 else 1968 if Sloc (Error_Msg_Node_1) > Standard_Location then 1969 declare 1970 Iloc : constant Source_Ptr := 1971 Instantiation_Location (Sloc (Error_Msg_Node_1)); 1972 1973 begin 1974 if Iloc /= No_Location 1975 and then not Suppress_Instance_Location 1976 then 1977 Set_Msg_Str (" from instance"); 1978 Set_Msg_Insertion_Line_Number (Iloc, Flag); 1979 end if; 1980 end; 1981 end if; 1982 end if; 1983 end Set_Msg_Insertion_Type_Reference; 1984 1985 --------------------------------- 1986 -- Set_Msg_Insertion_Unit_Name -- 1987 --------------------------------- 1988 1989 procedure Set_Msg_Insertion_Unit_Name is 1990 begin 1991 if Error_Msg_Unit_1 = No_Name then 1992 null; 1993 1994 elsif Error_Msg_Unit_1 = Error_Name then 1995 Set_Msg_Blank; 1996 Set_Msg_Str ("<error>"); 1997 1998 else 1999 Get_Unit_Name_String (Error_Msg_Unit_1); 2000 Set_Msg_Blank; 2001 Set_Msg_Quote; 2002 Set_Msg_Name_Buffer; 2003 Set_Msg_Quote; 2004 end if; 2005 2006 -- The following assignment ensures that a second percent insertion 2007 -- character will correspond to the Error_Msg_Unit_2 parameter. 2008 2009 Error_Msg_Unit_1 := Error_Msg_Unit_2; 2010 end Set_Msg_Insertion_Unit_Name; 2011 2012 ------------------ 2013 -- Set_Msg_Node -- 2014 ------------------ 2015 2016 procedure Set_Msg_Node (Node : Node_Id) is 2017 Ent : Entity_Id; 2018 Nam : Name_Id; 2019 2020 begin 2021 if Nkind (Node) = N_Designator then 2022 Set_Msg_Node (Name (Node)); 2023 Set_Msg_Char ('.'); 2024 Set_Msg_Node (Identifier (Node)); 2025 return; 2026 2027 elsif Nkind (Node) = N_Defining_Program_Unit_Name then 2028 Set_Msg_Node (Name (Node)); 2029 Set_Msg_Char ('.'); 2030 Set_Msg_Node (Defining_Identifier (Node)); 2031 return; 2032 2033 elsif Nkind (Node) = N_Selected_Component then 2034 Set_Msg_Node (Prefix (Node)); 2035 Set_Msg_Char ('.'); 2036 Set_Msg_Node (Selector_Name (Node)); 2037 return; 2038 end if; 2039 2040 -- The only remaining possibilities are identifiers, defining 2041 -- identifiers, pragmas, and pragma argument associations, i.e. 2042 -- nodes that have a Chars field. 2043 2044 -- Internal names generally represent something gone wrong. An exception 2045 -- is the case of internal type names, where we try to find a reasonable 2046 -- external representation for the external name 2047 2048 if Is_Internal_Name (Chars (Node)) 2049 and then 2050 ((Is_Entity_Name (Node) 2051 and then Present (Entity (Node)) 2052 and then Is_Type (Entity (Node))) 2053 or else 2054 (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node))) 2055 then 2056 if Nkind (Node) = N_Identifier then 2057 Ent := Entity (Node); 2058 else 2059 Ent := Node; 2060 end if; 2061 2062 Unwind_Internal_Type (Ent); 2063 Nam := Chars (Ent); 2064 2065 else 2066 Nam := Chars (Node); 2067 end if; 2068 2069 -- At this stage, the name to output is in Nam 2070 2071 Get_Unqualified_Decoded_Name_String (Nam); 2072 2073 -- Remove trailing upper case letters from the name (useful for 2074 -- dealing with some cases of internal names. 2075 2076 while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop 2077 Name_Len := Name_Len - 1; 2078 end loop; 2079 2080 -- If we have any of the names from standard that start with the 2081 -- characters "any " (e.g. Any_Type), then kill the message since 2082 -- almost certainly it is a junk cascaded message. 2083 2084 if Name_Len > 4 2085 and then Name_Buffer (1 .. 4) = "any " 2086 then 2087 Kill_Message := True; 2088 end if; 2089 2090 -- Now we have to set the proper case. If we have a source location 2091 -- then do a check to see if the name in the source is the same name 2092 -- as the name in the Names table, except for possible differences 2093 -- in case, which is the case when we can copy from the source. 2094 2095 declare 2096 Src_Loc : constant Source_Ptr := Sloc (Error_Msg_Node_1); 2097 Sbuffer : Source_Buffer_Ptr; 2098 Ref_Ptr : Integer; 2099 Src_Ptr : Source_Ptr; 2100 2101 begin 2102 Ref_Ptr := 1; 2103 Src_Ptr := Src_Loc; 2104 2105 -- For standard locations, always use mixed case 2106 2107 if Src_Loc <= No_Location 2108 or else Sloc (Node) <= No_Location 2109 then 2110 Set_Casing (Mixed_Case); 2111 2112 else 2113 -- Determine if the reference we are dealing with corresponds 2114 -- to text at the point of the error reference. This will often 2115 -- be the case for simple identifier references, and is the case 2116 -- where we can copy the spelling from the source. 2117 2118 Sbuffer := Source_Text (Get_Source_File_Index (Src_Loc)); 2119 2120 while Ref_Ptr <= Name_Len loop 2121 exit when 2122 Fold_Lower (Sbuffer (Src_Ptr)) /= 2123 Fold_Lower (Name_Buffer (Ref_Ptr)); 2124 Ref_Ptr := Ref_Ptr + 1; 2125 Src_Ptr := Src_Ptr + 1; 2126 end loop; 2127 2128 -- If we get through the loop without a mismatch, then output 2129 -- the name the way it is spelled in the source program 2130 2131 if Ref_Ptr > Name_Len then 2132 Src_Ptr := Src_Loc; 2133 2134 for J in 1 .. Name_Len loop 2135 Name_Buffer (J) := Sbuffer (Src_Ptr); 2136 Src_Ptr := Src_Ptr + 1; 2137 end loop; 2138 2139 -- Otherwise set the casing using the default identifier casing 2140 2141 else 2142 Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case); 2143 end if; 2144 end if; 2145 end; 2146 2147 Set_Msg_Name_Buffer; 2148 Add_Class; 2149 end Set_Msg_Node; 2150 2151 ------------------ 2152 -- Set_Msg_Text -- 2153 ------------------ 2154 2155 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is 2156 C : Character; -- Current character 2157 P : Natural; -- Current index; 2158 2159 begin 2160 Manual_Quote_Mode := False; 2161 Is_Unconditional_Msg := False; 2162 Msglen := 0; 2163 Flag_Source := Get_Source_File_Index (Flag); 2164 P := Text'First; 2165 2166 while P <= Text'Last loop 2167 C := Text (P); 2168 P := P + 1; 2169 2170 -- Check for insertion character 2171 2172 case C is 2173 when '%' => 2174 Set_Msg_Insertion_Name; 2175 2176 when '$' => 2177 Set_Msg_Insertion_Unit_Name; 2178 2179 when '{' => 2180 Set_Msg_Insertion_File_Name; 2181 2182 when '}' => 2183 Set_Msg_Insertion_Type_Reference (Flag); 2184 2185 when '*' => 2186 Set_Msg_Insertion_Reserved_Name; 2187 2188 when '&' => 2189 Set_Msg_Insertion_Node; 2190 2191 when '#' => 2192 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); 2193 2194 when '\' => 2195 Continuation := True; 2196 2197 when '@' => 2198 Set_Msg_Insertion_Column; 2199 2200 when '>' => 2201 Set_Msg_Insertion_Run_Time_Name; 2202 2203 2204 when '^' => 2205 Set_Msg_Insertion_Uint; 2206 2207 when '`' => 2208 Manual_Quote_Mode := not Manual_Quote_Mode; 2209 Set_Msg_Char ('"'); 2210 2211 when '!' => 2212 Is_Unconditional_Msg := True; 2213 2214 when '?' => 2215 null; -- already dealt with 2216 2217 when '|' => 2218 null; -- already dealt with 2219 2220 when ''' => 2221 Set_Msg_Char (Text (P)); 2222 P := P + 1; 2223 2224 -- Upper case letter 2225 2226 when 'A' .. 'Z' => 2227 2228 -- Start of reserved word if two or more 2229 2230 if P <= Text'Last and then Text (P) in 'A' .. 'Z' then 2231 P := P - 1; 2232 Set_Msg_Insertion_Reserved_Word (Text, P); 2233 2234 -- Single upper case letter is just inserted 2235 2236 else 2237 Set_Msg_Char (C); 2238 end if; 2239 2240 -- Normal character with no special treatment 2241 2242 when others => 2243 Set_Msg_Char (C); 2244 end case; 2245 end loop; 2246 end Set_Msg_Text; 2247 2248 ---------------- 2249 -- Set_Posted -- 2250 ---------------- 2251 2252 procedure Set_Posted (N : Node_Id) is 2253 P : Node_Id; 2254 2255 begin 2256 if Is_Serious_Error then 2257 2258 -- We always set Error_Posted on the node itself 2259 2260 Set_Error_Posted (N); 2261 2262 -- If it is a subexpression, then set Error_Posted on parents 2263 -- up to and including the first non-subexpression construct. This 2264 -- helps avoid cascaded error messages within a single expression. 2265 2266 P := N; 2267 loop 2268 P := Parent (P); 2269 exit when No (P); 2270 Set_Error_Posted (P); 2271 exit when Nkind (P) not in N_Subexpr; 2272 end loop; 2273 2274 -- A special check, if we just posted an error on an attribute 2275 -- definition clause, then also set the entity involved as posted. 2276 -- For example, this stops complaining about the alignment after 2277 -- complaining about the size, which is likely to be useless. 2278 2279 if Nkind (P) = N_Attribute_Definition_Clause then 2280 if Is_Entity_Name (Name (P)) then 2281 Set_Error_Posted (Entity (Name (P))); 2282 end if; 2283 end if; 2284 end if; 2285 end Set_Posted; 2286 2287 ----------------------- 2288 -- Set_Qualification -- 2289 ----------------------- 2290 2291 procedure Set_Qualification (N : Nat; E : Entity_Id) is 2292 begin 2293 if N /= 0 and then Scope (E) /= Standard_Standard then 2294 Set_Qualification (N - 1, Scope (E)); 2295 Set_Msg_Node (Scope (E)); 2296 Set_Msg_Char ('.'); 2297 end if; 2298 end Set_Qualification; 2299 2300 ------------------------ 2301 -- Special_Msg_Delete -- 2302 ------------------------ 2303 2304 function Special_Msg_Delete 2305 (Msg : String; 2306 N : Node_Or_Entity_Id; 2307 E : Node_Or_Entity_Id) 2308 return Boolean 2309 is 2310 begin 2311 -- Never delete messages in -gnatdO mode 2312 2313 if Debug_Flag_OO then 2314 return False; 2315 2316 -- When an atomic object refers to a non-atomic type in the same 2317 -- scope, we implicitly make the type atomic. In the non-error 2318 -- case this is surely safe (and in fact prevents an error from 2319 -- occurring if the type is not atomic by default). But if the 2320 -- object cannot be made atomic, then we introduce an extra junk 2321 -- message by this manipulation, which we get rid of here. 2322 2323 -- We identify this case by the fact that it references a type for 2324 -- which Is_Atomic is set, but there is no Atomic pragma setting it. 2325 2326 elsif Msg = "atomic access to & cannot be guaranteed" 2327 and then Is_Type (E) 2328 and then Is_Atomic (E) 2329 and then No (Get_Rep_Pragma (E, Name_Atomic)) 2330 then 2331 return True; 2332 2333 -- When a size is wrong for a frozen type there is no explicit 2334 -- size clause, and other errors have occurred, suppress the 2335 -- message, since it is likely that this size error is a cascaded 2336 -- result of other errors. The reason we eliminate unfrozen types 2337 -- is that messages issued before the freeze type are for sure OK. 2338 2339 elsif Msg = "size for& too small, minimum allowed is ^" 2340 and then Is_Frozen (E) 2341 and then Serious_Errors_Detected > 0 2342 and then Nkind (N) /= N_Component_Clause 2343 and then Nkind (Parent (N)) /= N_Component_Clause 2344 and then 2345 No (Get_Attribute_Definition_Clause (E, Attribute_Size)) 2346 and then 2347 No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size)) 2348 and then 2349 No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size)) 2350 then 2351 return True; 2352 2353 -- All special tests complete, so go ahead with message 2354 2355 else 2356 return False; 2357 end if; 2358 end Special_Msg_Delete; 2359 2360 -------------------------- 2361 -- Unwind_Internal_Type -- 2362 -------------------------- 2363 2364 procedure Unwind_Internal_Type (Ent : in out Entity_Id) is 2365 Derived : Boolean := False; 2366 Mchar : Character; 2367 Old_Ent : Entity_Id; 2368 2369 begin 2370 -- Undo placement of a quote, since we will put it back later 2371 2372 Mchar := Msg_Buffer (Msglen); 2373 2374 if Mchar = '"' then 2375 Msglen := Msglen - 1; 2376 end if; 2377 2378 -- The loop here deals with recursive types, we are trying to 2379 -- find a related entity that is not an implicit type. Note 2380 -- that the check with Old_Ent stops us from getting "stuck". 2381 -- Also, we don't output the "type derived from" message more 2382 -- than once in the case where we climb up multiple levels. 2383 2384 loop 2385 Old_Ent := Ent; 2386 2387 -- Implicit access type, use directly designated type 2388 2389 if Is_Access_Type (Ent) then 2390 Set_Msg_Str ("access to "); 2391 Ent := Directly_Designated_Type (Ent); 2392 2393 -- Classwide type 2394 2395 elsif Is_Class_Wide_Type (Ent) then 2396 Class_Flag := True; 2397 Ent := Root_Type (Ent); 2398 2399 -- Use base type if this is a subtype 2400 2401 elsif Ent /= Base_Type (Ent) then 2402 Buffer_Remove ("type "); 2403 2404 -- Avoid duplication "subtype of subtype of", and also replace 2405 -- "derived from subtype of" simply by "derived from" 2406 2407 if not Buffer_Ends_With ("subtype of ") 2408 and then not Buffer_Ends_With ("derived from ") 2409 then 2410 Set_Msg_Str ("subtype of "); 2411 end if; 2412 2413 Ent := Base_Type (Ent); 2414 2415 -- If this is a base type with a first named subtype, use the 2416 -- first named subtype instead. This is not quite accurate in 2417 -- all cases, but it makes too much noise to be accurate and 2418 -- add 'Base in all cases. Note that we only do this is the 2419 -- first named subtype is not itself an internal name. This 2420 -- avoids the obvious loop (subtype->basetype->subtype) which 2421 -- would otherwise occur!) 2422 2423 elsif Present (Freeze_Node (Ent)) 2424 and then Present (First_Subtype_Link (Freeze_Node (Ent))) 2425 and then 2426 not Is_Internal_Name 2427 (Chars (First_Subtype_Link (Freeze_Node (Ent)))) 2428 then 2429 Ent := First_Subtype_Link (Freeze_Node (Ent)); 2430 2431 -- Otherwise use root type 2432 2433 else 2434 if not Derived then 2435 Buffer_Remove ("type "); 2436 2437 -- Test for "subtype of type derived from" which seems 2438 -- excessive and is replaced by simply "type derived from" 2439 2440 Buffer_Remove ("subtype of"); 2441 2442 -- Avoid duplication "type derived from type derived from" 2443 2444 if not Buffer_Ends_With ("type derived from ") then 2445 Set_Msg_Str ("type derived from "); 2446 end if; 2447 2448 Derived := True; 2449 end if; 2450 2451 Ent := Etype (Ent); 2452 end if; 2453 2454 -- If we are stuck in a loop, get out and settle for the internal 2455 -- name after all. In this case we set to kill the message if it 2456 -- is not the first error message (we really try hard not to show 2457 -- the dirty laundry of the implementation to the poor user!) 2458 2459 if Ent = Old_Ent then 2460 Kill_Message := True; 2461 exit; 2462 end if; 2463 2464 -- Get out if we finally found a non-internal name to use 2465 2466 exit when not Is_Internal_Name (Chars (Ent)); 2467 end loop; 2468 2469 if Mchar = '"' then 2470 Set_Msg_Char ('"'); 2471 end if; 2472 end Unwind_Internal_Type; 2473 2474end Errout; 2475