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-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26-- Warning: Error messages can be generated during Gigi processing by direct 27-- calls to error message routines, so it is essential that the processing 28-- in this body be consistent with the requirements for the Gigi processing 29-- environment, and that in particular, no disallowed table expansion is 30-- allowed to occur. 31 32with Atree; use Atree; 33with Casing; use Casing; 34with Csets; use Csets; 35with Debug; use Debug; 36with Einfo; use Einfo; 37with Erroutc; use Erroutc; 38with Gnatvsn; use Gnatvsn; 39with Lib; use Lib; 40with Opt; use Opt; 41with Nlists; use Nlists; 42with Output; use Output; 43with Scans; use Scans; 44with Sem_Aux; use Sem_Aux; 45with Sinput; use Sinput; 46with Sinfo; use Sinfo; 47with Snames; use Snames; 48with Stand; use Stand; 49with Stylesw; use Stylesw; 50with Uname; use Uname; 51 52package body Errout is 53 54 Errors_Must_Be_Ignored : Boolean := False; 55 -- Set to True by procedure Set_Ignore_Errors (True), when calls to error 56 -- message procedures should be ignored (when parsing irrelevant text in 57 -- sources being preprocessed). 58 59 Finalize_Called : Boolean := False; 60 -- Set True if the Finalize routine has been called 61 62 Record_Compilation_Errors : Boolean := False; 63 -- Record that a compilation error was witnessed during a given phase of 64 -- analysis for gnat2why. This is needed as Warning_Mode is modified twice 65 -- in gnat2why, hence Erroutc.Compilation_Errors can only return a suitable 66 -- value for each phase of analysis separately. This is updated at each 67 -- call to Compilation_Errors. 68 69 Warn_On_Instance : Boolean; 70 -- Flag set true for warning message to be posted on instance 71 72 ------------------------------------ 73 -- Table of Non-Instance Messages -- 74 ------------------------------------ 75 76 -- This table contains an entry for every error message processed by the 77 -- Error_Msg routine that is not posted on generic (or inlined) instance. 78 -- As explained in further detail in the Error_Msg procedure body, this 79 -- table is used to avoid posting redundant messages on instances. 80 81 type NIM_Record is record 82 Msg : String_Ptr; 83 Loc : Source_Ptr; 84 end record; 85 -- Type used to store text and location of one message 86 87 package Non_Instance_Msgs is new Table.Table ( 88 Table_Component_Type => NIM_Record, 89 Table_Index_Type => Int, 90 Table_Low_Bound => 1, 91 Table_Initial => 100, 92 Table_Increment => 100, 93 Table_Name => "Non_Instance_Msgs"); 94 95 ----------------------- 96 -- Local Subprograms -- 97 ----------------------- 98 99 procedure Error_Msg_Internal 100 (Msg : String; 101 Sptr : Source_Ptr; 102 Optr : Source_Ptr; 103 Msg_Cont : Boolean; 104 Node : Node_Id); 105 -- This is the low level routine used to post messages after dealing with 106 -- the issue of messages placed on instantiations (which get broken up 107 -- into separate calls in Error_Msg). Sptr is the location on which the 108 -- flag will be placed in the output. In the case where the flag is on 109 -- the template, this points directly to the template, not to one of the 110 -- instantiation copies of the template. Optr is the original location 111 -- used to flag the error, and this may indeed point to an instantiation 112 -- copy. So typically we can see Optr pointing to the template location 113 -- in an instantiation copy when Sptr points to the source location of 114 -- the actual instantiation (i.e the line with the new). Msg_Cont is 115 -- set true if this is a continuation message. Node is the relevant 116 -- Node_Id for this message, to be used to compute the enclosing entity if 117 -- Opt.Include_Subprogram_In_Messages is set. 118 119 function No_Warnings (N : Node_Or_Entity_Id) return Boolean; 120 -- Determines if warnings should be suppressed for the given node 121 122 function OK_Node (N : Node_Id) return Boolean; 123 -- Determines if a node is an OK node to place an error message on (return 124 -- True) or if the error message should be suppressed (return False). A 125 -- message is suppressed if the node already has an error posted on it, 126 -- or if it refers to an Etype that has an error posted on it, or if 127 -- it references an Entity that has an error posted on it. 128 129 procedure Output_Source_Line 130 (L : Physical_Line_Number; 131 Sfile : Source_File_Index; 132 Errs : Boolean); 133 -- Outputs text of source line L, in file S, together with preceding line 134 -- number, as described above for Output_Line_Number. The Errs parameter 135 -- indicates if there are errors attached to the line, which forces 136 -- listing on, even in the presence of pragma List (Off). 137 138 procedure Set_Msg_Insertion_Column; 139 -- Handle column number insertion (@ insertion character) 140 141 procedure Set_Msg_Insertion_Node; 142 -- Handle node (name from node) insertion (& insertion character) 143 144 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr); 145 -- Handle type reference (right brace insertion character). Flag is the 146 -- location of the flag, which is provided for the internal call to 147 -- Set_Msg_Insertion_Line_Number, 148 149 procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True); 150 -- Handle unit name insertion ($ insertion character). Depending on Boolean 151 -- parameter Suffix, (spec) or (body) is appended after the unit name. 152 153 procedure Set_Msg_Node (Node : Node_Id); 154 -- Add the sequence of characters for the name associated with the given 155 -- node to the current message. For N_Designator, N_Selected_Component, 156 -- N_Defining_Program_Unit_Name, and N_Expanded_Name, the Prefix is 157 -- included as well. 158 159 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr); 160 -- Add a sequence of characters to the current message. The characters may 161 -- be one of the special insertion characters (see documentation in spec). 162 -- Flag is the location at which the error is to be posted, which is used 163 -- to determine whether or not the # insertion needs a file name. The 164 -- variables Msg_Buffer are set on return Msglen. 165 166 procedure Set_Posted (N : Node_Id); 167 -- Sets the Error_Posted flag on the given node, and all its parents that 168 -- are subexpressions and then on the parent non-subexpression construct 169 -- that contains the original expression. If that parent is a named 170 -- association, the flag is further propagated to its parent. This is done 171 -- in order to guard against cascaded errors. Note that this call has an 172 -- effect for a serious error only. 173 174 procedure Set_Qualification (N : Nat; E : Entity_Id); 175 -- Outputs up to N levels of qualification for the given entity. For 176 -- example, the entity A.B.C.D will output B.C. if N = 2. 177 178 function Special_Msg_Delete 179 (Msg : String; 180 N : Node_Or_Entity_Id; 181 E : Node_Or_Entity_Id) return Boolean; 182 -- This function is called from Error_Msg_NEL, passing the message Msg, 183 -- node N on which the error is to be posted, and the entity or node E 184 -- to be used for an & insertion in the message if any. The job of this 185 -- procedure is to test for certain cascaded messages that we would like 186 -- to suppress. If the message is to be suppressed then we return True. 187 -- If the message should be generated (the normal case) False is returned. 188 189 procedure Unwind_Internal_Type (Ent : in out Entity_Id); 190 -- This procedure is given an entity id for an internal type, i.e. a type 191 -- with an internal name. It unwinds the type to try to get to something 192 -- reasonably printable, generating prefixes like "subtype of", "access 193 -- to", etc along the way in the buffer. The value in Ent on return is the 194 -- final name to be printed. Hopefully this is not an internal name, but in 195 -- some internal name cases, it is an internal name, and has to be printed 196 -- anyway (although in this case the message has been killed if possible). 197 -- The global variable Class_Flag is set to True if the resulting entity 198 -- should have 'Class appended to its name (see Add_Class procedure), and 199 -- is otherwise unchanged. 200 201 function Warn_Insertion return String; 202 -- This is called for warning messages only (so Warning_Msg_Char is set) 203 -- and returns a corresponding string to use at the beginning of generated 204 -- auxiliary messages, such as "in instantiation at ...". 205 -- 'a' .. 'z' returns "?x?" 206 -- 'A' .. 'Z' returns "?X?" 207 -- '*' returns "?*?" 208 -- '$' returns "?$?info: " 209 -- ' ' returns " " 210 -- No other settings are valid 211 212 ----------------------- 213 -- Change_Error_Text -- 214 ----------------------- 215 216 procedure Change_Error_Text (Error_Id : Error_Msg_Id; New_Msg : String) is 217 Save_Next : Error_Msg_Id; 218 Err_Id : Error_Msg_Id := Error_Id; 219 220 begin 221 Set_Msg_Text (New_Msg, Errors.Table (Error_Id).Sptr); 222 Errors.Table (Error_Id).Text := new String'(Msg_Buffer (1 .. Msglen)); 223 224 -- If in immediate error message mode, output modified error message now 225 -- This is just a bit tricky, because we want to output just a single 226 -- message, and the messages we modified is already linked in. We solve 227 -- this by temporarily resetting its forward pointer to empty. 228 229 if Debug_Flag_OO then 230 Save_Next := Errors.Table (Error_Id).Next; 231 Errors.Table (Error_Id).Next := No_Error_Msg; 232 Write_Eol; 233 Output_Source_Line 234 (Errors.Table (Error_Id).Line, Errors.Table (Error_Id).Sfile, True); 235 Output_Error_Msgs (Err_Id); 236 Errors.Table (Error_Id).Next := Save_Next; 237 end if; 238 end Change_Error_Text; 239 240 ------------------------ 241 -- Compilation_Errors -- 242 ------------------------ 243 244 function Compilation_Errors return Boolean is 245 begin 246 if not Finalize_Called then 247 raise Program_Error; 248 249 -- Record that a compilation error was witnessed during a given phase of 250 -- analysis for gnat2why. This is needed as Warning_Mode is modified 251 -- twice in gnat2why, hence Erroutc.Compilation_Errors can only return a 252 -- suitable value for each phase of analysis separately. 253 254 else 255 Record_Compilation_Errors := 256 Record_Compilation_Errors or else Erroutc.Compilation_Errors; 257 258 return Record_Compilation_Errors; 259 end if; 260 end Compilation_Errors; 261 262 -------------------------------------- 263 -- Delete_Warning_And_Continuations -- 264 -------------------------------------- 265 266 procedure Delete_Warning_And_Continuations (Msg : Error_Msg_Id) is 267 Id : Error_Msg_Id; 268 269 begin 270 pragma Assert (not Errors.Table (Msg).Msg_Cont); 271 272 Id := Msg; 273 loop 274 declare 275 M : Error_Msg_Object renames Errors.Table (Id); 276 277 begin 278 if not M.Deleted then 279 M.Deleted := True; 280 Warnings_Detected := Warnings_Detected - 1; 281 282 if M.Info then 283 Warning_Info_Messages := Warning_Info_Messages - 1; 284 end if; 285 286 if M.Warn_Err then 287 Warnings_Treated_As_Errors := Warnings_Treated_As_Errors - 1; 288 end if; 289 end if; 290 291 Id := M.Next; 292 exit when Id = No_Error_Msg; 293 exit when not Errors.Table (Id).Msg_Cont; 294 end; 295 end loop; 296 end Delete_Warning_And_Continuations; 297 298 --------------- 299 -- Error_Msg -- 300 --------------- 301 302 -- Error_Msg posts a flag at the given location, except that if the 303 -- Flag_Location points within a generic template and corresponds to an 304 -- instantiation of this generic template, then the actual message will be 305 -- posted on the generic instantiation, along with additional messages 306 -- referencing the generic declaration. 307 308 procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is 309 begin 310 Error_Msg (Msg, Flag_Location, Current_Node); 311 end Error_Msg; 312 313 procedure Error_Msg 314 (Msg : String; 315 Flag_Location : Source_Ptr; 316 N : Node_Id) 317 is 318 Sindex : Source_File_Index; 319 -- Source index for flag location 320 321 Orig_Loc : Source_Ptr; 322 -- Original location of Flag_Location (i.e. location in original 323 -- template in instantiation case, otherwise unchanged). 324 325 begin 326 -- Return if all errors are to be ignored 327 328 if Errors_Must_Be_Ignored then 329 return; 330 end if; 331 332 -- If we already have messages, and we are trying to place a message at 333 -- No_Location, then just ignore the attempt since we assume that what 334 -- is happening is some cascaded junk. Note that this is safe in the 335 -- sense that proceeding will surely bomb. We will also bomb if the flag 336 -- location is No_Location and we don't have any messages so far, but 337 -- that is a real bug and a legitimate bomb, so we go ahead. 338 339 if Flag_Location = No_Location 340 and then Total_Errors_Detected > 0 341 then 342 return; 343 end if; 344 345 -- Start of processing for new message 346 347 Sindex := Get_Source_File_Index (Flag_Location); 348 Prescan_Message (Msg); 349 Orig_Loc := Original_Location (Flag_Location); 350 351 -- If the current location is in an instantiation, the issue arises of 352 -- whether to post the message on the template or the instantiation. 353 354 -- The way we decide is to see if we have posted the same message on 355 -- the template when we compiled the template (the template is always 356 -- compiled before any instantiations). For this purpose, we use a 357 -- separate table of messages. The reason we do this is twofold: 358 359 -- First, the messages can get changed by various processing 360 -- including the insertion of tokens etc, making it hard to 361 -- do the comparison. 362 363 -- Second, we will suppress a warning on a template if it is not in 364 -- the current extended source unit. That's reasonable and means we 365 -- don't want the warning on the instantiation here either, but it 366 -- does mean that the main error table would not in any case include 367 -- the message. 368 369 if Flag_Location = Orig_Loc then 370 Non_Instance_Msgs.Append ((new String'(Msg), Flag_Location)); 371 Warn_On_Instance := False; 372 373 -- Here we have an instance message 374 375 else 376 -- Delete if debug flag off, and this message duplicates a message 377 -- already posted on the corresponding template 378 379 if not Debug_Flag_GG then 380 for J in Non_Instance_Msgs.First .. Non_Instance_Msgs.Last loop 381 if Msg = Non_Instance_Msgs.Table (J).Msg.all 382 and then Non_Instance_Msgs.Table (J).Loc = Orig_Loc 383 then 384 return; 385 end if; 386 end loop; 387 end if; 388 389 -- No duplicate, so error/warning will be posted on instance 390 391 Warn_On_Instance := Is_Warning_Msg; 392 end if; 393 394 -- Ignore warning message that is suppressed for this location. Note 395 -- that style checks are not considered warning messages for this 396 -- purpose. 397 398 if Is_Warning_Msg and then Warnings_Suppressed (Orig_Loc) /= No_String 399 then 400 return; 401 402 -- For style messages, check too many messages so far 403 404 elsif Is_Style_Msg 405 and then Maximum_Messages /= 0 406 and then Warnings_Detected >= Maximum_Messages 407 then 408 return; 409 end if; 410 411 -- The idea at this stage is that we have two kinds of messages 412 413 -- First, we have those messages that are to be placed as requested at 414 -- Flag_Location. This includes messages that have nothing to do with 415 -- generics, and also messages placed on generic templates that reflect 416 -- an error in the template itself. For such messages we simply call 417 -- Error_Msg_Internal to place the message in the requested location. 418 419 if Instantiation (Sindex) = No_Location then 420 Error_Msg_Internal (Msg, Flag_Location, Flag_Location, False, N); 421 return; 422 end if; 423 424 -- If we are trying to flag an error in an instantiation, we may have 425 -- a generic contract violation. What we generate in this case is: 426 427 -- instantiation error at ... 428 -- original error message 429 430 -- or 431 432 -- warning: in instantiation at ... 433 -- warning: original warning message 434 435 -- or 436 437 -- info: in instantiation at ... 438 -- info: original info message 439 440 -- All these messages are posted at the location of the top level 441 -- instantiation. If there are nested instantiations, then the 442 -- instantiation error message can be repeated, pointing to each 443 -- of the relevant instantiations. 444 445 -- Note: the instantiation mechanism is also shared for inlining of 446 -- subprogram bodies when front end inlining is done. In this case the 447 -- messages have the form: 448 449 -- in inlined body at ... 450 -- original error message 451 452 -- or 453 454 -- warning: in inlined body at ... 455 -- warning: original warning message 456 457 -- or 458 459 -- info: in inlined body at ... 460 -- info: original info message 461 462 -- OK, here we have an instantiation error, and we need to generate the 463 -- error on the instantiation, rather than on the template. 464 465 declare 466 Actual_Error_Loc : Source_Ptr; 467 -- Location of outer level instantiation in instantiation case, or 468 -- just a copy of Flag_Location in the normal case. This is the 469 -- location where all error messages will actually be posted. 470 471 Save_Error_Msg_Sloc : constant Source_Ptr := Error_Msg_Sloc; 472 -- Save possible location set for caller's message. We need to use 473 -- Error_Msg_Sloc for the location of the instantiation error but we 474 -- have to preserve a possible original value. 475 476 X : Source_File_Index; 477 478 Msg_Cont_Status : Boolean; 479 -- Used to label continuation lines in instantiation case with 480 -- proper Msg_Cont status. 481 482 begin 483 -- Loop to find highest level instantiation, where all error 484 -- messages will be placed. 485 486 X := Sindex; 487 loop 488 Actual_Error_Loc := Instantiation (X); 489 X := Get_Source_File_Index (Actual_Error_Loc); 490 exit when Instantiation (X) = No_Location; 491 end loop; 492 493 -- Since we are generating the messages at the instantiation point in 494 -- any case, we do not want the references to the bad lines in the 495 -- instance to be annotated with the location of the instantiation. 496 497 Suppress_Instance_Location := True; 498 Msg_Cont_Status := False; 499 500 -- Loop to generate instantiation messages 501 502 Error_Msg_Sloc := Flag_Location; 503 X := Get_Source_File_Index (Flag_Location); 504 while Instantiation (X) /= No_Location loop 505 506 -- Suppress instantiation message on continuation lines 507 508 if Msg (Msg'First) /= '\' then 509 510 -- Case of inlined body 511 512 if Inlined_Body (X) then 513 if Is_Info_Msg then 514 Error_Msg_Internal 515 (Msg => "info: in inlined body #", 516 Sptr => Actual_Error_Loc, 517 Optr => Flag_Location, 518 Msg_Cont => Msg_Cont_Status, 519 Node => N); 520 521 elsif Is_Warning_Msg then 522 Error_Msg_Internal 523 (Msg => Warn_Insertion & "in inlined body #", 524 Sptr => Actual_Error_Loc, 525 Optr => Flag_Location, 526 Msg_Cont => Msg_Cont_Status, 527 Node => N); 528 529 elsif Is_Style_Msg then 530 Error_Msg_Internal 531 (Msg => "style: in inlined body #", 532 Sptr => Actual_Error_Loc, 533 Optr => Flag_Location, 534 Msg_Cont => Msg_Cont_Status, 535 Node => N); 536 537 else 538 Error_Msg_Internal 539 (Msg => "error in inlined body #", 540 Sptr => Actual_Error_Loc, 541 Optr => Flag_Location, 542 Msg_Cont => Msg_Cont_Status, 543 Node => N); 544 end if; 545 546 -- Case of generic instantiation 547 548 else 549 if Is_Info_Msg then 550 Error_Msg_Internal 551 (Msg => "info: in instantiation #", 552 Sptr => Actual_Error_Loc, 553 Optr => Flag_Location, 554 Msg_Cont => Msg_Cont_Status, 555 Node => N); 556 557 elsif Is_Warning_Msg then 558 Error_Msg_Internal 559 (Msg => Warn_Insertion & "in instantiation #", 560 Sptr => Actual_Error_Loc, 561 Optr => Flag_Location, 562 Msg_Cont => Msg_Cont_Status, 563 Node => N); 564 565 elsif Is_Style_Msg then 566 Error_Msg_Internal 567 (Msg => "style: in instantiation #", 568 Sptr => Actual_Error_Loc, 569 Optr => Flag_Location, 570 Msg_Cont => Msg_Cont_Status, 571 Node => N); 572 573 else 574 Error_Msg_Internal 575 (Msg => "instantiation error #", 576 Sptr => Actual_Error_Loc, 577 Optr => Flag_Location, 578 Msg_Cont => Msg_Cont_Status, 579 Node => N); 580 end if; 581 end if; 582 end if; 583 584 Error_Msg_Sloc := Instantiation (X); 585 X := Get_Source_File_Index (Error_Msg_Sloc); 586 Msg_Cont_Status := True; 587 end loop; 588 589 Suppress_Instance_Location := False; 590 Error_Msg_Sloc := Save_Error_Msg_Sloc; 591 592 -- Here we output the original message on the outer instantiation 593 594 Error_Msg_Internal 595 (Msg => Msg, 596 Sptr => Actual_Error_Loc, 597 Optr => Flag_Location, 598 Msg_Cont => Msg_Cont_Status, 599 Node => N); 600 end; 601 end Error_Msg; 602 603 -------------------------------- 604 -- Error_Msg_Ada_2012_Feature -- 605 -------------------------------- 606 607 procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr) is 608 begin 609 if Ada_Version < Ada_2012 then 610 Error_Msg (Feature & " is an Ada 2012 feature", Loc); 611 612 if No (Ada_Version_Pragma) then 613 Error_Msg ("\unit must be compiled with -gnat2012 switch", Loc); 614 else 615 Error_Msg_Sloc := Sloc (Ada_Version_Pragma); 616 Error_Msg ("\incompatible with Ada version set#", Loc); 617 end if; 618 end if; 619 end Error_Msg_Ada_2012_Feature; 620 621 ------------------ 622 -- Error_Msg_AP -- 623 ------------------ 624 625 procedure Error_Msg_AP (Msg : String) is 626 S1 : Source_Ptr; 627 C : Character; 628 629 begin 630 -- If we had saved the Scan_Ptr value after scanning the previous 631 -- token, then we would have exactly the right place for putting 632 -- the flag immediately at hand. However, that would add at least 633 -- two instructions to a Scan call *just* to service the possibility 634 -- of an Error_Msg_AP call. So instead we reconstruct that value. 635 636 -- We have two possibilities, start with Prev_Token_Ptr and skip over 637 -- the current token, which is made harder by the possibility that this 638 -- token may be in error, or start with Token_Ptr and work backwards. 639 -- We used to take the second approach, but it's hard because of 640 -- comments, and harder still because things that look like comments 641 -- can appear inside strings. So now we take the first approach. 642 643 -- Note: in the case where there is no previous token, Prev_Token_Ptr 644 -- is set to Source_First, which is a reasonable position for the 645 -- error flag in this situation. 646 647 S1 := Prev_Token_Ptr; 648 C := Source (S1); 649 650 -- If the previous token is a string literal, we need a special approach 651 -- since there may be white space inside the literal and we don't want 652 -- to stop on that white space. 653 654 -- Note: since this is an error recovery issue anyway, it is not worth 655 -- worrying about special UTF_32 line terminator characters here. 656 657 if Prev_Token = Tok_String_Literal then 658 loop 659 S1 := S1 + 1; 660 661 if Source (S1) = C then 662 S1 := S1 + 1; 663 exit when Source (S1) /= C; 664 elsif Source (S1) in Line_Terminator then 665 exit; 666 end if; 667 end loop; 668 669 -- Character literal also needs special handling 670 671 elsif Prev_Token = Tok_Char_Literal then 672 S1 := S1 + 3; 673 674 -- Otherwise we search forward for the end of the current token, marked 675 -- by a line terminator, white space, a comment symbol or if we bump 676 -- into the following token (i.e. the current token). 677 678 -- Again, it is not worth worrying about UTF_32 special line terminator 679 -- characters in this context, since this is only for error recovery. 680 681 else 682 while Source (S1) not in Line_Terminator 683 and then Source (S1) /= ' ' 684 and then Source (S1) /= ASCII.HT 685 and then (Source (S1) /= '-' or else Source (S1 + 1) /= '-') 686 and then S1 /= Token_Ptr 687 loop 688 S1 := S1 + 1; 689 end loop; 690 end if; 691 692 -- S1 is now set to the location for the flag 693 694 Error_Msg (Msg, S1); 695 end Error_Msg_AP; 696 697 ------------------ 698 -- Error_Msg_BC -- 699 ------------------ 700 701 procedure Error_Msg_BC (Msg : String) is 702 begin 703 -- If we are at end of file, post the flag after the previous token 704 705 if Token = Tok_EOF then 706 Error_Msg_AP (Msg); 707 708 -- If we are at start of file, post the flag at the current token 709 710 elsif Token_Ptr = Source_First (Current_Source_File) then 711 Error_Msg_SC (Msg); 712 713 -- If the character before the current token is a space or a horizontal 714 -- tab, then we place the flag on this character (in the case of a tab 715 -- we would really like to place it in the "last" character of the tab 716 -- space, but that it too much trouble to worry about). 717 718 elsif Source (Token_Ptr - 1) = ' ' 719 or else Source (Token_Ptr - 1) = ASCII.HT 720 then 721 Error_Msg (Msg, Token_Ptr - 1); 722 723 -- If there is no space or tab before the current token, then there is 724 -- no room to place the flag before the token, so we place it on the 725 -- token instead (this happens for example at the start of a line). 726 727 else 728 Error_Msg (Msg, Token_Ptr); 729 end if; 730 end Error_Msg_BC; 731 732 ------------------- 733 -- Error_Msg_CRT -- 734 ------------------- 735 736 procedure Error_Msg_CRT (Feature : String; N : Node_Id) is 737 CNRT : constant String := " not allowed in no run time mode"; 738 CCRT : constant String := " not supported by configuration>"; 739 740 S : String (1 .. Feature'Length + 1 + CCRT'Length); 741 L : Natural; 742 743 begin 744 S (1) := '|'; 745 S (2 .. Feature'Length + 1) := Feature; 746 L := Feature'Length + 2; 747 748 if No_Run_Time_Mode then 749 S (L .. L + CNRT'Length - 1) := CNRT; 750 L := L + CNRT'Length - 1; 751 752 else pragma Assert (Configurable_Run_Time_Mode); 753 S (L .. L + CCRT'Length - 1) := CCRT; 754 L := L + CCRT'Length - 1; 755 end if; 756 757 Error_Msg_N (S (1 .. L), N); 758 Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1; 759 end Error_Msg_CRT; 760 761 ------------------ 762 -- Error_Msg_PT -- 763 ------------------ 764 765 procedure Error_Msg_PT (E : Entity_Id; Iface_Prim : Entity_Id) is 766 begin 767 Error_Msg_N 768 ("illegal overriding of subprogram inherited from interface", E); 769 770 Error_Msg_Sloc := Sloc (Iface_Prim); 771 772 if Ekind (E) = E_Function then 773 Error_Msg_N 774 ("\first formal of & declared # must be of mode `IN` " 775 & "or access-to-constant", E); 776 else 777 Error_Msg_N 778 ("\first formal of & declared # must be of mode `OUT`, `IN OUT` " 779 & "or access-to-variable", E); 780 end if; 781 end Error_Msg_PT; 782 783 ----------------- 784 -- Error_Msg_F -- 785 ----------------- 786 787 procedure Error_Msg_F (Msg : String; N : Node_Id) is 788 begin 789 Error_Msg_NEL (Msg, N, N, Sloc (First_Node (N))); 790 end Error_Msg_F; 791 792 ------------------ 793 -- Error_Msg_FE -- 794 ------------------ 795 796 procedure Error_Msg_FE 797 (Msg : String; 798 N : Node_Id; 799 E : Node_Or_Entity_Id) 800 is 801 begin 802 Error_Msg_NEL (Msg, N, E, Sloc (First_Node (N))); 803 end Error_Msg_FE; 804 805 ------------------------ 806 -- Error_Msg_Internal -- 807 ------------------------ 808 809 procedure Error_Msg_Internal 810 (Msg : String; 811 Sptr : Source_Ptr; 812 Optr : Source_Ptr; 813 Msg_Cont : Boolean; 814 Node : Node_Id) 815 is 816 Next_Msg : Error_Msg_Id; 817 -- Pointer to next message at insertion point 818 819 Prev_Msg : Error_Msg_Id; 820 -- Pointer to previous message at insertion point 821 822 Temp_Msg : Error_Msg_Id; 823 824 Warn_Err : Boolean; 825 -- Set if warning to be treated as error 826 827 procedure Handle_Serious_Error; 828 -- Internal procedure to do all error message handling for a serious 829 -- error message, other than bumping the error counts and arranging 830 -- for the message to be output. 831 832 -------------------------- 833 -- Handle_Serious_Error -- 834 -------------------------- 835 836 procedure Handle_Serious_Error is 837 begin 838 -- Turn off code generation if not done already 839 840 if Operating_Mode = Generate_Code then 841 Operating_Mode := Check_Semantics; 842 Expander_Active := False; 843 end if; 844 845 -- Set the fatal error flag in the unit table unless we are in 846 -- Try_Semantics mode (in which case we set ignored mode if not 847 -- currently set. This stops the semantics from being performed 848 -- if we find a serious error. This is skipped if we are currently 849 -- dealing with the configuration pragma file. 850 851 if Current_Source_Unit /= No_Unit then 852 declare 853 U : constant Unit_Number_Type := Get_Source_Unit (Sptr); 854 begin 855 if Try_Semantics then 856 if Fatal_Error (U) = None then 857 Set_Fatal_Error (U, Error_Ignored); 858 end if; 859 else 860 Set_Fatal_Error (U, Error_Detected); 861 end if; 862 end; 863 end if; 864 865 -- Disable warnings on unused use clauses and the like. Otherwise, an 866 -- error might hide a reference to an entity in a used package, so 867 -- after fixing the error, the use clause no longer looks like it was 868 -- unused. 869 870 Check_Unreferenced := False; 871 Check_Unreferenced_Formals := False; 872 end Handle_Serious_Error; 873 874 -- Start of processing for Error_Msg_Internal 875 876 begin 877 if Raise_Exception_On_Error /= 0 then 878 raise Error_Msg_Exception; 879 end if; 880 881 Continuation := Msg_Cont; 882 Continuation_New_Line := False; 883 Suppress_Message := False; 884 Kill_Message := False; 885 Set_Msg_Text (Msg, Sptr); 886 887 -- Kill continuation if parent message killed 888 889 if Continuation and Last_Killed then 890 return; 891 end if; 892 893 -- Return without doing anything if message is suppressed 894 895 if Suppress_Message 896 and then not All_Errors_Mode 897 and then not Is_Warning_Msg 898 and then not Is_Unconditional_Msg 899 then 900 if not Continuation then 901 Last_Killed := True; 902 end if; 903 904 return; 905 end if; 906 907 -- Return without doing anything if message is killed and this is not 908 -- the first error message. The philosophy is that if we get a weird 909 -- error message and we already have had a message, then we hope the 910 -- weird message is a junk cascaded message 911 912 if Kill_Message 913 and then not All_Errors_Mode 914 and then Total_Errors_Detected /= 0 915 then 916 if not Continuation then 917 Last_Killed := True; 918 end if; 919 920 return; 921 end if; 922 923 -- Special check for warning message to see if it should be output 924 925 if Is_Warning_Msg then 926 927 -- Immediate return if warning message and warnings are suppressed 928 929 if Warnings_Suppressed (Optr) /= No_String 930 or else 931 Warnings_Suppressed (Sptr) /= No_String 932 then 933 Cur_Msg := No_Error_Msg; 934 return; 935 end if; 936 937 -- If the flag location is in the main extended source unit then for 938 -- sure we want the warning since it definitely belongs 939 940 if In_Extended_Main_Source_Unit (Sptr) then 941 null; 942 943 -- If the main unit has not been read yet. the warning must be on 944 -- a configuration file: gnat.adc or user-defined. This means we 945 -- are not parsing the main unit yet, so skip following checks. 946 947 elsif No (Cunit (Main_Unit)) then 948 null; 949 950 -- If the flag location is not in the main extended source unit, then 951 -- we want to eliminate the warning, unless it is in the extended 952 -- main code unit and we want warnings on the instance. 953 954 elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then 955 null; 956 957 -- Keep warning if debug flag G set 958 959 elsif Debug_Flag_GG then 960 null; 961 962 -- Keep warning if message text contains !! 963 964 elsif Has_Double_Exclam then 965 null; 966 967 -- Here is where we delete a warning from a with'ed unit 968 969 else 970 Cur_Msg := No_Error_Msg; 971 972 if not Continuation then 973 Last_Killed := True; 974 end if; 975 976 return; 977 end if; 978 end if; 979 980 -- If message is to be ignored in special ignore message mode, this is 981 -- where we do this special processing, bypassing message output. 982 983 if Ignore_Errors_Enable > 0 then 984 if Is_Serious_Error then 985 Handle_Serious_Error; 986 end if; 987 988 return; 989 end if; 990 991 -- If error message line length set, and this is a continuation message 992 -- then all we do is to append the text to the text of the last message 993 -- with a comma space separator (eliminating a possible (style) or 994 -- info prefix). 995 996 if Error_Msg_Line_Length /= 0 and then Continuation then 997 Cur_Msg := Errors.Last; 998 999 declare 1000 Oldm : String_Ptr := Errors.Table (Cur_Msg).Text; 1001 Newm : String (1 .. Oldm'Last + 2 + Msglen); 1002 Newl : Natural; 1003 M : Natural; 1004 1005 begin 1006 -- First copy old message to new one and free it 1007 1008 Newm (Oldm'Range) := Oldm.all; 1009 Newl := Oldm'Length; 1010 Free (Oldm); 1011 1012 -- Remove (style) or info: at start of message 1013 1014 if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then 1015 M := 9; 1016 1017 elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then 1018 M := 7; 1019 1020 else 1021 M := 1; 1022 end if; 1023 1024 -- Now deal with separation between messages. Normally this is 1025 -- simply comma space, but there are some special cases. 1026 1027 -- If continuation new line, then put actual NL character in msg 1028 1029 if Continuation_New_Line then 1030 Newl := Newl + 1; 1031 Newm (Newl) := ASCII.LF; 1032 1033 -- If continuation message is enclosed in parentheses, then 1034 -- special treatment (don't need a comma, and we want to combine 1035 -- successive parenthetical remarks into a single one with 1036 -- separating commas). 1037 1038 elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then 1039 1040 -- Case where existing message ends in right paren, remove 1041 -- and separate parenthetical remarks with a comma. 1042 1043 if Newm (Newl) = ')' then 1044 Newm (Newl) := ','; 1045 Msg_Buffer (M) := ' '; 1046 1047 -- Case where we are adding new parenthetical comment 1048 1049 else 1050 Newl := Newl + 1; 1051 Newm (Newl) := ' '; 1052 end if; 1053 1054 -- Case where continuation not in parens and no new line 1055 1056 else 1057 Newm (Newl + 1 .. Newl + 2) := ", "; 1058 Newl := Newl + 2; 1059 end if; 1060 1061 -- Append new message 1062 1063 Newm (Newl + 1 .. Newl + Msglen - M + 1) := 1064 Msg_Buffer (M .. Msglen); 1065 Newl := Newl + Msglen - M + 1; 1066 Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl)); 1067 1068 -- Update warning msg flag and message doc char if needed 1069 1070 if Is_Warning_Msg then 1071 if not Errors.Table (Cur_Msg).Warn then 1072 Errors.Table (Cur_Msg).Warn := True; 1073 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; 1074 1075 elsif Warning_Msg_Char /= ' ' then 1076 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; 1077 end if; 1078 end if; 1079 end; 1080 1081 return; 1082 end if; 1083 1084 -- Here we build a new error object 1085 1086 Errors.Append 1087 ((Text => new String'(Msg_Buffer (1 .. Msglen)), 1088 Next => No_Error_Msg, 1089 Prev => No_Error_Msg, 1090 Sptr => Sptr, 1091 Optr => Optr, 1092 Sfile => Get_Source_File_Index (Sptr), 1093 Line => Get_Physical_Line_Number (Sptr), 1094 Col => Get_Column_Number (Sptr), 1095 Warn => Is_Warning_Msg, 1096 Info => Is_Info_Msg, 1097 Check => Is_Check_Msg, 1098 Warn_Err => False, -- reset below 1099 Warn_Chr => Warning_Msg_Char, 1100 Style => Is_Style_Msg, 1101 Serious => Is_Serious_Error, 1102 Uncond => Is_Unconditional_Msg, 1103 Msg_Cont => Continuation, 1104 Deleted => False, 1105 Node => Node)); 1106 Cur_Msg := Errors.Last; 1107 1108 -- Test if warning to be treated as error 1109 1110 Warn_Err := 1111 (Is_Warning_Msg or Is_Style_Msg) 1112 and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen)) 1113 or else 1114 Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg))); 1115 1116 -- Propagate Warn_Err to this message and preceding continuations 1117 1118 for J in reverse 1 .. Errors.Last loop 1119 Errors.Table (J).Warn_Err := Warn_Err; 1120 exit when not Errors.Table (J).Msg_Cont; 1121 end loop; 1122 1123 -- If immediate errors mode set, output error message now. Also output 1124 -- now if the -d1 debug flag is set (so node number message comes out 1125 -- just before actual error message) 1126 1127 if Debug_Flag_OO or else Debug_Flag_1 then 1128 Write_Eol; 1129 Output_Source_Line 1130 (Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Sfile, True); 1131 Temp_Msg := Cur_Msg; 1132 Output_Error_Msgs (Temp_Msg); 1133 1134 -- If not in immediate errors mode, then we insert the message in the 1135 -- error chain for later output by Finalize. The messages are sorted 1136 -- first by unit (main unit comes first), and within a unit by source 1137 -- location (earlier flag location first in the chain). 1138 1139 else 1140 -- First a quick check, does this belong at the very end of the chain 1141 -- of error messages. This saves a lot of time in the normal case if 1142 -- there are lots of messages. 1143 1144 if Last_Error_Msg /= No_Error_Msg 1145 and then Errors.Table (Cur_Msg).Sfile = 1146 Errors.Table (Last_Error_Msg).Sfile 1147 and then (Sptr > Errors.Table (Last_Error_Msg).Sptr 1148 or else 1149 (Sptr = Errors.Table (Last_Error_Msg).Sptr 1150 and then 1151 Optr > Errors.Table (Last_Error_Msg).Optr)) 1152 then 1153 Prev_Msg := Last_Error_Msg; 1154 Next_Msg := No_Error_Msg; 1155 1156 -- Otherwise do a full sequential search for the insertion point 1157 1158 else 1159 Prev_Msg := No_Error_Msg; 1160 Next_Msg := First_Error_Msg; 1161 while Next_Msg /= No_Error_Msg loop 1162 exit when 1163 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; 1164 1165 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile 1166 then 1167 exit when Sptr < Errors.Table (Next_Msg).Sptr 1168 or else (Sptr = Errors.Table (Next_Msg).Sptr 1169 and then Optr < Errors.Table (Next_Msg).Optr); 1170 end if; 1171 1172 Prev_Msg := Next_Msg; 1173 Next_Msg := Errors.Table (Next_Msg).Next; 1174 end loop; 1175 end if; 1176 1177 -- Now we insert the new message in the error chain. 1178 1179 -- The possible insertion point for the new message is after Prev_Msg 1180 -- and before Next_Msg. However, this is where we do a special check 1181 -- for redundant parsing messages, defined as messages posted on the 1182 -- same line. The idea here is that probably such messages are junk 1183 -- from the parser recovering. In full errors mode, we don't do this 1184 -- deletion, but otherwise such messages are discarded at this stage. 1185 1186 if Prev_Msg /= No_Error_Msg 1187 and then Errors.Table (Prev_Msg).Line = 1188 Errors.Table (Cur_Msg).Line 1189 and then Errors.Table (Prev_Msg).Sfile = 1190 Errors.Table (Cur_Msg).Sfile 1191 and then Compiler_State = Parsing 1192 and then not All_Errors_Mode 1193 then 1194 -- Don't delete unconditional messages and at this stage, don't 1195 -- delete continuation lines; we attempted to delete those earlier 1196 -- if the parent message was deleted. 1197 1198 if not Errors.Table (Cur_Msg).Uncond 1199 and then not Continuation 1200 then 1201 -- Don't delete if prev msg is warning and new msg is an error. 1202 -- This is because we don't want a real error masked by a 1203 -- warning. In all other cases (that is parse errors for the 1204 -- same line that are not unconditional) we do delete the 1205 -- message. This helps to avoid junk extra messages from 1206 -- cascaded parsing errors 1207 1208 if not (Errors.Table (Prev_Msg).Warn 1209 or else 1210 Errors.Table (Prev_Msg).Style) 1211 or else 1212 (Errors.Table (Cur_Msg).Warn 1213 or else 1214 Errors.Table (Cur_Msg).Style) 1215 then 1216 -- All tests passed, delete the message by simply returning 1217 -- without any further processing. 1218 1219 pragma Assert (not Continuation); 1220 1221 Last_Killed := True; 1222 return; 1223 end if; 1224 end if; 1225 end if; 1226 1227 -- Come here if message is to be inserted in the error chain 1228 1229 if not Continuation then 1230 Last_Killed := False; 1231 end if; 1232 1233 if Prev_Msg = No_Error_Msg then 1234 First_Error_Msg := Cur_Msg; 1235 else 1236 Errors.Table (Prev_Msg).Next := Cur_Msg; 1237 end if; 1238 1239 Errors.Table (Cur_Msg).Next := Next_Msg; 1240 1241 if Next_Msg = No_Error_Msg then 1242 Last_Error_Msg := Cur_Msg; 1243 end if; 1244 end if; 1245 1246 -- Bump appropriate statistics counts 1247 1248 if Errors.Table (Cur_Msg).Info then 1249 1250 -- Could be (usually is) both "info" and "warning" 1251 1252 if Errors.Table (Cur_Msg).Warn then 1253 Warning_Info_Messages := Warning_Info_Messages + 1; 1254 Warnings_Detected := Warnings_Detected + 1; 1255 else 1256 Report_Info_Messages := Report_Info_Messages + 1; 1257 end if; 1258 1259 elsif Errors.Table (Cur_Msg).Warn 1260 or else Errors.Table (Cur_Msg).Style 1261 then 1262 Warnings_Detected := Warnings_Detected + 1; 1263 1264 elsif Errors.Table (Cur_Msg).Check then 1265 Check_Messages := Check_Messages + 1; 1266 1267 else 1268 Total_Errors_Detected := Total_Errors_Detected + 1; 1269 1270 if Errors.Table (Cur_Msg).Serious then 1271 Serious_Errors_Detected := Serious_Errors_Detected + 1; 1272 Handle_Serious_Error; 1273 1274 -- If not serious error, set Fatal_Error to indicate ignored error 1275 1276 else 1277 declare 1278 U : constant Unit_Number_Type := Get_Source_Unit (Sptr); 1279 begin 1280 if Fatal_Error (U) = None then 1281 Set_Fatal_Error (U, Error_Ignored); 1282 end if; 1283 end; 1284 end if; 1285 end if; 1286 1287 -- Record warning message issued 1288 1289 if Errors.Table (Cur_Msg).Warn 1290 and then not Errors.Table (Cur_Msg).Msg_Cont 1291 then 1292 Warning_Msg := Cur_Msg; 1293 end if; 1294 1295 -- If too many warnings turn off warnings 1296 1297 if Maximum_Messages /= 0 then 1298 if Warnings_Detected = Maximum_Messages then 1299 Warning_Mode := Suppress; 1300 end if; 1301 1302 -- If too many errors abandon compilation 1303 1304 if Total_Errors_Detected = Maximum_Messages then 1305 raise Unrecoverable_Error; 1306 end if; 1307 end if; 1308 end Error_Msg_Internal; 1309 1310 ----------------- 1311 -- Error_Msg_N -- 1312 ----------------- 1313 1314 procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is 1315 begin 1316 Error_Msg_NEL (Msg, N, N, Sloc (N)); 1317 end Error_Msg_N; 1318 1319 ------------------ 1320 -- Error_Msg_NE -- 1321 ------------------ 1322 1323 procedure Error_Msg_NE 1324 (Msg : String; 1325 N : Node_Or_Entity_Id; 1326 E : Node_Or_Entity_Id) 1327 is 1328 begin 1329 Error_Msg_NEL (Msg, N, E, Sloc (N)); 1330 end Error_Msg_NE; 1331 1332 ------------------- 1333 -- Error_Msg_NEL -- 1334 ------------------- 1335 1336 procedure Error_Msg_NEL 1337 (Msg : String; 1338 N : Node_Or_Entity_Id; 1339 E : Node_Or_Entity_Id; 1340 Flag_Location : Source_Ptr) 1341 is 1342 begin 1343 if Special_Msg_Delete (Msg, N, E) then 1344 return; 1345 end if; 1346 1347 Prescan_Message (Msg); 1348 1349 -- Special handling for warning messages 1350 1351 if Is_Warning_Msg then 1352 1353 -- Suppress if no warnings set for either entity or node 1354 1355 if No_Warnings (N) or else No_Warnings (E) then 1356 1357 -- Disable any continuation messages as well 1358 1359 Last_Killed := True; 1360 return; 1361 end if; 1362 1363 -- Suppress if inside loop that is known to be null or is probably 1364 -- null (case where loop executes only if invalid values present). 1365 -- In either case warnings in the loop are likely to be junk. 1366 1367 declare 1368 P : Node_Id; 1369 1370 begin 1371 P := Parent (N); 1372 while Present (P) loop 1373 if Nkind (P) = N_Loop_Statement 1374 and then Suppress_Loop_Warnings (P) 1375 then 1376 return; 1377 end if; 1378 1379 P := Parent (P); 1380 end loop; 1381 end; 1382 end if; 1383 1384 -- Test for message to be output 1385 1386 if All_Errors_Mode 1387 or else Is_Unconditional_Msg 1388 or else Is_Warning_Msg 1389 or else OK_Node (N) 1390 or else (Msg (Msg'First) = '\' and then not Last_Killed) 1391 then 1392 Debug_Output (N); 1393 Error_Msg_Node_1 := E; 1394 Error_Msg (Msg, Flag_Location, N); 1395 1396 else 1397 Last_Killed := True; 1398 end if; 1399 1400 Set_Posted (N); 1401 end Error_Msg_NEL; 1402 1403 ------------------ 1404 -- Error_Msg_NW -- 1405 ------------------ 1406 1407 procedure Error_Msg_NW 1408 (Eflag : Boolean; 1409 Msg : String; 1410 N : Node_Or_Entity_Id) 1411 is 1412 begin 1413 if Eflag 1414 and then In_Extended_Main_Source_Unit (N) 1415 and then Comes_From_Source (N) 1416 then 1417 Error_Msg_NEL (Msg, N, N, Sloc (N)); 1418 end if; 1419 end Error_Msg_NW; 1420 1421 ----------------- 1422 -- Error_Msg_S -- 1423 ----------------- 1424 1425 procedure Error_Msg_S (Msg : String) is 1426 begin 1427 Error_Msg (Msg, Scan_Ptr); 1428 end Error_Msg_S; 1429 1430 ------------------ 1431 -- Error_Msg_SC -- 1432 ------------------ 1433 1434 procedure Error_Msg_SC (Msg : String) is 1435 begin 1436 -- If we are at end of file, post the flag after the previous token 1437 1438 if Token = Tok_EOF then 1439 Error_Msg_AP (Msg); 1440 1441 -- For all other cases the message is posted at the current token 1442 -- pointer position 1443 1444 else 1445 Error_Msg (Msg, Token_Ptr); 1446 end if; 1447 end Error_Msg_SC; 1448 1449 ------------------ 1450 -- Error_Msg_SP -- 1451 ------------------ 1452 1453 procedure Error_Msg_SP (Msg : String) is 1454 begin 1455 -- Note: in the case where there is no previous token, Prev_Token_Ptr 1456 -- is set to Source_First, which is a reasonable position for the 1457 -- error flag in this situation 1458 1459 Error_Msg (Msg, Prev_Token_Ptr); 1460 end Error_Msg_SP; 1461 1462 -------------- 1463 -- Finalize -- 1464 -------------- 1465 1466 procedure Finalize (Last_Call : Boolean) is 1467 Cur : Error_Msg_Id; 1468 Nxt : Error_Msg_Id; 1469 F : Error_Msg_Id; 1470 1471 procedure Delete_Warning (E : Error_Msg_Id); 1472 -- Delete a warning msg if not already deleted and adjust warning count 1473 1474 -------------------- 1475 -- Delete_Warning -- 1476 -------------------- 1477 1478 procedure Delete_Warning (E : Error_Msg_Id) is 1479 begin 1480 if not Errors.Table (E).Deleted then 1481 Errors.Table (E).Deleted := True; 1482 Warnings_Detected := Warnings_Detected - 1; 1483 1484 if Errors.Table (E).Info then 1485 Warning_Info_Messages := Warning_Info_Messages - 1; 1486 end if; 1487 end if; 1488 end Delete_Warning; 1489 1490 -- Start of processing for Finalize 1491 1492 begin 1493 -- Set Prev pointers 1494 1495 Cur := First_Error_Msg; 1496 while Cur /= No_Error_Msg loop 1497 Nxt := Errors.Table (Cur).Next; 1498 exit when Nxt = No_Error_Msg; 1499 Errors.Table (Nxt).Prev := Cur; 1500 Cur := Nxt; 1501 end loop; 1502 1503 -- Eliminate any duplicated error messages from the list. This is 1504 -- done after the fact to avoid problems with Change_Error_Text. 1505 1506 Cur := First_Error_Msg; 1507 while Cur /= No_Error_Msg loop 1508 Nxt := Errors.Table (Cur).Next; 1509 1510 F := Nxt; 1511 while F /= No_Error_Msg 1512 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr 1513 loop 1514 Check_Duplicate_Message (Cur, F); 1515 F := Errors.Table (F).Next; 1516 end loop; 1517 1518 Cur := Nxt; 1519 end loop; 1520 1521 -- Mark any messages suppressed by specific warnings as Deleted 1522 1523 Cur := First_Error_Msg; 1524 while Cur /= No_Error_Msg loop 1525 declare 1526 CE : Error_Msg_Object renames Errors.Table (Cur); 1527 Tag : constant String := Get_Warning_Tag (Cur); 1528 1529 begin 1530 if (CE.Warn and not CE.Deleted) 1531 and then 1532 (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /= 1533 No_String 1534 or else 1535 Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /= 1536 No_String) 1537 then 1538 Delete_Warning (Cur); 1539 1540 -- If this is a continuation, delete previous parts of message 1541 1542 F := Cur; 1543 while Errors.Table (F).Msg_Cont loop 1544 F := Errors.Table (F).Prev; 1545 exit when F = No_Error_Msg; 1546 Delete_Warning (F); 1547 end loop; 1548 1549 -- Delete any following continuations 1550 1551 F := Cur; 1552 loop 1553 F := Errors.Table (F).Next; 1554 exit when F = No_Error_Msg; 1555 exit when not Errors.Table (F).Msg_Cont; 1556 Delete_Warning (F); 1557 end loop; 1558 end if; 1559 end; 1560 1561 Cur := Errors.Table (Cur).Next; 1562 end loop; 1563 1564 Finalize_Called := True; 1565 1566 -- Check consistency of specific warnings (may add warnings). We only 1567 -- do this on the last call, after all possible warnings are posted. 1568 1569 if Last_Call then 1570 Validate_Specific_Warnings (Error_Msg'Access); 1571 end if; 1572 end Finalize; 1573 1574 ---------------- 1575 -- First_Node -- 1576 ---------------- 1577 1578 function First_Node (C : Node_Id) return Node_Id is 1579 Orig : constant Node_Id := Original_Node (C); 1580 Loc : constant Source_Ptr := Sloc (Orig); 1581 Sfile : constant Source_File_Index := Get_Source_File_Index (Loc); 1582 Earliest : Node_Id; 1583 Eloc : Source_Ptr; 1584 1585 function Test_Earlier (N : Node_Id) return Traverse_Result; 1586 -- Function applied to every node in the construct 1587 1588 procedure Search_Tree_First is new Traverse_Proc (Test_Earlier); 1589 -- Create traversal procedure 1590 1591 ------------------ 1592 -- Test_Earlier -- 1593 ------------------ 1594 1595 function Test_Earlier (N : Node_Id) return Traverse_Result is 1596 Norig : constant Node_Id := Original_Node (N); 1597 Loc : constant Source_Ptr := Sloc (Norig); 1598 1599 begin 1600 -- Check for earlier 1601 1602 if Loc < Eloc 1603 1604 -- Ignore nodes with no useful location information 1605 1606 and then Loc /= Standard_Location 1607 and then Loc /= No_Location 1608 1609 -- Ignore nodes from a different file. This ensures against cases 1610 -- of strange foreign code somehow being present. We don't want 1611 -- wild placement of messages if that happens. 1612 1613 and then Get_Source_File_Index (Loc) = Sfile 1614 then 1615 Earliest := Norig; 1616 Eloc := Loc; 1617 end if; 1618 1619 return OK_Orig; 1620 end Test_Earlier; 1621 1622 -- Start of processing for First_Node 1623 1624 begin 1625 if Nkind (Orig) in N_Subexpr then 1626 Earliest := Orig; 1627 Eloc := Loc; 1628 Search_Tree_First (Orig); 1629 return Earliest; 1630 1631 else 1632 return Orig; 1633 end if; 1634 end First_Node; 1635 1636 ---------------- 1637 -- First_Sloc -- 1638 ---------------- 1639 1640 function First_Sloc (N : Node_Id) return Source_Ptr is 1641 SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); 1642 SF : constant Source_Ptr := Source_First (SI); 1643 F : Node_Id; 1644 S : Source_Ptr; 1645 1646 begin 1647 F := First_Node (N); 1648 S := Sloc (F); 1649 1650 -- The following circuit is a bit subtle. When we have parenthesized 1651 -- expressions, then the Sloc will not record the location of the paren, 1652 -- but we would like to post the flag on the paren. So what we do is to 1653 -- crawl up the tree from the First_Node, adjusting the Sloc value for 1654 -- any parentheses we know are present. Yes, we know this circuit is not 1655 -- 100% reliable (e.g. because we don't record all possible paren level 1656 -- values), but this is only for an error message so it is good enough. 1657 1658 Node_Loop : loop 1659 Paren_Loop : for J in 1 .. Paren_Count (F) loop 1660 1661 -- We don't look more than 12 characters behind the current 1662 -- location, and in any case not past the front of the source. 1663 1664 Search_Loop : for K in 1 .. 12 loop 1665 exit Search_Loop when S = SF; 1666 1667 if Source_Text (SI) (S - 1) = '(' then 1668 S := S - 1; 1669 exit Search_Loop; 1670 1671 elsif Source_Text (SI) (S - 1) <= ' ' then 1672 S := S - 1; 1673 1674 else 1675 exit Search_Loop; 1676 end if; 1677 end loop Search_Loop; 1678 end loop Paren_Loop; 1679 1680 exit Node_Loop when F = N; 1681 F := Parent (F); 1682 exit Node_Loop when Nkind (F) not in N_Subexpr; 1683 end loop Node_Loop; 1684 1685 return S; 1686 end First_Sloc; 1687 1688 ----------------------- 1689 -- Get_Ignore_Errors -- 1690 ----------------------- 1691 1692 function Get_Ignore_Errors return Boolean is 1693 begin 1694 return Errors_Must_Be_Ignored; 1695 end Get_Ignore_Errors; 1696 1697 ---------------- 1698 -- Initialize -- 1699 ---------------- 1700 1701 procedure Initialize is 1702 begin 1703 Errors.Init; 1704 First_Error_Msg := No_Error_Msg; 1705 Last_Error_Msg := No_Error_Msg; 1706 Serious_Errors_Detected := 0; 1707 Total_Errors_Detected := 0; 1708 Cur_Msg := No_Error_Msg; 1709 List_Pragmas.Init; 1710 1711 -- Reset counts for warnings 1712 1713 Reset_Warnings; 1714 1715 -- Initialize warnings tables 1716 1717 Warnings.Init; 1718 Specific_Warnings.Init; 1719 end Initialize; 1720 1721 ------------------------------- 1722 -- Is_Size_Too_Small_Message -- 1723 ------------------------------- 1724 1725 function Is_Size_Too_Small_Message (S : String) return Boolean is 1726 Size_For : constant String := "size for"; 1727 pragma Assert (Size_Too_Small_Message (1 .. Size_For'Last) = Size_For); 1728 -- Assert that Size_Too_Small_Message starts with Size_For 1729 begin 1730 return S'Length >= Size_For'Length 1731 and then S (S'First .. S'First + Size_For'Length - 1) = Size_For; 1732 -- True if S starts with Size_For 1733 end Is_Size_Too_Small_Message; 1734 1735 ----------------- 1736 -- No_Warnings -- 1737 ----------------- 1738 1739 function No_Warnings (N : Node_Or_Entity_Id) return Boolean is 1740 begin 1741 if Error_Posted (N) then 1742 return True; 1743 1744 elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then 1745 return True; 1746 1747 elsif Is_Entity_Name (N) 1748 and then Present (Entity (N)) 1749 and then Has_Warnings_Off (Entity (N)) 1750 then 1751 return True; 1752 1753 else 1754 return False; 1755 end if; 1756 end No_Warnings; 1757 1758 ------------- 1759 -- OK_Node -- 1760 ------------- 1761 1762 function OK_Node (N : Node_Id) return Boolean is 1763 K : constant Node_Kind := Nkind (N); 1764 1765 begin 1766 if Error_Posted (N) then 1767 return False; 1768 1769 elsif K in N_Has_Etype 1770 and then Present (Etype (N)) 1771 and then Error_Posted (Etype (N)) 1772 then 1773 return False; 1774 1775 elsif (K in N_Op 1776 or else K = N_Attribute_Reference 1777 or else K = N_Character_Literal 1778 or else K = N_Expanded_Name 1779 or else K = N_Identifier 1780 or else K = N_Operator_Symbol) 1781 and then Present (Entity (N)) 1782 and then Error_Posted (Entity (N)) 1783 then 1784 return False; 1785 else 1786 return True; 1787 end if; 1788 end OK_Node; 1789 1790 --------------------- 1791 -- Output_Messages -- 1792 --------------------- 1793 1794 procedure Output_Messages is 1795 E : Error_Msg_Id; 1796 Err_Flag : Boolean; 1797 1798 procedure Write_Error_Summary; 1799 -- Write error summary 1800 1801 procedure Write_Header (Sfile : Source_File_Index); 1802 -- Write header line (compiling or checking given file) 1803 1804 procedure Write_Max_Errors; 1805 -- Write message if max errors reached 1806 1807 ------------------------- 1808 -- Write_Error_Summary -- 1809 ------------------------- 1810 1811 procedure Write_Error_Summary is 1812 begin 1813 -- Extra blank line if error messages or source listing were output 1814 1815 if Total_Errors_Detected + Warnings_Detected > 0 or else Full_List 1816 then 1817 Write_Eol; 1818 end if; 1819 1820 -- Message giving number of lines read and number of errors detected. 1821 -- This normally goes to Standard_Output. The exception is when brief 1822 -- mode is not set, verbose mode (or full list mode) is set, and 1823 -- there are errors. In this case we send the message to standard 1824 -- error to make sure that *something* appears on standard error 1825 -- in an error situation. 1826 1827 if Total_Errors_Detected + Warnings_Detected /= 0 1828 and then not Brief_Output 1829 and then (Verbose_Mode or Full_List) 1830 then 1831 Set_Standard_Error; 1832 end if; 1833 1834 -- Message giving total number of lines. Don't give this message if 1835 -- the Main_Source line is unknown (this happens in error situations, 1836 -- e.g. when integrated preprocessing fails). 1837 1838 if Main_Source_File > No_Source_File then 1839 Write_Str (" "); 1840 Write_Int (Num_Source_Lines (Main_Source_File)); 1841 1842 if Num_Source_Lines (Main_Source_File) = 1 then 1843 Write_Str (" line: "); 1844 else 1845 Write_Str (" lines: "); 1846 end if; 1847 end if; 1848 1849 if Total_Errors_Detected = 0 then 1850 Write_Str ("No errors"); 1851 1852 elsif Total_Errors_Detected = 1 then 1853 Write_Str ("1 error"); 1854 1855 else 1856 Write_Int (Total_Errors_Detected); 1857 Write_Str (" errors"); 1858 end if; 1859 1860 if Warnings_Detected - Warning_Info_Messages /= 0 then 1861 Write_Str (", "); 1862 Write_Int (Warnings_Detected); 1863 Write_Str (" warning"); 1864 1865 if Warnings_Detected - Warning_Info_Messages /= 1 then 1866 Write_Char ('s'); 1867 end if; 1868 1869 if Warning_Mode = Treat_As_Error then 1870 Write_Str (" (treated as error"); 1871 1872 if Warnings_Detected /= 1 then 1873 Write_Char ('s'); 1874 end if; 1875 1876 Write_Char (')'); 1877 1878 elsif Warnings_Treated_As_Errors /= 0 then 1879 Write_Str (" ("); 1880 Write_Int (Warnings_Treated_As_Errors); 1881 Write_Str (" treated as errors)"); 1882 end if; 1883 end if; 1884 1885 if Warning_Info_Messages + Report_Info_Messages /= 0 then 1886 Write_Str (", "); 1887 Write_Int (Warning_Info_Messages + Report_Info_Messages); 1888 Write_Str (" info message"); 1889 1890 if Warning_Info_Messages + Report_Info_Messages > 1 then 1891 Write_Char ('s'); 1892 end if; 1893 end if; 1894 1895 Write_Eol; 1896 Set_Standard_Output; 1897 end Write_Error_Summary; 1898 1899 ------------------ 1900 -- Write_Header -- 1901 ------------------ 1902 1903 procedure Write_Header (Sfile : Source_File_Index) is 1904 begin 1905 if Verbose_Mode or Full_List then 1906 if Original_Operating_Mode = Generate_Code then 1907 Write_Str ("Compiling: "); 1908 else 1909 Write_Str ("Checking: "); 1910 end if; 1911 1912 Write_Name (Full_File_Name (Sfile)); 1913 1914 if not Debug_Flag_7 then 1915 Write_Eol; 1916 Write_Str ("Source file time stamp: "); 1917 Write_Time_Stamp (Sfile); 1918 Write_Eol; 1919 Write_Str ("Compiled at: " & Compilation_Time); 1920 end if; 1921 1922 Write_Eol; 1923 end if; 1924 end Write_Header; 1925 1926 ---------------------- 1927 -- Write_Max_Errors -- 1928 ---------------------- 1929 1930 procedure Write_Max_Errors is 1931 begin 1932 if Maximum_Messages /= 0 then 1933 if Warnings_Detected >= Maximum_Messages then 1934 Set_Standard_Error; 1935 Write_Line ("maximum number of warnings output"); 1936 Write_Line ("any further warnings suppressed"); 1937 Set_Standard_Output; 1938 end if; 1939 1940 -- If too many errors print message 1941 1942 if Total_Errors_Detected >= Maximum_Messages then 1943 Set_Standard_Error; 1944 Write_Line ("fatal error: maximum number of errors detected"); 1945 Set_Standard_Output; 1946 end if; 1947 end if; 1948 end Write_Max_Errors; 1949 1950 -- Start of processing for Output_Messages 1951 1952 begin 1953 -- Error if Finalize has not been called 1954 1955 if not Finalize_Called then 1956 raise Program_Error; 1957 end if; 1958 1959 -- Reset current error source file if the main unit has a pragma 1960 -- Source_Reference. This ensures outputting the proper name of 1961 -- the source file in this situation. 1962 1963 if Main_Source_File <= No_Source_File 1964 or else Num_SRef_Pragmas (Main_Source_File) /= 0 1965 then 1966 Current_Error_Source_File := No_Source_File; 1967 end if; 1968 1969 -- Brief Error mode 1970 1971 if Brief_Output or (not Full_List and not Verbose_Mode) then 1972 Set_Standard_Error; 1973 1974 E := First_Error_Msg; 1975 while E /= No_Error_Msg loop 1976 if not Errors.Table (E).Deleted and then not Debug_Flag_KK then 1977 if Full_Path_Name_For_Brief_Errors then 1978 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); 1979 else 1980 Write_Name (Reference_Name (Errors.Table (E).Sfile)); 1981 end if; 1982 1983 Write_Char (':'); 1984 Write_Int (Int (Physical_To_Logical 1985 (Errors.Table (E).Line, 1986 Errors.Table (E).Sfile))); 1987 Write_Char (':'); 1988 1989 if Errors.Table (E).Col < 10 then 1990 Write_Char ('0'); 1991 end if; 1992 1993 Write_Int (Int (Errors.Table (E).Col)); 1994 Write_Str (": "); 1995 Output_Msg_Text (E); 1996 Write_Eol; 1997 end if; 1998 1999 E := Errors.Table (E).Next; 2000 end loop; 2001 2002 Set_Standard_Output; 2003 end if; 2004 2005 -- Full source listing case 2006 2007 if Full_List then 2008 List_Pragmas_Index := 1; 2009 List_Pragmas_Mode := True; 2010 E := First_Error_Msg; 2011 2012 -- Normal case, to stdout (copyright notice already output) 2013 2014 if Full_List_File_Name = null then 2015 if not Debug_Flag_7 then 2016 Write_Eol; 2017 end if; 2018 2019 -- Output to file 2020 2021 else 2022 Create_List_File_Access.all (Full_List_File_Name.all); 2023 Set_Special_Output (Write_List_Info_Access.all'Access); 2024 2025 -- Write copyright notice to file 2026 2027 if not Debug_Flag_7 then 2028 Write_Str ("GNAT "); 2029 Write_Str (Gnat_Version_String); 2030 Write_Eol; 2031 Write_Str ("Copyright 1992-" & 2032 Current_Year & 2033 ", Free Software Foundation, Inc."); 2034 Write_Eol; 2035 end if; 2036 end if; 2037 2038 -- First list extended main source file units with errors 2039 2040 for U in Main_Unit .. Last_Unit loop 2041 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) 2042 2043 -- If debug flag d.m is set, only the main source is listed 2044 2045 and then (U = Main_Unit or else not Debug_Flag_Dot_M) 2046 2047 -- If the unit of the entity does not come from source, it is 2048 -- an implicit subprogram declaration for a child subprogram. 2049 -- Do not emit errors for it, they are listed with the body. 2050 2051 and then 2052 (No (Cunit_Entity (U)) 2053 or else Comes_From_Source (Cunit_Entity (U)) 2054 or else not Is_Subprogram (Cunit_Entity (U))) 2055 2056 -- If the compilation unit associated with this unit does not 2057 -- come from source, it means it is an instantiation that should 2058 -- not be included in the source listing. 2059 2060 and then Comes_From_Source (Cunit (U)) 2061 then 2062 declare 2063 Sfile : constant Source_File_Index := Source_Index (U); 2064 2065 begin 2066 Write_Eol; 2067 2068 -- Only write the header if Sfile is known 2069 2070 if Sfile > No_Source_File then 2071 Write_Header (Sfile); 2072 Write_Eol; 2073 end if; 2074 2075 -- Normally, we don't want an "error messages from file" 2076 -- message when listing the entire file, so we set the 2077 -- current source file as the current error source file. 2078 -- However, the old style of doing things was to list this 2079 -- message if pragma Source_Reference is present, even for 2080 -- the main unit. Since the purpose of the -gnatd.m switch 2081 -- is to duplicate the old behavior, we skip the reset if 2082 -- this debug flag is set. 2083 2084 if not Debug_Flag_Dot_M then 2085 Current_Error_Source_File := Sfile; 2086 end if; 2087 2088 -- Only output the listing if Sfile is known, to avoid 2089 -- crashing the compiler. 2090 2091 if Sfile > No_Source_File then 2092 for N in 1 .. Last_Source_Line (Sfile) loop 2093 while E /= No_Error_Msg 2094 and then Errors.Table (E).Deleted 2095 loop 2096 E := Errors.Table (E).Next; 2097 end loop; 2098 2099 Err_Flag := 2100 E /= No_Error_Msg 2101 and then Errors.Table (E).Line = N 2102 and then Errors.Table (E).Sfile = Sfile; 2103 2104 Output_Source_Line (N, Sfile, Err_Flag); 2105 2106 if Err_Flag then 2107 Output_Error_Msgs (E); 2108 2109 if not Debug_Flag_2 then 2110 Write_Eol; 2111 end if; 2112 end if; 2113 end loop; 2114 end if; 2115 end; 2116 end if; 2117 end loop; 2118 2119 -- Then output errors, if any, for subsidiary units not in the 2120 -- main extended unit. 2121 2122 -- Note: if debug flag d.m set, include errors for any units other 2123 -- than the main unit in the extended source unit (e.g. spec and 2124 -- subunits for a body). 2125 2126 while E /= No_Error_Msg 2127 and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr) 2128 or else 2129 (Debug_Flag_Dot_M 2130 and then Get_Source_Unit 2131 (Errors.Table (E).Sptr) /= Main_Unit)) 2132 loop 2133 if Errors.Table (E).Deleted then 2134 E := Errors.Table (E).Next; 2135 2136 else 2137 Write_Eol; 2138 Output_Source_Line 2139 (Errors.Table (E).Line, Errors.Table (E).Sfile, True); 2140 Output_Error_Msgs (E); 2141 end if; 2142 end loop; 2143 2144 -- If output to file, write extra copy of error summary to the 2145 -- output file, and then close it. 2146 2147 if Full_List_File_Name /= null then 2148 Write_Error_Summary; 2149 Write_Max_Errors; 2150 Close_List_File_Access.all; 2151 Cancel_Special_Output; 2152 end if; 2153 end if; 2154 2155 -- Verbose mode (error lines only with error flags). Normally this is 2156 -- ignored in full list mode, unless we are listing to a file, in which 2157 -- case we still generate -gnatv output to standard output. 2158 2159 if Verbose_Mode 2160 and then (not Full_List or else Full_List_File_Name /= null) 2161 then 2162 Write_Eol; 2163 2164 -- Output the header only when Main_Source_File is known 2165 2166 if Main_Source_File > No_Source_File then 2167 Write_Header (Main_Source_File); 2168 end if; 2169 2170 E := First_Error_Msg; 2171 2172 -- Loop through error lines 2173 2174 while E /= No_Error_Msg loop 2175 if Errors.Table (E).Deleted then 2176 E := Errors.Table (E).Next; 2177 else 2178 Write_Eol; 2179 Output_Source_Line 2180 (Errors.Table (E).Line, Errors.Table (E).Sfile, True); 2181 Output_Error_Msgs (E); 2182 end if; 2183 end loop; 2184 end if; 2185 2186 -- Output error summary if verbose or full list mode 2187 2188 if Verbose_Mode or else Full_List then 2189 Write_Error_Summary; 2190 end if; 2191 2192 Write_Max_Errors; 2193 2194 -- Even though Warning_Info_Messages are a subclass of warnings, they 2195 -- must not be treated as errors when -gnatwe is in effect. 2196 2197 if Warning_Mode = Treat_As_Error then 2198 Total_Errors_Detected := 2199 Total_Errors_Detected + Warnings_Detected - Warning_Info_Messages; 2200 Warnings_Detected := Warning_Info_Messages; 2201 end if; 2202 end Output_Messages; 2203 2204 ------------------------ 2205 -- Output_Source_Line -- 2206 ------------------------ 2207 2208 procedure Output_Source_Line 2209 (L : Physical_Line_Number; 2210 Sfile : Source_File_Index; 2211 Errs : Boolean) 2212 is 2213 S : Source_Ptr; 2214 C : Character; 2215 2216 Line_Number_Output : Boolean := False; 2217 -- Set True once line number is output 2218 2219 Empty_Line : Boolean := True; 2220 -- Set False if line includes at least one character 2221 2222 begin 2223 if Sfile /= Current_Error_Source_File then 2224 Write_Str ("==============Error messages for "); 2225 2226 case Sinput.File_Type (Sfile) is 2227 when Sinput.Src => 2228 Write_Str ("source"); 2229 2230 when Sinput.Config => 2231 Write_Str ("configuration pragmas"); 2232 2233 when Sinput.Def => 2234 Write_Str ("symbol definition"); 2235 2236 when Sinput.Preproc => 2237 Write_Str ("preprocessing data"); 2238 end case; 2239 2240 Write_Str (" file: "); 2241 Write_Name (Full_File_Name (Sfile)); 2242 Write_Eol; 2243 2244 if Num_SRef_Pragmas (Sfile) > 0 then 2245 Write_Str ("--------------Line numbers from file: "); 2246 Write_Name (Full_Ref_Name (Sfile)); 2247 Write_Str (" (starting at line "); 2248 Write_Int (Int (First_Mapped_Line (Sfile))); 2249 Write_Char (')'); 2250 Write_Eol; 2251 end if; 2252 2253 Current_Error_Source_File := Sfile; 2254 end if; 2255 2256 if Errs or List_Pragmas_Mode then 2257 Output_Line_Number (Physical_To_Logical (L, Sfile)); 2258 Line_Number_Output := True; 2259 end if; 2260 2261 S := Line_Start (L, Sfile); 2262 2263 loop 2264 C := Source_Text (Sfile) (S); 2265 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; 2266 2267 -- Deal with matching entry in List_Pragmas table 2268 2269 if Full_List 2270 and then List_Pragmas_Index <= List_Pragmas.Last 2271 and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc 2272 then 2273 case List_Pragmas.Table (List_Pragmas_Index).Ptyp is 2274 when Page => 2275 Write_Char (C); 2276 2277 -- Ignore if on line with errors so that error flags 2278 -- get properly listed with the error line . 2279 2280 if not Errs then 2281 Write_Char (ASCII.FF); 2282 end if; 2283 2284 when List_On => 2285 List_Pragmas_Mode := True; 2286 2287 if not Line_Number_Output then 2288 Output_Line_Number (Physical_To_Logical (L, Sfile)); 2289 Line_Number_Output := True; 2290 end if; 2291 2292 Write_Char (C); 2293 2294 when List_Off => 2295 Write_Char (C); 2296 List_Pragmas_Mode := False; 2297 end case; 2298 2299 List_Pragmas_Index := List_Pragmas_Index + 1; 2300 2301 -- Normal case (no matching entry in List_Pragmas table) 2302 2303 else 2304 if Errs or List_Pragmas_Mode then 2305 Write_Char (C); 2306 end if; 2307 end if; 2308 2309 Empty_Line := False; 2310 S := S + 1; 2311 end loop; 2312 2313 -- If we have output a source line, then add the line terminator, with 2314 -- training spaces preserved (so we output the line exactly as input). 2315 2316 if Line_Number_Output then 2317 if Empty_Line then 2318 Write_Eol; 2319 else 2320 Write_Eol_Keep_Blanks; 2321 end if; 2322 end if; 2323 end Output_Source_Line; 2324 2325 ----------------------------- 2326 -- Remove_Warning_Messages -- 2327 ----------------------------- 2328 2329 procedure Remove_Warning_Messages (N : Node_Id) is 2330 2331 function Check_For_Warning (N : Node_Id) return Traverse_Result; 2332 -- This function checks one node for a possible warning message 2333 2334 function Check_All_Warnings is new Traverse_Func (Check_For_Warning); 2335 -- This defines the traversal operation 2336 2337 ----------------------- 2338 -- Check_For_Warning -- 2339 ----------------------- 2340 2341 function Check_For_Warning (N : Node_Id) return Traverse_Result is 2342 Loc : constant Source_Ptr := Sloc (N); 2343 E : Error_Msg_Id; 2344 2345 function To_Be_Removed (E : Error_Msg_Id) return Boolean; 2346 -- Returns True for a message that is to be removed. Also adjusts 2347 -- warning count appropriately. 2348 2349 ------------------- 2350 -- To_Be_Removed -- 2351 ------------------- 2352 2353 function To_Be_Removed (E : Error_Msg_Id) return Boolean is 2354 begin 2355 if E /= No_Error_Msg 2356 2357 -- Don't remove if location does not match 2358 2359 and then Errors.Table (E).Optr = Loc 2360 2361 -- Don't remove if not warning/info message. Note that we do 2362 -- not remove style messages here. They are warning messages 2363 -- but not ones we want removed in this context. 2364 2365 and then Errors.Table (E).Warn 2366 2367 -- Don't remove unconditional messages 2368 2369 and then not Errors.Table (E).Uncond 2370 then 2371 Warnings_Detected := Warnings_Detected - 1; 2372 2373 if Errors.Table (E).Info then 2374 Warning_Info_Messages := Warning_Info_Messages - 1; 2375 end if; 2376 2377 return True; 2378 2379 -- No removal required 2380 2381 else 2382 return False; 2383 end if; 2384 end To_Be_Removed; 2385 2386 -- Start of processing for Check_For_Warnings 2387 2388 begin 2389 while To_Be_Removed (First_Error_Msg) loop 2390 First_Error_Msg := Errors.Table (First_Error_Msg).Next; 2391 end loop; 2392 2393 if First_Error_Msg = No_Error_Msg then 2394 Last_Error_Msg := No_Error_Msg; 2395 end if; 2396 2397 E := First_Error_Msg; 2398 while E /= No_Error_Msg loop 2399 while To_Be_Removed (Errors.Table (E).Next) loop 2400 Errors.Table (E).Next := 2401 Errors.Table (Errors.Table (E).Next).Next; 2402 2403 if Errors.Table (E).Next = No_Error_Msg then 2404 Last_Error_Msg := E; 2405 end if; 2406 end loop; 2407 2408 E := Errors.Table (E).Next; 2409 end loop; 2410 2411 if Nkind (N) = N_Raise_Constraint_Error 2412 and then Is_Rewrite_Substitution (N) 2413 and then No (Condition (N)) 2414 then 2415 -- Warnings may have been posted on subexpressions of the original 2416 -- tree. We place the original node back on the tree to remove 2417 -- those warnings, whose sloc do not match those of any node in 2418 -- the current tree. Given that we are in unreachable code, this 2419 -- modification to the tree is harmless. 2420 2421 declare 2422 Status : Traverse_Final_Result; 2423 2424 begin 2425 if Is_List_Member (N) then 2426 Set_Condition (N, Original_Node (N)); 2427 Status := Check_All_Warnings (Condition (N)); 2428 else 2429 Rewrite (N, Original_Node (N)); 2430 Status := Check_All_Warnings (N); 2431 end if; 2432 2433 return Status; 2434 end; 2435 2436 else 2437 return OK; 2438 end if; 2439 end Check_For_Warning; 2440 2441 -- Start of processing for Remove_Warning_Messages 2442 2443 begin 2444 if Warnings_Detected /= 0 then 2445 declare 2446 Discard : Traverse_Final_Result; 2447 pragma Warnings (Off, Discard); 2448 2449 begin 2450 Discard := Check_All_Warnings (N); 2451 end; 2452 end if; 2453 end Remove_Warning_Messages; 2454 2455 procedure Remove_Warning_Messages (L : List_Id) is 2456 Stat : Node_Id; 2457 begin 2458 if Is_Non_Empty_List (L) then 2459 Stat := First (L); 2460 while Present (Stat) loop 2461 Remove_Warning_Messages (Stat); 2462 Next (Stat); 2463 end loop; 2464 end if; 2465 end Remove_Warning_Messages; 2466 2467 -------------------- 2468 -- Reset_Warnings -- 2469 -------------------- 2470 2471 procedure Reset_Warnings is 2472 begin 2473 Warnings_Treated_As_Errors := 0; 2474 Warnings_Detected := 0; 2475 Warning_Info_Messages := 0; 2476 Warnings_As_Errors_Count := 0; 2477 end Reset_Warnings; 2478 2479 ---------------------- 2480 -- Adjust_Name_Case -- 2481 ---------------------- 2482 2483 procedure Adjust_Name_Case 2484 (Buf : in out Bounded_String; 2485 Loc : Source_Ptr) 2486 is 2487 begin 2488 -- We have an all lower case name from Namet, and now we want to set 2489 -- the appropriate case. If possible we copy the actual casing from 2490 -- the source. If not we use standard identifier casing. 2491 2492 declare 2493 Src_Ind : constant Source_File_Index := Get_Source_File_Index (Loc); 2494 Sbuffer : Source_Buffer_Ptr; 2495 Ref_Ptr : Integer; 2496 Src_Ptr : Source_Ptr; 2497 2498 begin 2499 Ref_Ptr := 1; 2500 Src_Ptr := Loc; 2501 2502 -- For standard locations, always use mixed case 2503 2504 if Loc <= No_Location then 2505 Set_Casing (Mixed_Case); 2506 2507 else 2508 -- Determine if the reference we are dealing with corresponds to 2509 -- text at the point of the error reference. This will often be 2510 -- the case for simple identifier references, and is the case 2511 -- where we can copy the casing from the source. 2512 2513 Sbuffer := Source_Text (Src_Ind); 2514 2515 while Ref_Ptr <= Buf.Length loop 2516 exit when 2517 Fold_Lower (Sbuffer (Src_Ptr)) /= 2518 Fold_Lower (Buf.Chars (Ref_Ptr)); 2519 Ref_Ptr := Ref_Ptr + 1; 2520 Src_Ptr := Src_Ptr + 1; 2521 end loop; 2522 2523 -- If we get through the loop without a mismatch, then output the 2524 -- name the way it is cased in the source program 2525 2526 if Ref_Ptr > Buf.Length then 2527 Src_Ptr := Loc; 2528 2529 for J in 1 .. Buf.Length loop 2530 Buf.Chars (J) := Sbuffer (Src_Ptr); 2531 Src_Ptr := Src_Ptr + 1; 2532 end loop; 2533 2534 -- Otherwise set the casing using the default identifier casing 2535 2536 else 2537 Set_Casing (Buf, Identifier_Casing (Src_Ind)); 2538 end if; 2539 end if; 2540 end; 2541 end Adjust_Name_Case; 2542 2543 procedure Adjust_Name_Case (Loc : Source_Ptr) is 2544 begin 2545 Adjust_Name_Case (Global_Name_Buffer, Loc); 2546 end Adjust_Name_Case; 2547 2548 --------------------------- 2549 -- Set_Identifier_Casing -- 2550 --------------------------- 2551 2552 procedure Set_Identifier_Casing 2553 (Identifier_Name : System.Address; 2554 File_Name : System.Address) 2555 is 2556 Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name); 2557 File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name); 2558 Flen : Natural; 2559 2560 Desired_Case : Casing_Type := Mixed_Case; 2561 -- Casing required for result. Default value of Mixed_Case is used if 2562 -- for some reason we cannot find the right file name in the table. 2563 2564 begin 2565 -- Get length of file name 2566 2567 Flen := 0; 2568 while File (Flen + 1) /= ASCII.NUL loop 2569 Flen := Flen + 1; 2570 end loop; 2571 2572 -- Loop through file names to find matching one. This is a bit slow, but 2573 -- we only do it in error situations so it is not so terrible. Note that 2574 -- if the loop does not exit, then the desired case will be left set to 2575 -- Mixed_Case, this can happen if the name was not in canonical form. 2576 2577 for J in 1 .. Last_Source_File loop 2578 Get_Name_String (Full_Debug_Name (J)); 2579 2580 if Name_Len = Flen 2581 and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen)) 2582 then 2583 Desired_Case := Identifier_Casing (J); 2584 exit; 2585 end if; 2586 end loop; 2587 2588 -- Copy identifier as given to Name_Buffer 2589 2590 for J in Name_Buffer'Range loop 2591 Name_Buffer (J) := Ident (J); 2592 2593 if Name_Buffer (J) = ASCII.NUL then 2594 Name_Len := J - 1; 2595 exit; 2596 end if; 2597 end loop; 2598 2599 Set_Casing (Desired_Case); 2600 end Set_Identifier_Casing; 2601 2602 ----------------------- 2603 -- Set_Ignore_Errors -- 2604 ----------------------- 2605 2606 procedure Set_Ignore_Errors (To : Boolean) is 2607 begin 2608 Errors_Must_Be_Ignored := To; 2609 end Set_Ignore_Errors; 2610 2611 ------------------------------ 2612 -- Set_Msg_Insertion_Column -- 2613 ------------------------------ 2614 2615 procedure Set_Msg_Insertion_Column is 2616 begin 2617 if RM_Column_Check then 2618 Set_Msg_Str (" in column "); 2619 Set_Msg_Int (Int (Error_Msg_Col) + 1); 2620 end if; 2621 end Set_Msg_Insertion_Column; 2622 2623 ---------------------------- 2624 -- Set_Msg_Insertion_Node -- 2625 ---------------------------- 2626 2627 procedure Set_Msg_Insertion_Node is 2628 K : Node_Kind; 2629 2630 begin 2631 Suppress_Message := 2632 Error_Msg_Node_1 = Error 2633 or else Error_Msg_Node_1 = Any_Type; 2634 2635 if Error_Msg_Node_1 = Empty then 2636 Set_Msg_Blank_Conditional; 2637 Set_Msg_Str ("<empty>"); 2638 2639 elsif Error_Msg_Node_1 = Error then 2640 Set_Msg_Blank; 2641 Set_Msg_Str ("<error>"); 2642 2643 elsif Error_Msg_Node_1 = Standard_Void_Type then 2644 Set_Msg_Blank; 2645 Set_Msg_Str ("procedure name"); 2646 2647 elsif Nkind (Error_Msg_Node_1) in N_Entity 2648 and then Ekind (Error_Msg_Node_1) = E_Anonymous_Access_Subprogram_Type 2649 then 2650 Set_Msg_Blank; 2651 Set_Msg_Str ("access to subprogram"); 2652 2653 else 2654 Set_Msg_Blank_Conditional; 2655 2656 -- Output name 2657 2658 K := Nkind (Error_Msg_Node_1); 2659 2660 -- If we have operator case, skip quotes since name of operator 2661 -- itself will supply the required quotations. An operator can be an 2662 -- applied use in an expression or an explicit operator symbol, or an 2663 -- identifier whose name indicates it is an operator. 2664 2665 if K in N_Op 2666 or else K = N_Operator_Symbol 2667 or else K = N_Defining_Operator_Symbol 2668 or else ((K = N_Identifier or else K = N_Defining_Identifier) 2669 and then Is_Operator_Name (Chars (Error_Msg_Node_1))) 2670 then 2671 Set_Msg_Node (Error_Msg_Node_1); 2672 2673 -- Normal case, not an operator, surround with quotes 2674 2675 else 2676 Set_Msg_Quote; 2677 Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1); 2678 Set_Msg_Node (Error_Msg_Node_1); 2679 Set_Msg_Quote; 2680 end if; 2681 end if; 2682 2683 -- The following assignment ensures that a second ampersand insertion 2684 -- character will correspond to the Error_Msg_Node_2 parameter. We 2685 -- suppress possible validity checks in case operating in -gnatVa mode, 2686 -- and Error_Msg_Node_2 is not needed and has not been set. 2687 2688 declare 2689 pragma Suppress (Range_Check); 2690 begin 2691 Error_Msg_Node_1 := Error_Msg_Node_2; 2692 end; 2693 end Set_Msg_Insertion_Node; 2694 2695 -------------------------------------- 2696 -- Set_Msg_Insertion_Type_Reference -- 2697 -------------------------------------- 2698 2699 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is 2700 Ent : Entity_Id; 2701 2702 begin 2703 Set_Msg_Blank; 2704 2705 if Error_Msg_Node_1 = Standard_Void_Type then 2706 Set_Msg_Str ("package or procedure name"); 2707 return; 2708 2709 elsif Error_Msg_Node_1 = Standard_Exception_Type then 2710 Set_Msg_Str ("exception name"); 2711 return; 2712 2713 elsif Error_Msg_Node_1 = Any_Access 2714 or else Error_Msg_Node_1 = Any_Array 2715 or else Error_Msg_Node_1 = Any_Boolean 2716 or else Error_Msg_Node_1 = Any_Character 2717 or else Error_Msg_Node_1 = Any_Composite 2718 or else Error_Msg_Node_1 = Any_Discrete 2719 or else Error_Msg_Node_1 = Any_Fixed 2720 or else Error_Msg_Node_1 = Any_Integer 2721 or else Error_Msg_Node_1 = Any_Modular 2722 or else Error_Msg_Node_1 = Any_Numeric 2723 or else Error_Msg_Node_1 = Any_Real 2724 or else Error_Msg_Node_1 = Any_Scalar 2725 or else Error_Msg_Node_1 = Any_String 2726 then 2727 Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1)); 2728 Set_Msg_Name_Buffer; 2729 return; 2730 2731 elsif Error_Msg_Node_1 = Universal_Real then 2732 Set_Msg_Str ("type universal real"); 2733 return; 2734 2735 elsif Error_Msg_Node_1 = Universal_Integer then 2736 Set_Msg_Str ("type universal integer"); 2737 return; 2738 2739 elsif Error_Msg_Node_1 = Universal_Fixed then 2740 Set_Msg_Str ("type universal fixed"); 2741 return; 2742 end if; 2743 2744 -- Special case of anonymous array 2745 2746 if Nkind (Error_Msg_Node_1) in N_Entity 2747 and then Is_Array_Type (Error_Msg_Node_1) 2748 and then Present (Related_Array_Object (Error_Msg_Node_1)) 2749 then 2750 Set_Msg_Str ("type of "); 2751 Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1)); 2752 Set_Msg_Str (" declared"); 2753 Set_Msg_Insertion_Line_Number 2754 (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag); 2755 return; 2756 end if; 2757 2758 -- If we fall through, it is not a special case, so first output 2759 -- the name of the type, preceded by private for a private type 2760 2761 if Is_Private_Type (Error_Msg_Node_1) then 2762 Set_Msg_Str ("private type "); 2763 else 2764 Set_Msg_Str ("type "); 2765 end if; 2766 2767 Ent := Error_Msg_Node_1; 2768 2769 if Is_Internal_Name (Chars (Ent)) then 2770 Unwind_Internal_Type (Ent); 2771 end if; 2772 2773 -- Types in Standard are displayed as "Standard.name" 2774 2775 if Sloc (Ent) <= Standard_Location then 2776 Set_Msg_Quote; 2777 Set_Msg_Str ("Standard."); 2778 Set_Msg_Node (Ent); 2779 Add_Class; 2780 Set_Msg_Quote; 2781 2782 -- Types in other language defined units are displayed as 2783 -- "package-name.type-name" 2784 2785 elsif Is_Predefined_Unit (Get_Source_Unit (Ent)) then 2786 Get_Unqualified_Decoded_Name_String 2787 (Unit_Name (Get_Source_Unit (Ent))); 2788 Name_Len := Name_Len - 2; 2789 Set_Msg_Blank_Conditional; 2790 Set_Msg_Quote; 2791 Set_Casing (Mixed_Case); 2792 Set_Msg_Name_Buffer; 2793 Set_Msg_Char ('.'); 2794 Set_Casing (Mixed_Case); 2795 Set_Msg_Node (Ent); 2796 Add_Class; 2797 Set_Msg_Quote; 2798 2799 -- All other types display as "type name" defined at line xxx 2800 -- possibly qualified if qualification is requested. 2801 2802 else 2803 Set_Msg_Quote; 2804 Set_Qualification (Error_Msg_Qual_Level, Ent); 2805 Set_Msg_Node (Ent); 2806 Add_Class; 2807 2808 -- If we did not print a name (e.g. in the case of an anonymous 2809 -- subprogram type), there is no name to print, so remove quotes. 2810 2811 if Buffer_Ends_With ('"') then 2812 Buffer_Remove ('"'); 2813 else 2814 Set_Msg_Quote; 2815 end if; 2816 end if; 2817 2818 -- If the original type did not come from a predefined file, add the 2819 -- location where the type was defined. 2820 2821 if Sloc (Error_Msg_Node_1) > Standard_Location 2822 and then 2823 not Is_Predefined_Unit (Get_Source_Unit (Error_Msg_Node_1)) 2824 then 2825 Get_Name_String (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1))); 2826 Set_Msg_Str (" defined"); 2827 Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag); 2828 2829 -- If it did come from a predefined file, deal with the case where 2830 -- this was a file with a generic instantiation from elsewhere. 2831 2832 else 2833 if Sloc (Error_Msg_Node_1) > Standard_Location then 2834 declare 2835 Iloc : constant Source_Ptr := 2836 Instantiation_Location (Sloc (Error_Msg_Node_1)); 2837 2838 begin 2839 if Iloc /= No_Location 2840 and then not Suppress_Instance_Location 2841 then 2842 Set_Msg_Str (" from instance"); 2843 Set_Msg_Insertion_Line_Number (Iloc, Flag); 2844 end if; 2845 end; 2846 end if; 2847 end if; 2848 end Set_Msg_Insertion_Type_Reference; 2849 2850 --------------------------------- 2851 -- Set_Msg_Insertion_Unit_Name -- 2852 --------------------------------- 2853 2854 procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is 2855 begin 2856 if Error_Msg_Unit_1 = No_Unit_Name then 2857 null; 2858 2859 elsif Error_Msg_Unit_1 = Error_Unit_Name then 2860 Set_Msg_Blank; 2861 Set_Msg_Str ("<error>"); 2862 2863 else 2864 Get_Unit_Name_String (Error_Msg_Unit_1, Suffix); 2865 Set_Msg_Blank; 2866 Set_Msg_Quote; 2867 Set_Msg_Name_Buffer; 2868 Set_Msg_Quote; 2869 end if; 2870 2871 -- The following assignment ensures that a second percent insertion 2872 -- character will correspond to the Error_Msg_Unit_2 parameter. We 2873 -- suppress possible validity checks in case operating in -gnatVa mode, 2874 -- and Error_Msg_Unit_2 is not needed and has not been set. 2875 2876 declare 2877 pragma Suppress (Range_Check); 2878 begin 2879 Error_Msg_Unit_1 := Error_Msg_Unit_2; 2880 end; 2881 end Set_Msg_Insertion_Unit_Name; 2882 2883 ------------------ 2884 -- Set_Msg_Node -- 2885 ------------------ 2886 2887 procedure Set_Msg_Node (Node : Node_Id) is 2888 Loc : Source_Ptr; 2889 Ent : Entity_Id; 2890 Nam : Name_Id; 2891 2892 begin 2893 case Nkind (Node) is 2894 when N_Designator => 2895 Set_Msg_Node (Name (Node)); 2896 Set_Msg_Char ('.'); 2897 Set_Msg_Node (Identifier (Node)); 2898 return; 2899 2900 when N_Defining_Program_Unit_Name => 2901 Set_Msg_Node (Name (Node)); 2902 Set_Msg_Char ('.'); 2903 Set_Msg_Node (Defining_Identifier (Node)); 2904 return; 2905 2906 when N_Expanded_Name 2907 | N_Selected_Component 2908 => 2909 Set_Msg_Node (Prefix (Node)); 2910 Set_Msg_Char ('.'); 2911 Set_Msg_Node (Selector_Name (Node)); 2912 return; 2913 2914 when others => 2915 null; 2916 end case; 2917 2918 -- The only remaining possibilities are identifiers, defining 2919 -- identifiers, pragmas, and pragma argument associations. 2920 2921 if Nkind (Node) = N_Pragma then 2922 Nam := Pragma_Name (Node); 2923 Loc := Sloc (Node); 2924 2925 -- The other cases have Chars fields 2926 2927 -- First deal with internal names, which generally represent something 2928 -- gone wrong. First attempt: if this is a rewritten node that rewrites 2929 -- something with a Chars field that is not an internal name, use that. 2930 2931 elsif Is_Internal_Name (Chars (Node)) 2932 and then Nkind (Original_Node (Node)) in N_Has_Chars 2933 and then not Is_Internal_Name (Chars (Original_Node (Node))) 2934 then 2935 Nam := Chars (Original_Node (Node)); 2936 Loc := Sloc (Original_Node (Node)); 2937 2938 -- Another shot for internal names, in the case of internal type names, 2939 -- we try to find a reasonable representation for the external name. 2940 2941 elsif Is_Internal_Name (Chars (Node)) 2942 and then 2943 ((Is_Entity_Name (Node) 2944 and then Present (Entity (Node)) 2945 and then Is_Type (Entity (Node))) 2946 or else 2947 (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node))) 2948 then 2949 if Nkind (Node) = N_Identifier then 2950 Ent := Entity (Node); 2951 else 2952 Ent := Node; 2953 end if; 2954 2955 Loc := Sloc (Ent); 2956 2957 -- If the type is the designated type of an access_to_subprogram, 2958 -- then there is no name to provide in the call. 2959 2960 if Ekind (Ent) = E_Subprogram_Type then 2961 return; 2962 2963 -- Otherwise, we will be able to find some kind of name to output 2964 2965 else 2966 Unwind_Internal_Type (Ent); 2967 Nam := Chars (Ent); 2968 end if; 2969 2970 -- If not internal name, or if we could not find a reasonable possible 2971 -- substitution for the internal name, just use name in Chars field. 2972 2973 else 2974 Nam := Chars (Node); 2975 Loc := Sloc (Node); 2976 end if; 2977 2978 -- At this stage, the name to output is in Nam 2979 2980 Get_Unqualified_Decoded_Name_String (Nam); 2981 2982 -- Remove trailing upper case letters from the name (useful for 2983 -- dealing with some cases of internal names). 2984 2985 while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop 2986 Name_Len := Name_Len - 1; 2987 end loop; 2988 2989 -- If we have any of the names from standard that start with the 2990 -- characters "any " (e.g. Any_Type), then kill the message since 2991 -- almost certainly it is a junk cascaded message. 2992 2993 if Name_Len > 4 2994 and then Name_Buffer (1 .. 4) = "any " 2995 then 2996 Kill_Message := True; 2997 end if; 2998 2999 -- If we still have an internal name, kill the message (will only 3000 -- work if we already had errors!) 3001 3002 if Is_Internal_Name then 3003 Kill_Message := True; 3004 end if; 3005 -- Remaining step is to adjust casing and possibly add 'Class 3006 3007 Adjust_Name_Case (Global_Name_Buffer, Loc); 3008 Set_Msg_Name_Buffer; 3009 Add_Class; 3010 end Set_Msg_Node; 3011 3012 ------------------ 3013 -- Set_Msg_Text -- 3014 ------------------ 3015 3016 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is 3017 C : Character; -- Current character 3018 P : Natural; -- Current index; 3019 3020 procedure Skip_Msg_Insertion_Warning (C : Character); 3021 -- Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same 3022 -- sequences using < instead of ?). The caller has already bumped 3023 -- the pointer past the initial ? or < and C is set to this initial 3024 -- character (? or <). This procedure skips past the rest of the 3025 -- sequence. We do not need to set Msg_Insertion_Char, since this 3026 -- was already done during the message prescan. 3027 3028 -------------------------------- 3029 -- Skip_Msg_Insertion_Warning -- 3030 -------------------------------- 3031 3032 procedure Skip_Msg_Insertion_Warning (C : Character) is 3033 begin 3034 if P <= Text'Last and then Text (P) = C then 3035 P := P + 1; 3036 3037 elsif P + 1 <= Text'Last 3038 and then (Text (P) in 'a' .. 'z' 3039 or else 3040 Text (P) in 'A' .. 'Z' 3041 or else 3042 Text (P) = '*' 3043 or else 3044 Text (P) = '$') 3045 and then Text (P + 1) = C 3046 then 3047 P := P + 2; 3048 end if; 3049 end Skip_Msg_Insertion_Warning; 3050 3051 -- Start of processing for Set_Msg_Text 3052 3053 begin 3054 Manual_Quote_Mode := False; 3055 Msglen := 0; 3056 Flag_Source := Get_Source_File_Index (Flag); 3057 3058 -- Skip info: at start, we have recorded this in Is_Info_Msg, and this 3059 -- will be used (Info field in error message object) to put back the 3060 -- string when it is printed. We need to do this, or we get confused 3061 -- with instantiation continuations. 3062 3063 if Text'Length > 6 3064 and then Text (Text'First .. Text'First + 5) = "info: " 3065 then 3066 P := Text'First + 6; 3067 else 3068 P := Text'First; 3069 end if; 3070 3071 -- Loop through characters of message 3072 3073 while P <= Text'Last loop 3074 C := Text (P); 3075 P := P + 1; 3076 3077 -- Check for insertion character or sequence 3078 3079 case C is 3080 when '%' => 3081 if P <= Text'Last and then Text (P) = '%' then 3082 P := P + 1; 3083 Set_Msg_Insertion_Name_Literal; 3084 else 3085 Set_Msg_Insertion_Name; 3086 end if; 3087 3088 when '$' => 3089 if P <= Text'Last and then Text (P) = '$' then 3090 P := P + 1; 3091 Set_Msg_Insertion_Unit_Name (Suffix => False); 3092 else 3093 Set_Msg_Insertion_Unit_Name; 3094 end if; 3095 3096 when '{' => 3097 Set_Msg_Insertion_File_Name; 3098 3099 when '}' => 3100 Set_Msg_Insertion_Type_Reference (Flag); 3101 3102 when '*' => 3103 Set_Msg_Insertion_Reserved_Name; 3104 3105 when '&' => 3106 Set_Msg_Insertion_Node; 3107 3108 when '#' => 3109 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); 3110 3111 when '\' => 3112 Continuation := True; 3113 3114 if P <= Text'Last and then Text (P) = '\' then 3115 Continuation_New_Line := True; 3116 P := P + 1; 3117 end if; 3118 3119 when '@' => 3120 Set_Msg_Insertion_Column; 3121 3122 when '>' => 3123 Set_Msg_Insertion_Run_Time_Name; 3124 3125 when '^' => 3126 Set_Msg_Insertion_Uint; 3127 3128 when '`' => 3129 Manual_Quote_Mode := not Manual_Quote_Mode; 3130 Set_Msg_Char ('"'); 3131 3132 when '!' => 3133 null; -- already dealt with 3134 3135 when '?' => 3136 Skip_Msg_Insertion_Warning ('?'); 3137 3138 when '<' => 3139 Skip_Msg_Insertion_Warning ('<'); 3140 3141 when '|' => 3142 null; -- already dealt with 3143 3144 when ''' => 3145 Set_Msg_Char (Text (P)); 3146 P := P + 1; 3147 3148 when '~' => 3149 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen)); 3150 3151 -- Upper case letter 3152 3153 when 'A' .. 'Z' => 3154 3155 -- Start of reserved word if two or more 3156 3157 if P <= Text'Last and then Text (P) in 'A' .. 'Z' then 3158 P := P - 1; 3159 Set_Msg_Insertion_Reserved_Word (Text, P); 3160 3161 -- Single upper case letter is just inserted 3162 3163 else 3164 Set_Msg_Char (C); 3165 end if; 3166 3167 -- '[' (will be/would have been raised at run time) 3168 3169 when '[' => 3170 3171 -- Switch the message from a warning to an error if the flag 3172 -- -gnatwE is specified to treat run-time exception warnings 3173 -- as errors. 3174 3175 if Is_Warning_Msg 3176 and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors 3177 then 3178 Is_Warning_Msg := False; 3179 end if; 3180 3181 if Is_Warning_Msg then 3182 Set_Msg_Str ("will be raised at run time"); 3183 else 3184 Set_Msg_Str ("would have been raised at run time"); 3185 end if; 3186 3187 -- ']' (may be/might have been raised at run time) 3188 3189 when ']' => 3190 if Is_Warning_Msg then 3191 Set_Msg_Str ("may be raised at run time"); 3192 else 3193 Set_Msg_Str ("might have been raised at run time"); 3194 end if; 3195 3196 -- Normal character with no special treatment 3197 3198 when others => 3199 Set_Msg_Char (C); 3200 end case; 3201 end loop; 3202 end Set_Msg_Text; 3203 3204 ---------------- 3205 -- Set_Posted -- 3206 ---------------- 3207 3208 procedure Set_Posted (N : Node_Id) is 3209 P : Node_Id; 3210 3211 begin 3212 if Is_Serious_Error then 3213 3214 -- We always set Error_Posted on the node itself 3215 3216 Set_Error_Posted (N); 3217 3218 -- If it is a subexpression, then set Error_Posted on parents up to 3219 -- and including the first non-subexpression construct. This helps 3220 -- avoid cascaded error messages within a single expression. 3221 3222 P := N; 3223 loop 3224 P := Parent (P); 3225 exit when No (P); 3226 Set_Error_Posted (P); 3227 exit when Nkind (P) not in N_Subexpr; 3228 end loop; 3229 3230 if Nkind_In (P, N_Pragma_Argument_Association, 3231 N_Component_Association, 3232 N_Discriminant_Association, 3233 N_Generic_Association, 3234 N_Parameter_Association) 3235 then 3236 Set_Error_Posted (Parent (P)); 3237 end if; 3238 3239 -- A special check, if we just posted an error on an attribute 3240 -- definition clause, then also set the entity involved as posted. 3241 -- For example, this stops complaining about the alignment after 3242 -- complaining about the size, which is likely to be useless. 3243 3244 if Nkind (P) = N_Attribute_Definition_Clause then 3245 if Is_Entity_Name (Name (P)) then 3246 Set_Error_Posted (Entity (Name (P))); 3247 end if; 3248 end if; 3249 end if; 3250 end Set_Posted; 3251 3252 ----------------------- 3253 -- Set_Qualification -- 3254 ----------------------- 3255 3256 procedure Set_Qualification (N : Nat; E : Entity_Id) is 3257 begin 3258 if N /= 0 and then Scope (E) /= Standard_Standard then 3259 Set_Qualification (N - 1, Scope (E)); 3260 Set_Msg_Node (Scope (E)); 3261 Set_Msg_Char ('.'); 3262 end if; 3263 end Set_Qualification; 3264 3265 ------------------------ 3266 -- Special_Msg_Delete -- 3267 ------------------------ 3268 3269 -- Is it really right to have all this specialized knowledge in errout? 3270 3271 function Special_Msg_Delete 3272 (Msg : String; 3273 N : Node_Or_Entity_Id; 3274 E : Node_Or_Entity_Id) return Boolean 3275 is 3276 begin 3277 -- Never delete messages in -gnatdO mode 3278 3279 if Debug_Flag_OO then 3280 return False; 3281 3282 -- Processing for "Size too small" messages 3283 3284 elsif Is_Size_Too_Small_Message (Msg) then 3285 3286 -- Suppress "size too small" errors in CodePeer mode, since code may 3287 -- be analyzed in a different configuration than the one used for 3288 -- compilation. Even when the configurations match, this message 3289 -- may be issued on correct code, because pragma Pack is ignored 3290 -- in CodePeer mode. 3291 3292 if CodePeer_Mode then 3293 return True; 3294 3295 -- When a size is wrong for a frozen type there is no explicit size 3296 -- clause, and other errors have occurred, suppress the message, 3297 -- since it is likely that this size error is a cascaded result of 3298 -- other errors. The reason we eliminate unfrozen types is that 3299 -- messages issued before the freeze type are for sure OK. 3300 3301 elsif Is_Frozen (E) 3302 and then Serious_Errors_Detected > 0 3303 and then Nkind (N) /= N_Component_Clause 3304 and then Nkind (Parent (N)) /= N_Component_Clause 3305 and then 3306 No (Get_Attribute_Definition_Clause (E, Attribute_Size)) 3307 and then 3308 No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size)) 3309 and then 3310 No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size)) 3311 then 3312 return True; 3313 end if; 3314 end if; 3315 3316 -- All special tests complete, so go ahead with message 3317 3318 return False; 3319 end Special_Msg_Delete; 3320 3321 ----------------- 3322 -- SPARK_Msg_N -- 3323 ----------------- 3324 3325 procedure SPARK_Msg_N (Msg : String; N : Node_Or_Entity_Id) is 3326 begin 3327 if SPARK_Mode /= Off then 3328 Error_Msg_N (Msg, N); 3329 end if; 3330 end SPARK_Msg_N; 3331 3332 ------------------ 3333 -- SPARK_Msg_NE -- 3334 ------------------ 3335 3336 procedure SPARK_Msg_NE 3337 (Msg : String; 3338 N : Node_Or_Entity_Id; 3339 E : Node_Or_Entity_Id) 3340 is 3341 begin 3342 if SPARK_Mode /= Off then 3343 Error_Msg_NE (Msg, N, E); 3344 end if; 3345 end SPARK_Msg_NE; 3346 3347 -------------------------- 3348 -- Unwind_Internal_Type -- 3349 -------------------------- 3350 3351 procedure Unwind_Internal_Type (Ent : in out Entity_Id) is 3352 Derived : Boolean := False; 3353 Mchar : Character; 3354 Old_Ent : Entity_Id; 3355 3356 begin 3357 -- Undo placement of a quote, since we will put it back later 3358 3359 Mchar := Msg_Buffer (Msglen); 3360 3361 if Mchar = '"' then 3362 Msglen := Msglen - 1; 3363 end if; 3364 3365 -- The loop here deals with recursive types, we are trying to find a 3366 -- related entity that is not an implicit type. Note that the check with 3367 -- Old_Ent stops us from getting "stuck". Also, we don't output the 3368 -- "type derived from" message more than once in the case where we climb 3369 -- up multiple levels. 3370 3371 Find : loop 3372 Old_Ent := Ent; 3373 3374 -- Implicit access type, use directly designated type In Ada 2005, 3375 -- the designated type may be an anonymous access to subprogram, in 3376 -- which case we can only point to its definition. 3377 3378 if Is_Access_Type (Ent) then 3379 if Ekind (Ent) = E_Access_Subprogram_Type 3380 or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type 3381 or else Is_Access_Protected_Subprogram_Type (Ent) 3382 then 3383 Ent := Directly_Designated_Type (Ent); 3384 3385 if not Comes_From_Source (Ent) then 3386 if Buffer_Ends_With ("type ") then 3387 Buffer_Remove ("type "); 3388 end if; 3389 end if; 3390 3391 if Ekind (Ent) = E_Function then 3392 Set_Msg_Str ("access to function "); 3393 elsif Ekind (Ent) = E_Procedure then 3394 Set_Msg_Str ("access to procedure "); 3395 else 3396 Set_Msg_Str ("access to subprogram"); 3397 end if; 3398 3399 exit Find; 3400 3401 -- Type is access to object, named or anonymous 3402 3403 else 3404 Set_Msg_Str ("access to "); 3405 Ent := Directly_Designated_Type (Ent); 3406 end if; 3407 3408 -- Classwide type 3409 3410 elsif Is_Class_Wide_Type (Ent) then 3411 Class_Flag := True; 3412 Ent := Root_Type (Ent); 3413 3414 -- Use base type if this is a subtype 3415 3416 elsif Ent /= Base_Type (Ent) then 3417 Buffer_Remove ("type "); 3418 3419 -- Avoid duplication "subtype of subtype of", and also replace 3420 -- "derived from subtype of" simply by "derived from" 3421 3422 if not Buffer_Ends_With ("subtype of ") 3423 and then not Buffer_Ends_With ("derived from ") 3424 then 3425 Set_Msg_Str ("subtype of "); 3426 end if; 3427 3428 Ent := Base_Type (Ent); 3429 3430 -- If this is a base type with a first named subtype, use the first 3431 -- named subtype instead. This is not quite accurate in all cases, 3432 -- but it makes too much noise to be accurate and add 'Base in all 3433 -- cases. Note that we only do this is the first named subtype is not 3434 -- itself an internal name. This avoids the obvious loop (subtype -> 3435 -- basetype -> subtype) which would otherwise occur). 3436 3437 else 3438 declare 3439 FST : constant Entity_Id := First_Subtype (Ent); 3440 3441 begin 3442 if not Is_Internal_Name (Chars (FST)) then 3443 Ent := FST; 3444 exit Find; 3445 3446 -- Otherwise use root type 3447 3448 else 3449 if not Derived then 3450 Buffer_Remove ("type "); 3451 3452 -- Test for "subtype of type derived from" which seems 3453 -- excessive and is replaced by "type derived from". 3454 3455 Buffer_Remove ("subtype of"); 3456 3457 -- Avoid duplicated "type derived from type derived from" 3458 3459 if not Buffer_Ends_With ("type derived from ") then 3460 Set_Msg_Str ("type derived from "); 3461 end if; 3462 3463 Derived := True; 3464 end if; 3465 end if; 3466 end; 3467 3468 Ent := Etype (Ent); 3469 end if; 3470 3471 -- If we are stuck in a loop, get out and settle for the internal 3472 -- name after all. In this case we set to kill the message if it is 3473 -- not the first error message (we really try hard not to show the 3474 -- dirty laundry of the implementation to the poor user). 3475 3476 if Ent = Old_Ent then 3477 Kill_Message := True; 3478 exit Find; 3479 end if; 3480 3481 -- Get out if we finally found a non-internal name to use 3482 3483 exit Find when not Is_Internal_Name (Chars (Ent)); 3484 end loop Find; 3485 3486 if Mchar = '"' then 3487 Set_Msg_Char ('"'); 3488 end if; 3489 end Unwind_Internal_Type; 3490 3491 -------------------- 3492 -- Warn_Insertion -- 3493 -------------------- 3494 3495 function Warn_Insertion return String is 3496 begin 3497 case Warning_Msg_Char is 3498 when '?' => 3499 return "??"; 3500 3501 when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' => 3502 return '?' & Warning_Msg_Char & '?'; 3503 3504 when ' ' => 3505 return "?"; 3506 3507 when others => 3508 raise Program_Error; 3509 end case; 3510 end Warn_Insertion; 3511 3512end Errout; 3513