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 end Handle_Serious_Error; 865 866 -- Start of processing for Error_Msg_Internal 867 868 begin 869 if Raise_Exception_On_Error /= 0 then 870 raise Error_Msg_Exception; 871 end if; 872 873 Continuation := Msg_Cont; 874 Continuation_New_Line := False; 875 Suppress_Message := False; 876 Kill_Message := False; 877 Set_Msg_Text (Msg, Sptr); 878 879 -- Kill continuation if parent message killed 880 881 if Continuation and Last_Killed then 882 return; 883 end if; 884 885 -- Return without doing anything if message is suppressed 886 887 if Suppress_Message 888 and then not All_Errors_Mode 889 and then not Is_Warning_Msg 890 and then not Is_Unconditional_Msg 891 then 892 if not Continuation then 893 Last_Killed := True; 894 end if; 895 896 return; 897 end if; 898 899 -- Return without doing anything if message is killed and this is not 900 -- the first error message. The philosophy is that if we get a weird 901 -- error message and we already have had a message, then we hope the 902 -- weird message is a junk cascaded message 903 904 if Kill_Message 905 and then not All_Errors_Mode 906 and then Total_Errors_Detected /= 0 907 then 908 if not Continuation then 909 Last_Killed := True; 910 end if; 911 912 return; 913 end if; 914 915 -- Special check for warning message to see if it should be output 916 917 if Is_Warning_Msg then 918 919 -- Immediate return if warning message and warnings are suppressed 920 921 if Warnings_Suppressed (Optr) /= No_String 922 or else 923 Warnings_Suppressed (Sptr) /= No_String 924 then 925 Cur_Msg := No_Error_Msg; 926 return; 927 end if; 928 929 -- If the flag location is in the main extended source unit then for 930 -- sure we want the warning since it definitely belongs 931 932 if In_Extended_Main_Source_Unit (Sptr) then 933 null; 934 935 -- If the main unit has not been read yet. the warning must be on 936 -- a configuration file: gnat.adc or user-defined. This means we 937 -- are not parsing the main unit yet, so skip following checks. 938 939 elsif No (Cunit (Main_Unit)) then 940 null; 941 942 -- If the flag location is not in the main extended source unit, then 943 -- we want to eliminate the warning, unless it is in the extended 944 -- main code unit and we want warnings on the instance. 945 946 elsif In_Extended_Main_Code_Unit (Sptr) and then Warn_On_Instance then 947 null; 948 949 -- Keep warning if debug flag G set 950 951 elsif Debug_Flag_GG then 952 null; 953 954 -- Keep warning if message text contains !! 955 956 elsif Has_Double_Exclam then 957 null; 958 959 -- Here is where we delete a warning from a with'ed unit 960 961 else 962 Cur_Msg := No_Error_Msg; 963 964 if not Continuation then 965 Last_Killed := True; 966 end if; 967 968 return; 969 end if; 970 end if; 971 972 -- If message is to be ignored in special ignore message mode, this is 973 -- where we do this special processing, bypassing message output. 974 975 if Ignore_Errors_Enable > 0 then 976 if Is_Serious_Error then 977 Handle_Serious_Error; 978 end if; 979 980 return; 981 end if; 982 983 -- If error message line length set, and this is a continuation message 984 -- then all we do is to append the text to the text of the last message 985 -- with a comma space separator (eliminating a possible (style) or 986 -- info prefix). 987 988 if Error_Msg_Line_Length /= 0 and then Continuation then 989 Cur_Msg := Errors.Last; 990 991 declare 992 Oldm : String_Ptr := Errors.Table (Cur_Msg).Text; 993 Newm : String (1 .. Oldm'Last + 2 + Msglen); 994 Newl : Natural; 995 M : Natural; 996 997 begin 998 -- First copy old message to new one and free it 999 1000 Newm (Oldm'Range) := Oldm.all; 1001 Newl := Oldm'Length; 1002 Free (Oldm); 1003 1004 -- Remove (style) or info: at start of message 1005 1006 if Msglen > 8 and then Msg_Buffer (1 .. 8) = "(style) " then 1007 M := 9; 1008 1009 elsif Msglen > 6 and then Msg_Buffer (1 .. 6) = "info: " then 1010 M := 7; 1011 1012 else 1013 M := 1; 1014 end if; 1015 1016 -- Now deal with separation between messages. Normally this is 1017 -- simply comma space, but there are some special cases. 1018 1019 -- If continuation new line, then put actual NL character in msg 1020 1021 if Continuation_New_Line then 1022 Newl := Newl + 1; 1023 Newm (Newl) := ASCII.LF; 1024 1025 -- If continuation message is enclosed in parentheses, then 1026 -- special treatment (don't need a comma, and we want to combine 1027 -- successive parenthetical remarks into a single one with 1028 -- separating commas). 1029 1030 elsif Msg_Buffer (M) = '(' and then Msg_Buffer (Msglen) = ')' then 1031 1032 -- Case where existing message ends in right paren, remove 1033 -- and separate parenthetical remarks with a comma. 1034 1035 if Newm (Newl) = ')' then 1036 Newm (Newl) := ','; 1037 Msg_Buffer (M) := ' '; 1038 1039 -- Case where we are adding new parenthetical comment 1040 1041 else 1042 Newl := Newl + 1; 1043 Newm (Newl) := ' '; 1044 end if; 1045 1046 -- Case where continuation not in parens and no new line 1047 1048 else 1049 Newm (Newl + 1 .. Newl + 2) := ", "; 1050 Newl := Newl + 2; 1051 end if; 1052 1053 -- Append new message 1054 1055 Newm (Newl + 1 .. Newl + Msglen - M + 1) := 1056 Msg_Buffer (M .. Msglen); 1057 Newl := Newl + Msglen - M + 1; 1058 Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl)); 1059 1060 -- Update warning msg flag and message doc char if needed 1061 1062 if Is_Warning_Msg then 1063 if not Errors.Table (Cur_Msg).Warn then 1064 Errors.Table (Cur_Msg).Warn := True; 1065 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; 1066 1067 elsif Warning_Msg_Char /= ' ' then 1068 Errors.Table (Cur_Msg).Warn_Chr := Warning_Msg_Char; 1069 end if; 1070 end if; 1071 end; 1072 1073 return; 1074 end if; 1075 1076 -- Here we build a new error object 1077 1078 Errors.Append 1079 ((Text => new String'(Msg_Buffer (1 .. Msglen)), 1080 Next => No_Error_Msg, 1081 Prev => No_Error_Msg, 1082 Sptr => Sptr, 1083 Optr => Optr, 1084 Sfile => Get_Source_File_Index (Sptr), 1085 Line => Get_Physical_Line_Number (Sptr), 1086 Col => Get_Column_Number (Sptr), 1087 Warn => Is_Warning_Msg, 1088 Info => Is_Info_Msg, 1089 Check => Is_Check_Msg, 1090 Warn_Err => False, -- reset below 1091 Warn_Chr => Warning_Msg_Char, 1092 Style => Is_Style_Msg, 1093 Serious => Is_Serious_Error, 1094 Uncond => Is_Unconditional_Msg, 1095 Msg_Cont => Continuation, 1096 Deleted => False, 1097 Node => Node)); 1098 Cur_Msg := Errors.Last; 1099 1100 -- Test if warning to be treated as error 1101 1102 Warn_Err := 1103 Is_Warning_Msg 1104 and then (Warning_Treated_As_Error (Msg_Buffer (1 .. Msglen)) 1105 or else 1106 Warning_Treated_As_Error (Get_Warning_Tag (Cur_Msg))); 1107 1108 -- Propagate Warn_Err to this message and preceding continuations 1109 1110 for J in reverse 1 .. Errors.Last loop 1111 Errors.Table (J).Warn_Err := Warn_Err; 1112 exit when not Errors.Table (J).Msg_Cont; 1113 end loop; 1114 1115 -- If immediate errors mode set, output error message now. Also output 1116 -- now if the -d1 debug flag is set (so node number message comes out 1117 -- just before actual error message) 1118 1119 if Debug_Flag_OO or else Debug_Flag_1 then 1120 Write_Eol; 1121 Output_Source_Line 1122 (Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Sfile, True); 1123 Temp_Msg := Cur_Msg; 1124 Output_Error_Msgs (Temp_Msg); 1125 1126 -- If not in immediate errors mode, then we insert the message in the 1127 -- error chain for later output by Finalize. The messages are sorted 1128 -- first by unit (main unit comes first), and within a unit by source 1129 -- location (earlier flag location first in the chain). 1130 1131 else 1132 -- First a quick check, does this belong at the very end of the chain 1133 -- of error messages. This saves a lot of time in the normal case if 1134 -- there are lots of messages. 1135 1136 if Last_Error_Msg /= No_Error_Msg 1137 and then Errors.Table (Cur_Msg).Sfile = 1138 Errors.Table (Last_Error_Msg).Sfile 1139 and then (Sptr > Errors.Table (Last_Error_Msg).Sptr 1140 or else 1141 (Sptr = Errors.Table (Last_Error_Msg).Sptr 1142 and then 1143 Optr > Errors.Table (Last_Error_Msg).Optr)) 1144 then 1145 Prev_Msg := Last_Error_Msg; 1146 Next_Msg := No_Error_Msg; 1147 1148 -- Otherwise do a full sequential search for the insertion point 1149 1150 else 1151 Prev_Msg := No_Error_Msg; 1152 Next_Msg := First_Error_Msg; 1153 while Next_Msg /= No_Error_Msg loop 1154 exit when 1155 Errors.Table (Cur_Msg).Sfile < Errors.Table (Next_Msg).Sfile; 1156 1157 if Errors.Table (Cur_Msg).Sfile = Errors.Table (Next_Msg).Sfile 1158 then 1159 exit when Sptr < Errors.Table (Next_Msg).Sptr 1160 or else (Sptr = Errors.Table (Next_Msg).Sptr 1161 and then Optr < Errors.Table (Next_Msg).Optr); 1162 end if; 1163 1164 Prev_Msg := Next_Msg; 1165 Next_Msg := Errors.Table (Next_Msg).Next; 1166 end loop; 1167 end if; 1168 1169 -- Now we insert the new message in the error chain. 1170 1171 -- The possible insertion point for the new message is after Prev_Msg 1172 -- and before Next_Msg. However, this is where we do a special check 1173 -- for redundant parsing messages, defined as messages posted on the 1174 -- same line. The idea here is that probably such messages are junk 1175 -- from the parser recovering. In full errors mode, we don't do this 1176 -- deletion, but otherwise such messages are discarded at this stage. 1177 1178 if Prev_Msg /= No_Error_Msg 1179 and then Errors.Table (Prev_Msg).Line = 1180 Errors.Table (Cur_Msg).Line 1181 and then Errors.Table (Prev_Msg).Sfile = 1182 Errors.Table (Cur_Msg).Sfile 1183 and then Compiler_State = Parsing 1184 and then not All_Errors_Mode 1185 then 1186 -- Don't delete unconditional messages and at this stage, don't 1187 -- delete continuation lines; we attempted to delete those earlier 1188 -- if the parent message was deleted. 1189 1190 if not Errors.Table (Cur_Msg).Uncond 1191 and then not Continuation 1192 then 1193 -- Don't delete if prev msg is warning and new msg is an error. 1194 -- This is because we don't want a real error masked by a 1195 -- warning. In all other cases (that is parse errors for the 1196 -- same line that are not unconditional) we do delete the 1197 -- message. This helps to avoid junk extra messages from 1198 -- cascaded parsing errors 1199 1200 if not (Errors.Table (Prev_Msg).Warn 1201 or else 1202 Errors.Table (Prev_Msg).Style) 1203 or else 1204 (Errors.Table (Cur_Msg).Warn 1205 or else 1206 Errors.Table (Cur_Msg).Style) 1207 then 1208 -- All tests passed, delete the message by simply returning 1209 -- without any further processing. 1210 1211 pragma Assert (not Continuation); 1212 1213 Last_Killed := True; 1214 return; 1215 end if; 1216 end if; 1217 end if; 1218 1219 -- Come here if message is to be inserted in the error chain 1220 1221 if not Continuation then 1222 Last_Killed := False; 1223 end if; 1224 1225 if Prev_Msg = No_Error_Msg then 1226 First_Error_Msg := Cur_Msg; 1227 else 1228 Errors.Table (Prev_Msg).Next := Cur_Msg; 1229 end if; 1230 1231 Errors.Table (Cur_Msg).Next := Next_Msg; 1232 1233 if Next_Msg = No_Error_Msg then 1234 Last_Error_Msg := Cur_Msg; 1235 end if; 1236 end if; 1237 1238 -- Bump appropriate statistics counts 1239 1240 if Errors.Table (Cur_Msg).Info then 1241 1242 -- Could be (usually is) both "info" and "warning" 1243 1244 if Errors.Table (Cur_Msg).Warn then 1245 Warning_Info_Messages := Warning_Info_Messages + 1; 1246 Warnings_Detected := Warnings_Detected + 1; 1247 else 1248 Report_Info_Messages := Report_Info_Messages + 1; 1249 end if; 1250 1251 elsif Errors.Table (Cur_Msg).Warn 1252 or else Errors.Table (Cur_Msg).Style 1253 then 1254 Warnings_Detected := Warnings_Detected + 1; 1255 1256 elsif Errors.Table (Cur_Msg).Check then 1257 Check_Messages := Check_Messages + 1; 1258 1259 else 1260 Total_Errors_Detected := Total_Errors_Detected + 1; 1261 1262 if Errors.Table (Cur_Msg).Serious then 1263 Serious_Errors_Detected := Serious_Errors_Detected + 1; 1264 Handle_Serious_Error; 1265 1266 -- If not serious error, set Fatal_Error to indicate ignored error 1267 1268 else 1269 declare 1270 U : constant Unit_Number_Type := Get_Source_Unit (Sptr); 1271 begin 1272 if Fatal_Error (U) = None then 1273 Set_Fatal_Error (U, Error_Ignored); 1274 end if; 1275 end; 1276 end if; 1277 end if; 1278 1279 -- Record warning message issued 1280 1281 if Errors.Table (Cur_Msg).Warn 1282 and then not Errors.Table (Cur_Msg).Msg_Cont 1283 then 1284 Warning_Msg := Cur_Msg; 1285 end if; 1286 1287 -- If too many warnings turn off warnings 1288 1289 if Maximum_Messages /= 0 then 1290 if Warnings_Detected = Maximum_Messages then 1291 Warning_Mode := Suppress; 1292 end if; 1293 1294 -- If too many errors abandon compilation 1295 1296 if Total_Errors_Detected = Maximum_Messages then 1297 raise Unrecoverable_Error; 1298 end if; 1299 end if; 1300 end Error_Msg_Internal; 1301 1302 ----------------- 1303 -- Error_Msg_N -- 1304 ----------------- 1305 1306 procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id) is 1307 begin 1308 Error_Msg_NEL (Msg, N, N, Sloc (N)); 1309 end Error_Msg_N; 1310 1311 ------------------ 1312 -- Error_Msg_NE -- 1313 ------------------ 1314 1315 procedure Error_Msg_NE 1316 (Msg : String; 1317 N : Node_Or_Entity_Id; 1318 E : Node_Or_Entity_Id) 1319 is 1320 begin 1321 Error_Msg_NEL (Msg, N, E, Sloc (N)); 1322 end Error_Msg_NE; 1323 1324 ------------------- 1325 -- Error_Msg_NEL -- 1326 ------------------- 1327 1328 procedure Error_Msg_NEL 1329 (Msg : String; 1330 N : Node_Or_Entity_Id; 1331 E : Node_Or_Entity_Id; 1332 Flag_Location : Source_Ptr) 1333 is 1334 begin 1335 if Special_Msg_Delete (Msg, N, E) then 1336 return; 1337 end if; 1338 1339 Prescan_Message (Msg); 1340 1341 -- Special handling for warning messages 1342 1343 if Is_Warning_Msg then 1344 1345 -- Suppress if no warnings set for either entity or node 1346 1347 if No_Warnings (N) or else No_Warnings (E) then 1348 1349 -- Disable any continuation messages as well 1350 1351 Last_Killed := True; 1352 return; 1353 end if; 1354 1355 -- Suppress if inside loop that is known to be null or is probably 1356 -- null (case where loop executes only if invalid values present). 1357 -- In either case warnings in the loop are likely to be junk. 1358 1359 declare 1360 P : Node_Id; 1361 1362 begin 1363 P := Parent (N); 1364 while Present (P) loop 1365 if Nkind (P) = N_Loop_Statement 1366 and then Suppress_Loop_Warnings (P) 1367 then 1368 return; 1369 end if; 1370 1371 P := Parent (P); 1372 end loop; 1373 end; 1374 end if; 1375 1376 -- Test for message to be output 1377 1378 if All_Errors_Mode 1379 or else Is_Unconditional_Msg 1380 or else Is_Warning_Msg 1381 or else OK_Node (N) 1382 or else (Msg (Msg'First) = '\' and then not Last_Killed) 1383 then 1384 Debug_Output (N); 1385 Error_Msg_Node_1 := E; 1386 Error_Msg (Msg, Flag_Location, N); 1387 1388 else 1389 Last_Killed := True; 1390 end if; 1391 1392 Set_Posted (N); 1393 end Error_Msg_NEL; 1394 1395 ------------------ 1396 -- Error_Msg_NW -- 1397 ------------------ 1398 1399 procedure Error_Msg_NW 1400 (Eflag : Boolean; 1401 Msg : String; 1402 N : Node_Or_Entity_Id) 1403 is 1404 begin 1405 if Eflag 1406 and then In_Extended_Main_Source_Unit (N) 1407 and then Comes_From_Source (N) 1408 then 1409 Error_Msg_NEL (Msg, N, N, Sloc (N)); 1410 end if; 1411 end Error_Msg_NW; 1412 1413 ----------------- 1414 -- Error_Msg_S -- 1415 ----------------- 1416 1417 procedure Error_Msg_S (Msg : String) is 1418 begin 1419 Error_Msg (Msg, Scan_Ptr); 1420 end Error_Msg_S; 1421 1422 ------------------ 1423 -- Error_Msg_SC -- 1424 ------------------ 1425 1426 procedure Error_Msg_SC (Msg : String) is 1427 begin 1428 -- If we are at end of file, post the flag after the previous token 1429 1430 if Token = Tok_EOF then 1431 Error_Msg_AP (Msg); 1432 1433 -- For all other cases the message is posted at the current token 1434 -- pointer position 1435 1436 else 1437 Error_Msg (Msg, Token_Ptr); 1438 end if; 1439 end Error_Msg_SC; 1440 1441 ------------------ 1442 -- Error_Msg_SP -- 1443 ------------------ 1444 1445 procedure Error_Msg_SP (Msg : String) is 1446 begin 1447 -- Note: in the case where there is no previous token, Prev_Token_Ptr 1448 -- is set to Source_First, which is a reasonable position for the 1449 -- error flag in this situation 1450 1451 Error_Msg (Msg, Prev_Token_Ptr); 1452 end Error_Msg_SP; 1453 1454 -------------- 1455 -- Finalize -- 1456 -------------- 1457 1458 procedure Finalize (Last_Call : Boolean) is 1459 Cur : Error_Msg_Id; 1460 Nxt : Error_Msg_Id; 1461 F : Error_Msg_Id; 1462 1463 procedure Delete_Warning (E : Error_Msg_Id); 1464 -- Delete a warning msg if not already deleted and adjust warning count 1465 1466 -------------------- 1467 -- Delete_Warning -- 1468 -------------------- 1469 1470 procedure Delete_Warning (E : Error_Msg_Id) is 1471 begin 1472 if not Errors.Table (E).Deleted then 1473 Errors.Table (E).Deleted := True; 1474 Warnings_Detected := Warnings_Detected - 1; 1475 1476 if Errors.Table (E).Info then 1477 Warning_Info_Messages := Warning_Info_Messages - 1; 1478 end if; 1479 end if; 1480 end Delete_Warning; 1481 1482 -- Start of processing for Finalize 1483 1484 begin 1485 -- Set Prev pointers 1486 1487 Cur := First_Error_Msg; 1488 while Cur /= No_Error_Msg loop 1489 Nxt := Errors.Table (Cur).Next; 1490 exit when Nxt = No_Error_Msg; 1491 Errors.Table (Nxt).Prev := Cur; 1492 Cur := Nxt; 1493 end loop; 1494 1495 -- Eliminate any duplicated error messages from the list. This is 1496 -- done after the fact to avoid problems with Change_Error_Text. 1497 1498 Cur := First_Error_Msg; 1499 while Cur /= No_Error_Msg loop 1500 Nxt := Errors.Table (Cur).Next; 1501 1502 F := Nxt; 1503 while F /= No_Error_Msg 1504 and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr 1505 loop 1506 Check_Duplicate_Message (Cur, F); 1507 F := Errors.Table (F).Next; 1508 end loop; 1509 1510 Cur := Nxt; 1511 end loop; 1512 1513 -- Mark any messages suppressed by specific warnings as Deleted 1514 1515 Cur := First_Error_Msg; 1516 while Cur /= No_Error_Msg loop 1517 declare 1518 CE : Error_Msg_Object renames Errors.Table (Cur); 1519 Tag : constant String := Get_Warning_Tag (Cur); 1520 1521 begin 1522 if (CE.Warn and not CE.Deleted) 1523 and then 1524 (Warning_Specifically_Suppressed (CE.Sptr, CE.Text, Tag) /= 1525 No_String 1526 or else 1527 Warning_Specifically_Suppressed (CE.Optr, CE.Text, Tag) /= 1528 No_String) 1529 then 1530 Delete_Warning (Cur); 1531 1532 -- If this is a continuation, delete previous parts of message 1533 1534 F := Cur; 1535 while Errors.Table (F).Msg_Cont loop 1536 F := Errors.Table (F).Prev; 1537 exit when F = No_Error_Msg; 1538 Delete_Warning (F); 1539 end loop; 1540 1541 -- Delete any following continuations 1542 1543 F := Cur; 1544 loop 1545 F := Errors.Table (F).Next; 1546 exit when F = No_Error_Msg; 1547 exit when not Errors.Table (F).Msg_Cont; 1548 Delete_Warning (F); 1549 end loop; 1550 end if; 1551 end; 1552 1553 Cur := Errors.Table (Cur).Next; 1554 end loop; 1555 1556 Finalize_Called := True; 1557 1558 -- Check consistency of specific warnings (may add warnings). We only 1559 -- do this on the last call, after all possible warnings are posted. 1560 1561 if Last_Call then 1562 Validate_Specific_Warnings (Error_Msg'Access); 1563 end if; 1564 end Finalize; 1565 1566 ---------------- 1567 -- First_Node -- 1568 ---------------- 1569 1570 function First_Node (C : Node_Id) return Node_Id is 1571 Orig : constant Node_Id := Original_Node (C); 1572 Loc : constant Source_Ptr := Sloc (Orig); 1573 Sfile : constant Source_File_Index := Get_Source_File_Index (Loc); 1574 Earliest : Node_Id; 1575 Eloc : Source_Ptr; 1576 1577 function Test_Earlier (N : Node_Id) return Traverse_Result; 1578 -- Function applied to every node in the construct 1579 1580 procedure Search_Tree_First is new Traverse_Proc (Test_Earlier); 1581 -- Create traversal procedure 1582 1583 ------------------ 1584 -- Test_Earlier -- 1585 ------------------ 1586 1587 function Test_Earlier (N : Node_Id) return Traverse_Result is 1588 Norig : constant Node_Id := Original_Node (N); 1589 Loc : constant Source_Ptr := Sloc (Norig); 1590 1591 begin 1592 -- Check for earlier 1593 1594 if Loc < Eloc 1595 1596 -- Ignore nodes with no useful location information 1597 1598 and then Loc /= Standard_Location 1599 and then Loc /= No_Location 1600 1601 -- Ignore nodes from a different file. This ensures against cases 1602 -- of strange foreign code somehow being present. We don't want 1603 -- wild placement of messages if that happens. 1604 1605 and then Get_Source_File_Index (Loc) = Sfile 1606 then 1607 Earliest := Norig; 1608 Eloc := Loc; 1609 end if; 1610 1611 return OK_Orig; 1612 end Test_Earlier; 1613 1614 -- Start of processing for First_Node 1615 1616 begin 1617 if Nkind (Orig) in N_Subexpr then 1618 Earliest := Orig; 1619 Eloc := Loc; 1620 Search_Tree_First (Orig); 1621 return Earliest; 1622 1623 else 1624 return Orig; 1625 end if; 1626 end First_Node; 1627 1628 ---------------- 1629 -- First_Sloc -- 1630 ---------------- 1631 1632 function First_Sloc (N : Node_Id) return Source_Ptr is 1633 SI : constant Source_File_Index := Source_Index (Get_Source_Unit (N)); 1634 SF : constant Source_Ptr := Source_First (SI); 1635 F : Node_Id; 1636 S : Source_Ptr; 1637 1638 begin 1639 F := First_Node (N); 1640 S := Sloc (F); 1641 1642 -- The following circuit is a bit subtle. When we have parenthesized 1643 -- expressions, then the Sloc will not record the location of the paren, 1644 -- but we would like to post the flag on the paren. So what we do is to 1645 -- crawl up the tree from the First_Node, adjusting the Sloc value for 1646 -- any parentheses we know are present. Yes, we know this circuit is not 1647 -- 100% reliable (e.g. because we don't record all possible paren level 1648 -- values), but this is only for an error message so it is good enough. 1649 1650 Node_Loop : loop 1651 Paren_Loop : for J in 1 .. Paren_Count (F) loop 1652 1653 -- We don't look more than 12 characters behind the current 1654 -- location, and in any case not past the front of the source. 1655 1656 Search_Loop : for K in 1 .. 12 loop 1657 exit Search_Loop when S = SF; 1658 1659 if Source_Text (SI) (S - 1) = '(' then 1660 S := S - 1; 1661 exit Search_Loop; 1662 1663 elsif Source_Text (SI) (S - 1) <= ' ' then 1664 S := S - 1; 1665 1666 else 1667 exit Search_Loop; 1668 end if; 1669 end loop Search_Loop; 1670 end loop Paren_Loop; 1671 1672 exit Node_Loop when F = N; 1673 F := Parent (F); 1674 exit Node_Loop when Nkind (F) not in N_Subexpr; 1675 end loop Node_Loop; 1676 1677 return S; 1678 end First_Sloc; 1679 1680 ----------------------- 1681 -- Get_Ignore_Errors -- 1682 ----------------------- 1683 1684 function Get_Ignore_Errors return Boolean is 1685 begin 1686 return Errors_Must_Be_Ignored; 1687 end Get_Ignore_Errors; 1688 1689 ---------------- 1690 -- Initialize -- 1691 ---------------- 1692 1693 procedure Initialize is 1694 begin 1695 Errors.Init; 1696 First_Error_Msg := No_Error_Msg; 1697 Last_Error_Msg := No_Error_Msg; 1698 Serious_Errors_Detected := 0; 1699 Total_Errors_Detected := 0; 1700 Cur_Msg := No_Error_Msg; 1701 List_Pragmas.Init; 1702 1703 -- Reset counts for warnings 1704 1705 Reset_Warnings; 1706 1707 -- Initialize warnings tables 1708 1709 Warnings.Init; 1710 Specific_Warnings.Init; 1711 end Initialize; 1712 1713 ----------------- 1714 -- No_Warnings -- 1715 ----------------- 1716 1717 function No_Warnings (N : Node_Or_Entity_Id) return Boolean is 1718 begin 1719 if Error_Posted (N) then 1720 return True; 1721 1722 elsif Nkind (N) in N_Entity and then Has_Warnings_Off (N) then 1723 return True; 1724 1725 elsif Is_Entity_Name (N) 1726 and then Present (Entity (N)) 1727 and then Has_Warnings_Off (Entity (N)) 1728 then 1729 return True; 1730 1731 else 1732 return False; 1733 end if; 1734 end No_Warnings; 1735 1736 ------------- 1737 -- OK_Node -- 1738 ------------- 1739 1740 function OK_Node (N : Node_Id) return Boolean is 1741 K : constant Node_Kind := Nkind (N); 1742 1743 begin 1744 if Error_Posted (N) then 1745 return False; 1746 1747 elsif K in N_Has_Etype 1748 and then Present (Etype (N)) 1749 and then Error_Posted (Etype (N)) 1750 then 1751 return False; 1752 1753 elsif (K in N_Op 1754 or else K = N_Attribute_Reference 1755 or else K = N_Character_Literal 1756 or else K = N_Expanded_Name 1757 or else K = N_Identifier 1758 or else K = N_Operator_Symbol) 1759 and then Present (Entity (N)) 1760 and then Error_Posted (Entity (N)) 1761 then 1762 return False; 1763 else 1764 return True; 1765 end if; 1766 end OK_Node; 1767 1768 --------------------- 1769 -- Output_Messages -- 1770 --------------------- 1771 1772 procedure Output_Messages is 1773 E : Error_Msg_Id; 1774 Err_Flag : Boolean; 1775 1776 procedure Write_Error_Summary; 1777 -- Write error summary 1778 1779 procedure Write_Header (Sfile : Source_File_Index); 1780 -- Write header line (compiling or checking given file) 1781 1782 procedure Write_Max_Errors; 1783 -- Write message if max errors reached 1784 1785 ------------------------- 1786 -- Write_Error_Summary -- 1787 ------------------------- 1788 1789 procedure Write_Error_Summary is 1790 begin 1791 -- Extra blank line if error messages or source listing were output 1792 1793 if Total_Errors_Detected + Warnings_Detected > 0 or else Full_List 1794 then 1795 Write_Eol; 1796 end if; 1797 1798 -- Message giving number of lines read and number of errors detected. 1799 -- This normally goes to Standard_Output. The exception is when brief 1800 -- mode is not set, verbose mode (or full list mode) is set, and 1801 -- there are errors. In this case we send the message to standard 1802 -- error to make sure that *something* appears on standard error 1803 -- in an error situation. 1804 1805 if Total_Errors_Detected + Warnings_Detected /= 0 1806 and then not Brief_Output 1807 and then (Verbose_Mode or Full_List) 1808 then 1809 Set_Standard_Error; 1810 end if; 1811 1812 -- Message giving total number of lines. Don't give this message if 1813 -- the Main_Source line is unknown (this happens in error situations, 1814 -- e.g. when integrated preprocessing fails). 1815 1816 if Main_Source_File > No_Source_File then 1817 Write_Str (" "); 1818 Write_Int (Num_Source_Lines (Main_Source_File)); 1819 1820 if Num_Source_Lines (Main_Source_File) = 1 then 1821 Write_Str (" line: "); 1822 else 1823 Write_Str (" lines: "); 1824 end if; 1825 end if; 1826 1827 if Total_Errors_Detected = 0 then 1828 Write_Str ("No errors"); 1829 1830 elsif Total_Errors_Detected = 1 then 1831 Write_Str ("1 error"); 1832 1833 else 1834 Write_Int (Total_Errors_Detected); 1835 Write_Str (" errors"); 1836 end if; 1837 1838 if Warnings_Detected - Warning_Info_Messages /= 0 then 1839 Write_Str (", "); 1840 Write_Int (Warnings_Detected); 1841 Write_Str (" warning"); 1842 1843 if Warnings_Detected - Warning_Info_Messages /= 1 then 1844 Write_Char ('s'); 1845 end if; 1846 1847 if Warning_Mode = Treat_As_Error then 1848 Write_Str (" (treated as error"); 1849 1850 if Warnings_Detected /= 1 then 1851 Write_Char ('s'); 1852 end if; 1853 1854 Write_Char (')'); 1855 1856 elsif Warnings_Treated_As_Errors /= 0 then 1857 Write_Str (" ("); 1858 Write_Int (Warnings_Treated_As_Errors); 1859 Write_Str (" treated as errors)"); 1860 end if; 1861 end if; 1862 1863 if Warning_Info_Messages + Report_Info_Messages /= 0 then 1864 Write_Str (", "); 1865 Write_Int (Warning_Info_Messages + Report_Info_Messages); 1866 Write_Str (" info message"); 1867 1868 if Warning_Info_Messages + Report_Info_Messages > 1 then 1869 Write_Char ('s'); 1870 end if; 1871 end if; 1872 1873 Write_Eol; 1874 Set_Standard_Output; 1875 end Write_Error_Summary; 1876 1877 ------------------ 1878 -- Write_Header -- 1879 ------------------ 1880 1881 procedure Write_Header (Sfile : Source_File_Index) is 1882 begin 1883 if Verbose_Mode or Full_List then 1884 if Original_Operating_Mode = Generate_Code then 1885 Write_Str ("Compiling: "); 1886 else 1887 Write_Str ("Checking: "); 1888 end if; 1889 1890 Write_Name (Full_File_Name (Sfile)); 1891 1892 if not Debug_Flag_7 then 1893 Write_Eol; 1894 Write_Str ("Source file time stamp: "); 1895 Write_Time_Stamp (Sfile); 1896 Write_Eol; 1897 Write_Str ("Compiled at: " & Compilation_Time); 1898 end if; 1899 1900 Write_Eol; 1901 end if; 1902 end Write_Header; 1903 1904 ---------------------- 1905 -- Write_Max_Errors -- 1906 ---------------------- 1907 1908 procedure Write_Max_Errors is 1909 begin 1910 if Maximum_Messages /= 0 then 1911 if Warnings_Detected >= Maximum_Messages then 1912 Set_Standard_Error; 1913 Write_Line ("maximum number of warnings output"); 1914 Write_Line ("any further warnings suppressed"); 1915 Set_Standard_Output; 1916 end if; 1917 1918 -- If too many errors print message 1919 1920 if Total_Errors_Detected >= Maximum_Messages then 1921 Set_Standard_Error; 1922 Write_Line ("fatal error: maximum number of errors detected"); 1923 Set_Standard_Output; 1924 end if; 1925 end if; 1926 end Write_Max_Errors; 1927 1928 -- Start of processing for Output_Messages 1929 1930 begin 1931 -- Error if Finalize has not been called 1932 1933 if not Finalize_Called then 1934 raise Program_Error; 1935 end if; 1936 1937 -- Reset current error source file if the main unit has a pragma 1938 -- Source_Reference. This ensures outputting the proper name of 1939 -- the source file in this situation. 1940 1941 if Main_Source_File <= No_Source_File 1942 or else Num_SRef_Pragmas (Main_Source_File) /= 0 1943 then 1944 Current_Error_Source_File := No_Source_File; 1945 end if; 1946 1947 -- Brief Error mode 1948 1949 if Brief_Output or (not Full_List and not Verbose_Mode) then 1950 Set_Standard_Error; 1951 1952 E := First_Error_Msg; 1953 while E /= No_Error_Msg loop 1954 if not Errors.Table (E).Deleted and then not Debug_Flag_KK then 1955 if Full_Path_Name_For_Brief_Errors then 1956 Write_Name (Full_Ref_Name (Errors.Table (E).Sfile)); 1957 else 1958 Write_Name (Reference_Name (Errors.Table (E).Sfile)); 1959 end if; 1960 1961 Write_Char (':'); 1962 Write_Int (Int (Physical_To_Logical 1963 (Errors.Table (E).Line, 1964 Errors.Table (E).Sfile))); 1965 Write_Char (':'); 1966 1967 if Errors.Table (E).Col < 10 then 1968 Write_Char ('0'); 1969 end if; 1970 1971 Write_Int (Int (Errors.Table (E).Col)); 1972 Write_Str (": "); 1973 Output_Msg_Text (E); 1974 Write_Eol; 1975 end if; 1976 1977 E := Errors.Table (E).Next; 1978 end loop; 1979 1980 Set_Standard_Output; 1981 end if; 1982 1983 -- Full source listing case 1984 1985 if Full_List then 1986 List_Pragmas_Index := 1; 1987 List_Pragmas_Mode := True; 1988 E := First_Error_Msg; 1989 1990 -- Normal case, to stdout (copyright notice already output) 1991 1992 if Full_List_File_Name = null then 1993 if not Debug_Flag_7 then 1994 Write_Eol; 1995 end if; 1996 1997 -- Output to file 1998 1999 else 2000 Create_List_File_Access.all (Full_List_File_Name.all); 2001 Set_Special_Output (Write_List_Info_Access.all'Access); 2002 2003 -- Write copyright notice to file 2004 2005 if not Debug_Flag_7 then 2006 Write_Str ("GNAT "); 2007 Write_Str (Gnat_Version_String); 2008 Write_Eol; 2009 Write_Str ("Copyright 1992-" & 2010 Current_Year & 2011 ", Free Software Foundation, Inc."); 2012 Write_Eol; 2013 end if; 2014 end if; 2015 2016 -- First list extended main source file units with errors 2017 2018 for U in Main_Unit .. Last_Unit loop 2019 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) 2020 2021 -- If debug flag d.m is set, only the main source is listed 2022 2023 and then (U = Main_Unit or else not Debug_Flag_Dot_M) 2024 2025 -- If the unit of the entity does not come from source, it is 2026 -- an implicit subprogram declaration for a child subprogram. 2027 -- Do not emit errors for it, they are listed with the body. 2028 2029 and then 2030 (No (Cunit_Entity (U)) 2031 or else Comes_From_Source (Cunit_Entity (U)) 2032 or else not Is_Subprogram (Cunit_Entity (U))) 2033 2034 -- If the compilation unit associated with this unit does not 2035 -- come from source, it means it is an instantiation that should 2036 -- not be included in the source listing. 2037 2038 and then Comes_From_Source (Cunit (U)) 2039 then 2040 declare 2041 Sfile : constant Source_File_Index := Source_Index (U); 2042 2043 begin 2044 Write_Eol; 2045 2046 -- Only write the header if Sfile is known 2047 2048 if Sfile > No_Source_File then 2049 Write_Header (Sfile); 2050 Write_Eol; 2051 end if; 2052 2053 -- Normally, we don't want an "error messages from file" 2054 -- message when listing the entire file, so we set the 2055 -- current source file as the current error source file. 2056 -- However, the old style of doing things was to list this 2057 -- message if pragma Source_Reference is present, even for 2058 -- the main unit. Since the purpose of the -gnatd.m switch 2059 -- is to duplicate the old behavior, we skip the reset if 2060 -- this debug flag is set. 2061 2062 if not Debug_Flag_Dot_M then 2063 Current_Error_Source_File := Sfile; 2064 end if; 2065 2066 -- Only output the listing if Sfile is known, to avoid 2067 -- crashing the compiler. 2068 2069 if Sfile > No_Source_File then 2070 for N in 1 .. Last_Source_Line (Sfile) loop 2071 while E /= No_Error_Msg 2072 and then Errors.Table (E).Deleted 2073 loop 2074 E := Errors.Table (E).Next; 2075 end loop; 2076 2077 Err_Flag := 2078 E /= No_Error_Msg 2079 and then Errors.Table (E).Line = N 2080 and then Errors.Table (E).Sfile = Sfile; 2081 2082 Output_Source_Line (N, Sfile, Err_Flag); 2083 2084 if Err_Flag then 2085 Output_Error_Msgs (E); 2086 2087 if not Debug_Flag_2 then 2088 Write_Eol; 2089 end if; 2090 end if; 2091 end loop; 2092 end if; 2093 end; 2094 end if; 2095 end loop; 2096 2097 -- Then output errors, if any, for subsidiary units not in the 2098 -- main extended unit. 2099 2100 -- Note: if debug flag d.m set, include errors for any units other 2101 -- than the main unit in the extended source unit (e.g. spec and 2102 -- subunits for a body). 2103 2104 while E /= No_Error_Msg 2105 and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr) 2106 or else 2107 (Debug_Flag_Dot_M 2108 and then Get_Source_Unit 2109 (Errors.Table (E).Sptr) /= Main_Unit)) 2110 loop 2111 if Errors.Table (E).Deleted then 2112 E := Errors.Table (E).Next; 2113 2114 else 2115 Write_Eol; 2116 Output_Source_Line 2117 (Errors.Table (E).Line, Errors.Table (E).Sfile, True); 2118 Output_Error_Msgs (E); 2119 end if; 2120 end loop; 2121 2122 -- If output to file, write extra copy of error summary to the 2123 -- output file, and then close it. 2124 2125 if Full_List_File_Name /= null then 2126 Write_Error_Summary; 2127 Write_Max_Errors; 2128 Close_List_File_Access.all; 2129 Cancel_Special_Output; 2130 end if; 2131 end if; 2132 2133 -- Verbose mode (error lines only with error flags). Normally this is 2134 -- ignored in full list mode, unless we are listing to a file, in which 2135 -- case we still generate -gnatv output to standard output. 2136 2137 if Verbose_Mode 2138 and then (not Full_List or else Full_List_File_Name /= null) 2139 then 2140 Write_Eol; 2141 2142 -- Output the header only when Main_Source_File is known 2143 2144 if Main_Source_File > No_Source_File then 2145 Write_Header (Main_Source_File); 2146 end if; 2147 2148 E := First_Error_Msg; 2149 2150 -- Loop through error lines 2151 2152 while E /= No_Error_Msg loop 2153 if Errors.Table (E).Deleted then 2154 E := Errors.Table (E).Next; 2155 else 2156 Write_Eol; 2157 Output_Source_Line 2158 (Errors.Table (E).Line, Errors.Table (E).Sfile, True); 2159 Output_Error_Msgs (E); 2160 end if; 2161 end loop; 2162 end if; 2163 2164 -- Output error summary if verbose or full list mode 2165 2166 if Verbose_Mode or else Full_List then 2167 Write_Error_Summary; 2168 end if; 2169 2170 Write_Max_Errors; 2171 2172 -- Even though Warning_Info_Messages are a subclass of warnings, they 2173 -- must not be treated as errors when -gnatwe is in effect. 2174 2175 if Warning_Mode = Treat_As_Error then 2176 Total_Errors_Detected := 2177 Total_Errors_Detected + Warnings_Detected - Warning_Info_Messages; 2178 Warnings_Detected := Warning_Info_Messages; 2179 end if; 2180 end Output_Messages; 2181 2182 ------------------------ 2183 -- Output_Source_Line -- 2184 ------------------------ 2185 2186 procedure Output_Source_Line 2187 (L : Physical_Line_Number; 2188 Sfile : Source_File_Index; 2189 Errs : Boolean) 2190 is 2191 S : Source_Ptr; 2192 C : Character; 2193 2194 Line_Number_Output : Boolean := False; 2195 -- Set True once line number is output 2196 2197 Empty_Line : Boolean := True; 2198 -- Set False if line includes at least one character 2199 2200 begin 2201 if Sfile /= Current_Error_Source_File then 2202 Write_Str ("==============Error messages for "); 2203 2204 case Sinput.File_Type (Sfile) is 2205 when Sinput.Src => 2206 Write_Str ("source"); 2207 2208 when Sinput.Config => 2209 Write_Str ("configuration pragmas"); 2210 2211 when Sinput.Def => 2212 Write_Str ("symbol definition"); 2213 2214 when Sinput.Preproc => 2215 Write_Str ("preprocessing data"); 2216 end case; 2217 2218 Write_Str (" file: "); 2219 Write_Name (Full_File_Name (Sfile)); 2220 Write_Eol; 2221 2222 if Num_SRef_Pragmas (Sfile) > 0 then 2223 Write_Str ("--------------Line numbers from file: "); 2224 Write_Name (Full_Ref_Name (Sfile)); 2225 Write_Str (" (starting at line "); 2226 Write_Int (Int (First_Mapped_Line (Sfile))); 2227 Write_Char (')'); 2228 Write_Eol; 2229 end if; 2230 2231 Current_Error_Source_File := Sfile; 2232 end if; 2233 2234 if Errs or List_Pragmas_Mode then 2235 Output_Line_Number (Physical_To_Logical (L, Sfile)); 2236 Line_Number_Output := True; 2237 end if; 2238 2239 S := Line_Start (L, Sfile); 2240 2241 loop 2242 C := Source_Text (Sfile) (S); 2243 exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; 2244 2245 -- Deal with matching entry in List_Pragmas table 2246 2247 if Full_List 2248 and then List_Pragmas_Index <= List_Pragmas.Last 2249 and then S = List_Pragmas.Table (List_Pragmas_Index).Ploc 2250 then 2251 case List_Pragmas.Table (List_Pragmas_Index).Ptyp is 2252 when Page => 2253 Write_Char (C); 2254 2255 -- Ignore if on line with errors so that error flags 2256 -- get properly listed with the error line . 2257 2258 if not Errs then 2259 Write_Char (ASCII.FF); 2260 end if; 2261 2262 when List_On => 2263 List_Pragmas_Mode := True; 2264 2265 if not Line_Number_Output then 2266 Output_Line_Number (Physical_To_Logical (L, Sfile)); 2267 Line_Number_Output := True; 2268 end if; 2269 2270 Write_Char (C); 2271 2272 when List_Off => 2273 Write_Char (C); 2274 List_Pragmas_Mode := False; 2275 end case; 2276 2277 List_Pragmas_Index := List_Pragmas_Index + 1; 2278 2279 -- Normal case (no matching entry in List_Pragmas table) 2280 2281 else 2282 if Errs or List_Pragmas_Mode then 2283 Write_Char (C); 2284 end if; 2285 end if; 2286 2287 Empty_Line := False; 2288 S := S + 1; 2289 end loop; 2290 2291 -- If we have output a source line, then add the line terminator, with 2292 -- training spaces preserved (so we output the line exactly as input). 2293 2294 if Line_Number_Output then 2295 if Empty_Line then 2296 Write_Eol; 2297 else 2298 Write_Eol_Keep_Blanks; 2299 end if; 2300 end if; 2301 end Output_Source_Line; 2302 2303 ----------------------------- 2304 -- Remove_Warning_Messages -- 2305 ----------------------------- 2306 2307 procedure Remove_Warning_Messages (N : Node_Id) is 2308 2309 function Check_For_Warning (N : Node_Id) return Traverse_Result; 2310 -- This function checks one node for a possible warning message 2311 2312 function Check_All_Warnings is new Traverse_Func (Check_For_Warning); 2313 -- This defines the traversal operation 2314 2315 ----------------------- 2316 -- Check_For_Warning -- 2317 ----------------------- 2318 2319 function Check_For_Warning (N : Node_Id) return Traverse_Result is 2320 Loc : constant Source_Ptr := Sloc (N); 2321 E : Error_Msg_Id; 2322 2323 function To_Be_Removed (E : Error_Msg_Id) return Boolean; 2324 -- Returns True for a message that is to be removed. Also adjusts 2325 -- warning count appropriately. 2326 2327 ------------------- 2328 -- To_Be_Removed -- 2329 ------------------- 2330 2331 function To_Be_Removed (E : Error_Msg_Id) return Boolean is 2332 begin 2333 if E /= No_Error_Msg 2334 2335 -- Don't remove if location does not match 2336 2337 and then Errors.Table (E).Optr = Loc 2338 2339 -- Don't remove if not warning/info message. Note that we do 2340 -- not remove style messages here. They are warning messages 2341 -- but not ones we want removed in this context. 2342 2343 and then Errors.Table (E).Warn 2344 2345 -- Don't remove unconditional messages 2346 2347 and then not Errors.Table (E).Uncond 2348 then 2349 Warnings_Detected := Warnings_Detected - 1; 2350 2351 if Errors.Table (E).Info then 2352 Warning_Info_Messages := Warning_Info_Messages - 1; 2353 end if; 2354 2355 return True; 2356 2357 -- No removal required 2358 2359 else 2360 return False; 2361 end if; 2362 end To_Be_Removed; 2363 2364 -- Start of processing for Check_For_Warnings 2365 2366 begin 2367 while To_Be_Removed (First_Error_Msg) loop 2368 First_Error_Msg := Errors.Table (First_Error_Msg).Next; 2369 end loop; 2370 2371 if First_Error_Msg = No_Error_Msg then 2372 Last_Error_Msg := No_Error_Msg; 2373 end if; 2374 2375 E := First_Error_Msg; 2376 while E /= No_Error_Msg loop 2377 while To_Be_Removed (Errors.Table (E).Next) loop 2378 Errors.Table (E).Next := 2379 Errors.Table (Errors.Table (E).Next).Next; 2380 2381 if Errors.Table (E).Next = No_Error_Msg then 2382 Last_Error_Msg := E; 2383 end if; 2384 end loop; 2385 2386 E := Errors.Table (E).Next; 2387 end loop; 2388 2389 if Nkind (N) = N_Raise_Constraint_Error 2390 and then Is_Rewrite_Substitution (N) 2391 and then No (Condition (N)) 2392 then 2393 -- Warnings may have been posted on subexpressions of the original 2394 -- tree. We place the original node back on the tree to remove 2395 -- those warnings, whose sloc do not match those of any node in 2396 -- the current tree. Given that we are in unreachable code, this 2397 -- modification to the tree is harmless. 2398 2399 declare 2400 Status : Traverse_Final_Result; 2401 2402 begin 2403 if Is_List_Member (N) then 2404 Set_Condition (N, Original_Node (N)); 2405 Status := Check_All_Warnings (Condition (N)); 2406 else 2407 Rewrite (N, Original_Node (N)); 2408 Status := Check_All_Warnings (N); 2409 end if; 2410 2411 return Status; 2412 end; 2413 2414 else 2415 return OK; 2416 end if; 2417 end Check_For_Warning; 2418 2419 -- Start of processing for Remove_Warning_Messages 2420 2421 begin 2422 if Warnings_Detected /= 0 then 2423 declare 2424 Discard : Traverse_Final_Result; 2425 pragma Warnings (Off, Discard); 2426 2427 begin 2428 Discard := Check_All_Warnings (N); 2429 end; 2430 end if; 2431 end Remove_Warning_Messages; 2432 2433 procedure Remove_Warning_Messages (L : List_Id) is 2434 Stat : Node_Id; 2435 begin 2436 if Is_Non_Empty_List (L) then 2437 Stat := First (L); 2438 while Present (Stat) loop 2439 Remove_Warning_Messages (Stat); 2440 Next (Stat); 2441 end loop; 2442 end if; 2443 end Remove_Warning_Messages; 2444 2445 -------------------- 2446 -- Reset_Warnings -- 2447 -------------------- 2448 2449 procedure Reset_Warnings is 2450 begin 2451 Warnings_Treated_As_Errors := 0; 2452 Warnings_Detected := 0; 2453 Warning_Info_Messages := 0; 2454 Warnings_As_Errors_Count := 0; 2455 end Reset_Warnings; 2456 2457 ---------------------- 2458 -- Adjust_Name_Case -- 2459 ---------------------- 2460 2461 procedure Adjust_Name_Case 2462 (Buf : in out Bounded_String; 2463 Loc : Source_Ptr) 2464 is 2465 begin 2466 -- We have an all lower case name from Namet, and now we want to set 2467 -- the appropriate case. If possible we copy the actual casing from 2468 -- the source. If not we use standard identifier casing. 2469 2470 declare 2471 Src_Ind : constant Source_File_Index := Get_Source_File_Index (Loc); 2472 Sbuffer : Source_Buffer_Ptr; 2473 Ref_Ptr : Integer; 2474 Src_Ptr : Source_Ptr; 2475 2476 begin 2477 Ref_Ptr := 1; 2478 Src_Ptr := Loc; 2479 2480 -- For standard locations, always use mixed case 2481 2482 if Loc <= No_Location then 2483 Set_Casing (Mixed_Case); 2484 2485 else 2486 -- Determine if the reference we are dealing with corresponds to 2487 -- text at the point of the error reference. This will often be 2488 -- the case for simple identifier references, and is the case 2489 -- where we can copy the casing from the source. 2490 2491 Sbuffer := Source_Text (Src_Ind); 2492 2493 while Ref_Ptr <= Buf.Length loop 2494 exit when 2495 Fold_Lower (Sbuffer (Src_Ptr)) /= 2496 Fold_Lower (Buf.Chars (Ref_Ptr)); 2497 Ref_Ptr := Ref_Ptr + 1; 2498 Src_Ptr := Src_Ptr + 1; 2499 end loop; 2500 2501 -- If we get through the loop without a mismatch, then output the 2502 -- name the way it is cased in the source program 2503 2504 if Ref_Ptr > Buf.Length then 2505 Src_Ptr := Loc; 2506 2507 for J in 1 .. Buf.Length loop 2508 Buf.Chars (J) := Sbuffer (Src_Ptr); 2509 Src_Ptr := Src_Ptr + 1; 2510 end loop; 2511 2512 -- Otherwise set the casing using the default identifier casing 2513 2514 else 2515 Set_Casing (Buf, Identifier_Casing (Src_Ind)); 2516 end if; 2517 end if; 2518 end; 2519 end Adjust_Name_Case; 2520 2521 procedure Adjust_Name_Case (Loc : Source_Ptr) is 2522 begin 2523 Adjust_Name_Case (Global_Name_Buffer, Loc); 2524 end Adjust_Name_Case; 2525 2526 --------------------------- 2527 -- Set_Identifier_Casing -- 2528 --------------------------- 2529 2530 procedure Set_Identifier_Casing 2531 (Identifier_Name : System.Address; 2532 File_Name : System.Address) 2533 is 2534 Ident : constant Big_String_Ptr := To_Big_String_Ptr (Identifier_Name); 2535 File : constant Big_String_Ptr := To_Big_String_Ptr (File_Name); 2536 Flen : Natural; 2537 2538 Desired_Case : Casing_Type := Mixed_Case; 2539 -- Casing required for result. Default value of Mixed_Case is used if 2540 -- for some reason we cannot find the right file name in the table. 2541 2542 begin 2543 -- Get length of file name 2544 2545 Flen := 0; 2546 while File (Flen + 1) /= ASCII.NUL loop 2547 Flen := Flen + 1; 2548 end loop; 2549 2550 -- Loop through file names to find matching one. This is a bit slow, but 2551 -- we only do it in error situations so it is not so terrible. Note that 2552 -- if the loop does not exit, then the desired case will be left set to 2553 -- Mixed_Case, this can happen if the name was not in canonical form. 2554 2555 for J in 1 .. Last_Source_File loop 2556 Get_Name_String (Full_Debug_Name (J)); 2557 2558 if Name_Len = Flen 2559 and then Name_Buffer (1 .. Name_Len) = String (File (1 .. Flen)) 2560 then 2561 Desired_Case := Identifier_Casing (J); 2562 exit; 2563 end if; 2564 end loop; 2565 2566 -- Copy identifier as given to Name_Buffer 2567 2568 for J in Name_Buffer'Range loop 2569 Name_Buffer (J) := Ident (J); 2570 2571 if Name_Buffer (J) = ASCII.NUL then 2572 Name_Len := J - 1; 2573 exit; 2574 end if; 2575 end loop; 2576 2577 Set_Casing (Desired_Case); 2578 end Set_Identifier_Casing; 2579 2580 ----------------------- 2581 -- Set_Ignore_Errors -- 2582 ----------------------- 2583 2584 procedure Set_Ignore_Errors (To : Boolean) is 2585 begin 2586 Errors_Must_Be_Ignored := To; 2587 end Set_Ignore_Errors; 2588 2589 ------------------------------ 2590 -- Set_Msg_Insertion_Column -- 2591 ------------------------------ 2592 2593 procedure Set_Msg_Insertion_Column is 2594 begin 2595 if RM_Column_Check then 2596 Set_Msg_Str (" in column "); 2597 Set_Msg_Int (Int (Error_Msg_Col) + 1); 2598 end if; 2599 end Set_Msg_Insertion_Column; 2600 2601 ---------------------------- 2602 -- Set_Msg_Insertion_Node -- 2603 ---------------------------- 2604 2605 procedure Set_Msg_Insertion_Node is 2606 K : Node_Kind; 2607 2608 begin 2609 Suppress_Message := 2610 Error_Msg_Node_1 = Error 2611 or else Error_Msg_Node_1 = Any_Type; 2612 2613 if Error_Msg_Node_1 = Empty then 2614 Set_Msg_Blank_Conditional; 2615 Set_Msg_Str ("<empty>"); 2616 2617 elsif Error_Msg_Node_1 = Error then 2618 Set_Msg_Blank; 2619 Set_Msg_Str ("<error>"); 2620 2621 elsif Error_Msg_Node_1 = Standard_Void_Type then 2622 Set_Msg_Blank; 2623 Set_Msg_Str ("procedure name"); 2624 2625 elsif Nkind (Error_Msg_Node_1) in N_Entity 2626 and then Ekind (Error_Msg_Node_1) = E_Anonymous_Access_Subprogram_Type 2627 then 2628 Set_Msg_Blank; 2629 Set_Msg_Str ("access to subprogram"); 2630 2631 else 2632 Set_Msg_Blank_Conditional; 2633 2634 -- Output name 2635 2636 K := Nkind (Error_Msg_Node_1); 2637 2638 -- If we have operator case, skip quotes since name of operator 2639 -- itself will supply the required quotations. An operator can be an 2640 -- applied use in an expression or an explicit operator symbol, or an 2641 -- identifier whose name indicates it is an operator. 2642 2643 if K in N_Op 2644 or else K = N_Operator_Symbol 2645 or else K = N_Defining_Operator_Symbol 2646 or else ((K = N_Identifier or else K = N_Defining_Identifier) 2647 and then Is_Operator_Name (Chars (Error_Msg_Node_1))) 2648 then 2649 Set_Msg_Node (Error_Msg_Node_1); 2650 2651 -- Normal case, not an operator, surround with quotes 2652 2653 else 2654 Set_Msg_Quote; 2655 Set_Qualification (Error_Msg_Qual_Level, Error_Msg_Node_1); 2656 Set_Msg_Node (Error_Msg_Node_1); 2657 Set_Msg_Quote; 2658 end if; 2659 end if; 2660 2661 -- The following assignment ensures that a second ampersand insertion 2662 -- character will correspond to the Error_Msg_Node_2 parameter. We 2663 -- suppress possible validity checks in case operating in -gnatVa mode, 2664 -- and Error_Msg_Node_2 is not needed and has not been set. 2665 2666 declare 2667 pragma Suppress (Range_Check); 2668 begin 2669 Error_Msg_Node_1 := Error_Msg_Node_2; 2670 end; 2671 end Set_Msg_Insertion_Node; 2672 2673 -------------------------------------- 2674 -- Set_Msg_Insertion_Type_Reference -- 2675 -------------------------------------- 2676 2677 procedure Set_Msg_Insertion_Type_Reference (Flag : Source_Ptr) is 2678 Ent : Entity_Id; 2679 2680 begin 2681 Set_Msg_Blank; 2682 2683 if Error_Msg_Node_1 = Standard_Void_Type then 2684 Set_Msg_Str ("package or procedure name"); 2685 return; 2686 2687 elsif Error_Msg_Node_1 = Standard_Exception_Type then 2688 Set_Msg_Str ("exception name"); 2689 return; 2690 2691 elsif Error_Msg_Node_1 = Any_Access 2692 or else Error_Msg_Node_1 = Any_Array 2693 or else Error_Msg_Node_1 = Any_Boolean 2694 or else Error_Msg_Node_1 = Any_Character 2695 or else Error_Msg_Node_1 = Any_Composite 2696 or else Error_Msg_Node_1 = Any_Discrete 2697 or else Error_Msg_Node_1 = Any_Fixed 2698 or else Error_Msg_Node_1 = Any_Integer 2699 or else Error_Msg_Node_1 = Any_Modular 2700 or else Error_Msg_Node_1 = Any_Numeric 2701 or else Error_Msg_Node_1 = Any_Real 2702 or else Error_Msg_Node_1 = Any_Scalar 2703 or else Error_Msg_Node_1 = Any_String 2704 then 2705 Get_Unqualified_Decoded_Name_String (Chars (Error_Msg_Node_1)); 2706 Set_Msg_Name_Buffer; 2707 return; 2708 2709 elsif Error_Msg_Node_1 = Universal_Real then 2710 Set_Msg_Str ("type universal real"); 2711 return; 2712 2713 elsif Error_Msg_Node_1 = Universal_Integer then 2714 Set_Msg_Str ("type universal integer"); 2715 return; 2716 2717 elsif Error_Msg_Node_1 = Universal_Fixed then 2718 Set_Msg_Str ("type universal fixed"); 2719 return; 2720 end if; 2721 2722 -- Special case of anonymous array 2723 2724 if Nkind (Error_Msg_Node_1) in N_Entity 2725 and then Is_Array_Type (Error_Msg_Node_1) 2726 and then Present (Related_Array_Object (Error_Msg_Node_1)) 2727 then 2728 Set_Msg_Str ("type of "); 2729 Set_Msg_Node (Related_Array_Object (Error_Msg_Node_1)); 2730 Set_Msg_Str (" declared"); 2731 Set_Msg_Insertion_Line_Number 2732 (Sloc (Related_Array_Object (Error_Msg_Node_1)), Flag); 2733 return; 2734 end if; 2735 2736 -- If we fall through, it is not a special case, so first output 2737 -- the name of the type, preceded by private for a private type 2738 2739 if Is_Private_Type (Error_Msg_Node_1) then 2740 Set_Msg_Str ("private type "); 2741 else 2742 Set_Msg_Str ("type "); 2743 end if; 2744 2745 Ent := Error_Msg_Node_1; 2746 2747 if Is_Internal_Name (Chars (Ent)) then 2748 Unwind_Internal_Type (Ent); 2749 end if; 2750 2751 -- Types in Standard are displayed as "Standard.name" 2752 2753 if Sloc (Ent) <= Standard_Location then 2754 Set_Msg_Quote; 2755 Set_Msg_Str ("Standard."); 2756 Set_Msg_Node (Ent); 2757 Add_Class; 2758 Set_Msg_Quote; 2759 2760 -- Types in other language defined units are displayed as 2761 -- "package-name.type-name" 2762 2763 elsif Is_Predefined_Unit (Get_Source_Unit (Ent)) then 2764 Get_Unqualified_Decoded_Name_String 2765 (Unit_Name (Get_Source_Unit (Ent))); 2766 Name_Len := Name_Len - 2; 2767 Set_Msg_Blank_Conditional; 2768 Set_Msg_Quote; 2769 Set_Casing (Mixed_Case); 2770 Set_Msg_Name_Buffer; 2771 Set_Msg_Char ('.'); 2772 Set_Casing (Mixed_Case); 2773 Set_Msg_Node (Ent); 2774 Add_Class; 2775 Set_Msg_Quote; 2776 2777 -- All other types display as "type name" defined at line xxx 2778 -- possibly qualified if qualification is requested. 2779 2780 else 2781 Set_Msg_Quote; 2782 Set_Qualification (Error_Msg_Qual_Level, Ent); 2783 Set_Msg_Node (Ent); 2784 Add_Class; 2785 2786 -- If we did not print a name (e.g. in the case of an anonymous 2787 -- subprogram type), there is no name to print, so remove quotes. 2788 2789 if Buffer_Ends_With ('"') then 2790 Buffer_Remove ('"'); 2791 else 2792 Set_Msg_Quote; 2793 end if; 2794 end if; 2795 2796 -- If the original type did not come from a predefined file, add the 2797 -- location where the type was defined. 2798 2799 if Sloc (Error_Msg_Node_1) > Standard_Location 2800 and then 2801 not Is_Predefined_Unit (Get_Source_Unit (Error_Msg_Node_1)) 2802 then 2803 Get_Name_String (Unit_File_Name (Get_Source_Unit (Error_Msg_Node_1))); 2804 Set_Msg_Str (" defined"); 2805 Set_Msg_Insertion_Line_Number (Sloc (Error_Msg_Node_1), Flag); 2806 2807 -- If it did come from a predefined file, deal with the case where 2808 -- this was a file with a generic instantiation from elsewhere. 2809 2810 else 2811 if Sloc (Error_Msg_Node_1) > Standard_Location then 2812 declare 2813 Iloc : constant Source_Ptr := 2814 Instantiation_Location (Sloc (Error_Msg_Node_1)); 2815 2816 begin 2817 if Iloc /= No_Location 2818 and then not Suppress_Instance_Location 2819 then 2820 Set_Msg_Str (" from instance"); 2821 Set_Msg_Insertion_Line_Number (Iloc, Flag); 2822 end if; 2823 end; 2824 end if; 2825 end if; 2826 end Set_Msg_Insertion_Type_Reference; 2827 2828 --------------------------------- 2829 -- Set_Msg_Insertion_Unit_Name -- 2830 --------------------------------- 2831 2832 procedure Set_Msg_Insertion_Unit_Name (Suffix : Boolean := True) is 2833 begin 2834 if Error_Msg_Unit_1 = No_Unit_Name then 2835 null; 2836 2837 elsif Error_Msg_Unit_1 = Error_Unit_Name then 2838 Set_Msg_Blank; 2839 Set_Msg_Str ("<error>"); 2840 2841 else 2842 Get_Unit_Name_String (Error_Msg_Unit_1, Suffix); 2843 Set_Msg_Blank; 2844 Set_Msg_Quote; 2845 Set_Msg_Name_Buffer; 2846 Set_Msg_Quote; 2847 end if; 2848 2849 -- The following assignment ensures that a second percent insertion 2850 -- character will correspond to the Error_Msg_Unit_2 parameter. We 2851 -- suppress possible validity checks in case operating in -gnatVa mode, 2852 -- and Error_Msg_Unit_2 is not needed and has not been set. 2853 2854 declare 2855 pragma Suppress (Range_Check); 2856 begin 2857 Error_Msg_Unit_1 := Error_Msg_Unit_2; 2858 end; 2859 end Set_Msg_Insertion_Unit_Name; 2860 2861 ------------------ 2862 -- Set_Msg_Node -- 2863 ------------------ 2864 2865 procedure Set_Msg_Node (Node : Node_Id) is 2866 Loc : Source_Ptr; 2867 Ent : Entity_Id; 2868 Nam : Name_Id; 2869 2870 begin 2871 case Nkind (Node) is 2872 when N_Designator => 2873 Set_Msg_Node (Name (Node)); 2874 Set_Msg_Char ('.'); 2875 Set_Msg_Node (Identifier (Node)); 2876 return; 2877 2878 when N_Defining_Program_Unit_Name => 2879 Set_Msg_Node (Name (Node)); 2880 Set_Msg_Char ('.'); 2881 Set_Msg_Node (Defining_Identifier (Node)); 2882 return; 2883 2884 when N_Expanded_Name 2885 | N_Selected_Component 2886 => 2887 Set_Msg_Node (Prefix (Node)); 2888 Set_Msg_Char ('.'); 2889 Set_Msg_Node (Selector_Name (Node)); 2890 return; 2891 2892 when others => 2893 null; 2894 end case; 2895 2896 -- The only remaining possibilities are identifiers, defining 2897 -- identifiers, pragmas, and pragma argument associations. 2898 2899 if Nkind (Node) = N_Pragma then 2900 Nam := Pragma_Name (Node); 2901 Loc := Sloc (Node); 2902 2903 -- The other cases have Chars fields 2904 2905 -- First deal with internal names, which generally represent something 2906 -- gone wrong. First attempt: if this is a rewritten node that rewrites 2907 -- something with a Chars field that is not an internal name, use that. 2908 2909 elsif Is_Internal_Name (Chars (Node)) 2910 and then Nkind (Original_Node (Node)) in N_Has_Chars 2911 and then not Is_Internal_Name (Chars (Original_Node (Node))) 2912 then 2913 Nam := Chars (Original_Node (Node)); 2914 Loc := Sloc (Original_Node (Node)); 2915 2916 -- Another shot for internal names, in the case of internal type names, 2917 -- we try to find a reasonable representation for the external name. 2918 2919 elsif Is_Internal_Name (Chars (Node)) 2920 and then 2921 ((Is_Entity_Name (Node) 2922 and then Present (Entity (Node)) 2923 and then Is_Type (Entity (Node))) 2924 or else 2925 (Nkind (Node) = N_Defining_Identifier and then Is_Type (Node))) 2926 then 2927 if Nkind (Node) = N_Identifier then 2928 Ent := Entity (Node); 2929 else 2930 Ent := Node; 2931 end if; 2932 2933 Loc := Sloc (Ent); 2934 2935 -- If the type is the designated type of an access_to_subprogram, 2936 -- then there is no name to provide in the call. 2937 2938 if Ekind (Ent) = E_Subprogram_Type then 2939 return; 2940 2941 -- Otherwise, we will be able to find some kind of name to output 2942 2943 else 2944 Unwind_Internal_Type (Ent); 2945 Nam := Chars (Ent); 2946 end if; 2947 2948 -- If not internal name, or if we could not find a reasonable possible 2949 -- substitution for the internal name, just use name in Chars field. 2950 2951 else 2952 Nam := Chars (Node); 2953 Loc := Sloc (Node); 2954 end if; 2955 2956 -- At this stage, the name to output is in Nam 2957 2958 Get_Unqualified_Decoded_Name_String (Nam); 2959 2960 -- Remove trailing upper case letters from the name (useful for 2961 -- dealing with some cases of internal names). 2962 2963 while Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' loop 2964 Name_Len := Name_Len - 1; 2965 end loop; 2966 2967 -- If we have any of the names from standard that start with the 2968 -- characters "any " (e.g. Any_Type), then kill the message since 2969 -- almost certainly it is a junk cascaded message. 2970 2971 if Name_Len > 4 2972 and then Name_Buffer (1 .. 4) = "any " 2973 then 2974 Kill_Message := True; 2975 end if; 2976 2977 -- If we still have an internal name, kill the message (will only 2978 -- work if we already had errors!) 2979 2980 if Is_Internal_Name then 2981 Kill_Message := True; 2982 end if; 2983 -- Remaining step is to adjust casing and possibly add 'Class 2984 2985 Adjust_Name_Case (Global_Name_Buffer, Loc); 2986 Set_Msg_Name_Buffer; 2987 Add_Class; 2988 end Set_Msg_Node; 2989 2990 ------------------ 2991 -- Set_Msg_Text -- 2992 ------------------ 2993 2994 procedure Set_Msg_Text (Text : String; Flag : Source_Ptr) is 2995 C : Character; -- Current character 2996 P : Natural; -- Current index; 2997 2998 procedure Skip_Msg_Insertion_Warning (C : Character); 2999 -- Deal with ? ?? ?x? ?X? ?*? ?$? insertion sequences (and the same 3000 -- sequences using < instead of ?). The caller has already bumped 3001 -- the pointer past the initial ? or < and C is set to this initial 3002 -- character (? or <). This procedure skips past the rest of the 3003 -- sequence. We do not need to set Msg_Insertion_Char, since this 3004 -- was already done during the message prescan. 3005 3006 -------------------------------- 3007 -- Skip_Msg_Insertion_Warning -- 3008 -------------------------------- 3009 3010 procedure Skip_Msg_Insertion_Warning (C : Character) is 3011 begin 3012 if P <= Text'Last and then Text (P) = C then 3013 P := P + 1; 3014 3015 elsif P + 1 <= Text'Last 3016 and then (Text (P) in 'a' .. 'z' 3017 or else 3018 Text (P) in 'A' .. 'Z' 3019 or else 3020 Text (P) = '*' 3021 or else 3022 Text (P) = '$') 3023 and then Text (P + 1) = C 3024 then 3025 P := P + 2; 3026 end if; 3027 end Skip_Msg_Insertion_Warning; 3028 3029 -- Start of processing for Set_Msg_Text 3030 3031 begin 3032 Manual_Quote_Mode := False; 3033 Msglen := 0; 3034 Flag_Source := Get_Source_File_Index (Flag); 3035 3036 -- Skip info: at start, we have recorded this in Is_Info_Msg, and this 3037 -- will be used (Info field in error message object) to put back the 3038 -- string when it is printed. We need to do this, or we get confused 3039 -- with instantiation continuations. 3040 3041 if Text'Length > 6 3042 and then Text (Text'First .. Text'First + 5) = "info: " 3043 then 3044 P := Text'First + 6; 3045 else 3046 P := Text'First; 3047 end if; 3048 3049 -- Loop through characters of message 3050 3051 while P <= Text'Last loop 3052 C := Text (P); 3053 P := P + 1; 3054 3055 -- Check for insertion character or sequence 3056 3057 case C is 3058 when '%' => 3059 if P <= Text'Last and then Text (P) = '%' then 3060 P := P + 1; 3061 Set_Msg_Insertion_Name_Literal; 3062 else 3063 Set_Msg_Insertion_Name; 3064 end if; 3065 3066 when '$' => 3067 if P <= Text'Last and then Text (P) = '$' then 3068 P := P + 1; 3069 Set_Msg_Insertion_Unit_Name (Suffix => False); 3070 else 3071 Set_Msg_Insertion_Unit_Name; 3072 end if; 3073 3074 when '{' => 3075 Set_Msg_Insertion_File_Name; 3076 3077 when '}' => 3078 Set_Msg_Insertion_Type_Reference (Flag); 3079 3080 when '*' => 3081 Set_Msg_Insertion_Reserved_Name; 3082 3083 when '&' => 3084 Set_Msg_Insertion_Node; 3085 3086 when '#' => 3087 Set_Msg_Insertion_Line_Number (Error_Msg_Sloc, Flag); 3088 3089 when '\' => 3090 Continuation := True; 3091 3092 if P <= Text'Last and then Text (P) = '\' then 3093 Continuation_New_Line := True; 3094 P := P + 1; 3095 end if; 3096 3097 when '@' => 3098 Set_Msg_Insertion_Column; 3099 3100 when '>' => 3101 Set_Msg_Insertion_Run_Time_Name; 3102 3103 when '^' => 3104 Set_Msg_Insertion_Uint; 3105 3106 when '`' => 3107 Manual_Quote_Mode := not Manual_Quote_Mode; 3108 Set_Msg_Char ('"'); 3109 3110 when '!' => 3111 null; -- already dealt with 3112 3113 when '?' => 3114 Skip_Msg_Insertion_Warning ('?'); 3115 3116 when '<' => 3117 Skip_Msg_Insertion_Warning ('<'); 3118 3119 when '|' => 3120 null; -- already dealt with 3121 3122 when ''' => 3123 Set_Msg_Char (Text (P)); 3124 P := P + 1; 3125 3126 when '~' => 3127 Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen)); 3128 3129 -- Upper case letter 3130 3131 when 'A' .. 'Z' => 3132 3133 -- Start of reserved word if two or more 3134 3135 if P <= Text'Last and then Text (P) in 'A' .. 'Z' then 3136 P := P - 1; 3137 Set_Msg_Insertion_Reserved_Word (Text, P); 3138 3139 -- Single upper case letter is just inserted 3140 3141 else 3142 Set_Msg_Char (C); 3143 end if; 3144 3145 -- '[' (will be/would have been raised at run time) 3146 3147 when '[' => 3148 3149 -- Switch the message from a warning to an error if the flag 3150 -- -gnatwE is specified to treat run-time exception warnings 3151 -- as errors. 3152 3153 if Is_Warning_Msg 3154 and then Warning_Mode = Treat_Run_Time_Warnings_As_Errors 3155 then 3156 Is_Warning_Msg := False; 3157 end if; 3158 3159 if Is_Warning_Msg then 3160 Set_Msg_Str ("will be raised at run time"); 3161 else 3162 Set_Msg_Str ("would have been raised at run time"); 3163 end if; 3164 3165 -- ']' (may be/might have been raised at run time) 3166 3167 when ']' => 3168 if Is_Warning_Msg then 3169 Set_Msg_Str ("may be raised at run time"); 3170 else 3171 Set_Msg_Str ("might have been raised at run time"); 3172 end if; 3173 3174 -- Normal character with no special treatment 3175 3176 when others => 3177 Set_Msg_Char (C); 3178 end case; 3179 end loop; 3180 end Set_Msg_Text; 3181 3182 ---------------- 3183 -- Set_Posted -- 3184 ---------------- 3185 3186 procedure Set_Posted (N : Node_Id) is 3187 P : Node_Id; 3188 3189 begin 3190 if Is_Serious_Error then 3191 3192 -- We always set Error_Posted on the node itself 3193 3194 Set_Error_Posted (N); 3195 3196 -- If it is a subexpression, then set Error_Posted on parents up to 3197 -- and including the first non-subexpression construct. This helps 3198 -- avoid cascaded error messages within a single expression. 3199 3200 P := N; 3201 loop 3202 P := Parent (P); 3203 exit when No (P); 3204 Set_Error_Posted (P); 3205 exit when Nkind (P) not in N_Subexpr; 3206 end loop; 3207 3208 if Nkind_In (P, N_Pragma_Argument_Association, 3209 N_Component_Association, 3210 N_Discriminant_Association, 3211 N_Generic_Association, 3212 N_Parameter_Association) 3213 then 3214 Set_Error_Posted (Parent (P)); 3215 end if; 3216 3217 -- A special check, if we just posted an error on an attribute 3218 -- definition clause, then also set the entity involved as posted. 3219 -- For example, this stops complaining about the alignment after 3220 -- complaining about the size, which is likely to be useless. 3221 3222 if Nkind (P) = N_Attribute_Definition_Clause then 3223 if Is_Entity_Name (Name (P)) then 3224 Set_Error_Posted (Entity (Name (P))); 3225 end if; 3226 end if; 3227 end if; 3228 end Set_Posted; 3229 3230 ----------------------- 3231 -- Set_Qualification -- 3232 ----------------------- 3233 3234 procedure Set_Qualification (N : Nat; E : Entity_Id) is 3235 begin 3236 if N /= 0 and then Scope (E) /= Standard_Standard then 3237 Set_Qualification (N - 1, Scope (E)); 3238 Set_Msg_Node (Scope (E)); 3239 Set_Msg_Char ('.'); 3240 end if; 3241 end Set_Qualification; 3242 3243 ------------------------ 3244 -- Special_Msg_Delete -- 3245 ------------------------ 3246 3247 -- Is it really right to have all this specialized knowledge in errout? 3248 3249 function Special_Msg_Delete 3250 (Msg : String; 3251 N : Node_Or_Entity_Id; 3252 E : Node_Or_Entity_Id) return Boolean 3253 is 3254 begin 3255 -- Never delete messages in -gnatdO mode 3256 3257 if Debug_Flag_OO then 3258 return False; 3259 3260 -- Processing for "Size too small" messages 3261 3262 elsif Msg = "size for& too small, minimum allowed is ^" then 3263 3264 -- Suppress "size too small" errors in CodePeer mode, since code may 3265 -- be analyzed in a different configuration than the one used for 3266 -- compilation. Even when the configurations match, this message 3267 -- may be issued on correct code, because pragma Pack is ignored 3268 -- in CodePeer mode. 3269 3270 if CodePeer_Mode then 3271 return True; 3272 3273 -- When a size is wrong for a frozen type there is no explicit size 3274 -- clause, and other errors have occurred, suppress the message, 3275 -- since it is likely that this size error is a cascaded result of 3276 -- other errors. The reason we eliminate unfrozen types is that 3277 -- messages issued before the freeze type are for sure OK. 3278 3279 elsif Is_Frozen (E) 3280 and then Serious_Errors_Detected > 0 3281 and then Nkind (N) /= N_Component_Clause 3282 and then Nkind (Parent (N)) /= N_Component_Clause 3283 and then 3284 No (Get_Attribute_Definition_Clause (E, Attribute_Size)) 3285 and then 3286 No (Get_Attribute_Definition_Clause (E, Attribute_Object_Size)) 3287 and then 3288 No (Get_Attribute_Definition_Clause (E, Attribute_Value_Size)) 3289 then 3290 return True; 3291 end if; 3292 end if; 3293 3294 -- All special tests complete, so go ahead with message 3295 3296 return False; 3297 end Special_Msg_Delete; 3298 3299 ----------------- 3300 -- SPARK_Msg_N -- 3301 ----------------- 3302 3303 procedure SPARK_Msg_N (Msg : String; N : Node_Or_Entity_Id) is 3304 begin 3305 if SPARK_Mode /= Off then 3306 Error_Msg_N (Msg, N); 3307 end if; 3308 end SPARK_Msg_N; 3309 3310 ------------------ 3311 -- SPARK_Msg_NE -- 3312 ------------------ 3313 3314 procedure SPARK_Msg_NE 3315 (Msg : String; 3316 N : Node_Or_Entity_Id; 3317 E : Node_Or_Entity_Id) 3318 is 3319 begin 3320 if SPARK_Mode /= Off then 3321 Error_Msg_NE (Msg, N, E); 3322 end if; 3323 end SPARK_Msg_NE; 3324 3325 -------------------------- 3326 -- Unwind_Internal_Type -- 3327 -------------------------- 3328 3329 procedure Unwind_Internal_Type (Ent : in out Entity_Id) is 3330 Derived : Boolean := False; 3331 Mchar : Character; 3332 Old_Ent : Entity_Id; 3333 3334 begin 3335 -- Undo placement of a quote, since we will put it back later 3336 3337 Mchar := Msg_Buffer (Msglen); 3338 3339 if Mchar = '"' then 3340 Msglen := Msglen - 1; 3341 end if; 3342 3343 -- The loop here deals with recursive types, we are trying to find a 3344 -- related entity that is not an implicit type. Note that the check with 3345 -- Old_Ent stops us from getting "stuck". Also, we don't output the 3346 -- "type derived from" message more than once in the case where we climb 3347 -- up multiple levels. 3348 3349 Find : loop 3350 Old_Ent := Ent; 3351 3352 -- Implicit access type, use directly designated type In Ada 2005, 3353 -- the designated type may be an anonymous access to subprogram, in 3354 -- which case we can only point to its definition. 3355 3356 if Is_Access_Type (Ent) then 3357 if Ekind (Ent) = E_Access_Subprogram_Type 3358 or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type 3359 or else Is_Access_Protected_Subprogram_Type (Ent) 3360 then 3361 Ent := Directly_Designated_Type (Ent); 3362 3363 if not Comes_From_Source (Ent) then 3364 if Buffer_Ends_With ("type ") then 3365 Buffer_Remove ("type "); 3366 end if; 3367 end if; 3368 3369 if Ekind (Ent) = E_Function then 3370 Set_Msg_Str ("access to function "); 3371 elsif Ekind (Ent) = E_Procedure then 3372 Set_Msg_Str ("access to procedure "); 3373 else 3374 Set_Msg_Str ("access to subprogram"); 3375 end if; 3376 3377 exit Find; 3378 3379 -- Type is access to object, named or anonymous 3380 3381 else 3382 Set_Msg_Str ("access to "); 3383 Ent := Directly_Designated_Type (Ent); 3384 end if; 3385 3386 -- Classwide type 3387 3388 elsif Is_Class_Wide_Type (Ent) then 3389 Class_Flag := True; 3390 Ent := Root_Type (Ent); 3391 3392 -- Use base type if this is a subtype 3393 3394 elsif Ent /= Base_Type (Ent) then 3395 Buffer_Remove ("type "); 3396 3397 -- Avoid duplication "subtype of subtype of", and also replace 3398 -- "derived from subtype of" simply by "derived from" 3399 3400 if not Buffer_Ends_With ("subtype of ") 3401 and then not Buffer_Ends_With ("derived from ") 3402 then 3403 Set_Msg_Str ("subtype of "); 3404 end if; 3405 3406 Ent := Base_Type (Ent); 3407 3408 -- If this is a base type with a first named subtype, use the first 3409 -- named subtype instead. This is not quite accurate in all cases, 3410 -- but it makes too much noise to be accurate and add 'Base in all 3411 -- cases. Note that we only do this is the first named subtype is not 3412 -- itself an internal name. This avoids the obvious loop (subtype -> 3413 -- basetype -> subtype) which would otherwise occur). 3414 3415 else 3416 declare 3417 FST : constant Entity_Id := First_Subtype (Ent); 3418 3419 begin 3420 if not Is_Internal_Name (Chars (FST)) then 3421 Ent := FST; 3422 exit Find; 3423 3424 -- Otherwise use root type 3425 3426 else 3427 if not Derived then 3428 Buffer_Remove ("type "); 3429 3430 -- Test for "subtype of type derived from" which seems 3431 -- excessive and is replaced by "type derived from". 3432 3433 Buffer_Remove ("subtype of"); 3434 3435 -- Avoid duplicated "type derived from type derived from" 3436 3437 if not Buffer_Ends_With ("type derived from ") then 3438 Set_Msg_Str ("type derived from "); 3439 end if; 3440 3441 Derived := True; 3442 end if; 3443 end if; 3444 end; 3445 3446 Ent := Etype (Ent); 3447 end if; 3448 3449 -- If we are stuck in a loop, get out and settle for the internal 3450 -- name after all. In this case we set to kill the message if it is 3451 -- not the first error message (we really try hard not to show the 3452 -- dirty laundry of the implementation to the poor user). 3453 3454 if Ent = Old_Ent then 3455 Kill_Message := True; 3456 exit Find; 3457 end if; 3458 3459 -- Get out if we finally found a non-internal name to use 3460 3461 exit Find when not Is_Internal_Name (Chars (Ent)); 3462 end loop Find; 3463 3464 if Mchar = '"' then 3465 Set_Msg_Char ('"'); 3466 end if; 3467 end Unwind_Internal_Type; 3468 3469 -------------------- 3470 -- Warn_Insertion -- 3471 -------------------- 3472 3473 function Warn_Insertion return String is 3474 begin 3475 case Warning_Msg_Char is 3476 when '?' => 3477 return "??"; 3478 3479 when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' => 3480 return '?' & Warning_Msg_Char & '?'; 3481 3482 when ' ' => 3483 return "?"; 3484 3485 when others => 3486 raise Program_Error; 3487 end case; 3488 end Warn_Insertion; 3489 3490end Errout; 3491