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