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