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