1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P A R . C H 1 0 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26pragma Style_Checks (All_Checks); 27-- Turn off subprogram body ordering check. Subprograms are in order 28-- by RM section rather than alphabetical 29 30with Fname.UF; use Fname.UF; 31with Uname; use Uname; 32 33separate (Par) 34package body Ch10 is 35 36 -- Local functions, used only in this chapter 37 38 function P_Context_Clause return List_Id; 39 function P_Subunit return Node_Id; 40 41 function Set_Location return Source_Ptr; 42 -- The current compilation unit starts with Token at Token_Ptr. This 43 -- function determines the corresponding source location for the start 44 -- of the unit, including any preceding comment lines. 45 46 procedure Unit_Display 47 (Cunit : Node_Id; 48 Loc : Source_Ptr; 49 SR_Present : Boolean); 50 -- This procedure is used to generate a line of output for a unit in 51 -- the source program. Cunit is the node for the compilation unit, and 52 -- Loc is the source location for the start of the unit in the source 53 -- file (which is not necessarily the Sloc of the Cunit node). This 54 -- output is written to the standard output file for use by gnatchop. 55 56 procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr); 57 -- This routine has the same calling sequence as Unit_Display, but 58 -- it outputs only the line number and offset of the location, Loc, 59 -- using Cunit to obtain the proper source file index. 60 61 ------------------------- 62 -- 10.1.1 Compilation -- 63 ------------------------- 64 65 -- COMPILATION ::= {COMPILATION_UNIT} 66 67 -- There is no specific parsing routine for a compilation, since we only 68 -- permit a single compilation in a source file, so there is no explicit 69 -- occurrence of compilations as such (our representation of a compilation 70 -- is a series of separate source files). 71 72 ------------------------------ 73 -- 10.1.1 Compilation unit -- 74 ------------------------------ 75 76 -- COMPILATION_UNIT ::= 77 -- CONTEXT_CLAUSE LIBRARY_ITEM 78 -- | CONTEXT_CLAUSE SUBUNIT 79 80 -- LIBRARY_ITEM ::= 81 -- private LIBRARY_UNIT_DECLARATION 82 -- | LIBRARY_UNIT_BODY 83 -- | [private] LIBRARY_UNIT_RENAMING_DECLARATION 84 85 -- LIBRARY_UNIT_DECLARATION ::= 86 -- SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION 87 -- | GENERIC_DECLARATION | GENERIC_INSTANTIATION 88 89 -- LIBRARY_UNIT_RENAMING_DECLARATION ::= 90 -- PACKAGE_RENAMING_DECLARATION 91 -- | GENERIC_RENAMING_DECLARATION 92 -- | SUBPROGRAM_RENAMING_DECLARATION 93 94 -- LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY 95 96 -- Error recovery: cannot raise Error_Resync. If an error occurs, tokens 97 -- are skipped up to the next possible beginning of a compilation unit. 98 99 -- Note: if only configuration pragmas are found, Empty is returned 100 101 -- Note: in syntax-only mode, it is possible for P_Compilation_Unit 102 -- to return strange things that are not really compilation units. 103 -- This is done to help out gnatchop when it is faced with nonsense. 104 105 function P_Compilation_Unit return Node_Id is 106 Scan_State : Saved_Scan_State; 107 Body_Node : Node_Id; 108 Specification_Node : Node_Id; 109 Unit_Node : Node_Id; 110 Comp_Unit_Node : Node_Id; 111 Name_Node : Node_Id; 112 Item : Node_Id; 113 Private_Sloc : Source_Ptr := No_Location; 114 Config_Pragmas : List_Id; 115 P : Node_Id; 116 SR_Present : Boolean; 117 No_Body : Boolean; 118 119 Cunit_Error_Flag : Boolean := False; 120 -- This flag is set True if we have to scan for a compilation unit 121 -- token. It is used to ensure clean termination in such cases by 122 -- not insisting on being at the end of file, and, in the syntax only 123 -- case by not scanning for additional compilation units. 124 125 Cunit_Location : Source_Ptr; 126 -- Location of unit for unit identification output (List_Unit option) 127 128 begin 129 Num_Library_Units := Num_Library_Units + 1; 130 131 -- Set location of the compilation unit if unit list option set 132 -- and we are in syntax check only mode 133 134 if List_Units and then Operating_Mode = Check_Syntax then 135 Cunit_Location := Set_Location; 136 else 137 Cunit_Location := No_Location; 138 end if; 139 140 -- Deal with initial pragmas 141 142 Config_Pragmas := No_List; 143 144 -- If we have an initial Source_Reference pragma, then remember the fact 145 -- to generate an NR parameter in the output line. 146 147 SR_Present := False; 148 149 -- If we see a pragma No_Body, remember not to complain about no body 150 151 No_Body := False; 152 153 if Token = Tok_Pragma then 154 Save_Scan_State (Scan_State); 155 Item := P_Pragma; 156 157 if Item = Error 158 or else Pragma_Name_Unmapped (Item) /= Name_Source_Reference 159 then 160 Restore_Scan_State (Scan_State); 161 162 else 163 SR_Present := True; 164 165 -- If first unit, record the file name for gnatchop use 166 167 if Operating_Mode = Check_Syntax 168 and then List_Units 169 and then Num_Library_Units = 1 170 then 171 Write_Str ("Source_Reference pragma for file """); 172 Write_Name (Full_Ref_Name (Current_Source_File)); 173 Write_Char ('"'); 174 Write_Eol; 175 end if; 176 177 Config_Pragmas := New_List (Item); 178 end if; 179 end if; 180 181 -- Scan out any configuration pragmas 182 183 while Token = Tok_Pragma loop 184 Save_Scan_State (Scan_State); 185 Item := P_Pragma; 186 187 if Item /= Error and then Pragma_Name_Unmapped (Item) = Name_No_Body 188 then 189 No_Body := True; 190 end if; 191 192 if Item = Error 193 or else 194 not Is_Configuration_Pragma_Name (Pragma_Name_Unmapped (Item)) 195 then 196 Restore_Scan_State (Scan_State); 197 exit; 198 end if; 199 200 if Config_Pragmas = No_List then 201 Config_Pragmas := Empty_List; 202 203 if Operating_Mode = Check_Syntax and then List_Units then 204 Write_Str ("Configuration pragmas at"); 205 Unit_Location (Current_Source_File, Cunit_Location); 206 Write_Eol; 207 end if; 208 end if; 209 210 Append (Item, Config_Pragmas); 211 Cunit_Location := Set_Location; 212 end loop; 213 214 -- Establish compilation unit node and scan context items 215 216 Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location); 217 Set_Cunit (Current_Source_Unit, Comp_Unit_Node); 218 Set_Context_Items (Comp_Unit_Node, P_Context_Clause); 219 Set_Aux_Decls_Node 220 (Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location)); 221 222 if Present (Config_Pragmas) then 223 224 -- Check for case of only configuration pragmas present 225 226 if Token = Tok_EOF 227 and then Is_Empty_List (Context_Items (Comp_Unit_Node)) 228 then 229 if Operating_Mode = Check_Syntax then 230 return Empty; 231 232 else 233 Item := First (Config_Pragmas); 234 Error_Msg_N 235 ("cannot compile configuration pragmas with gcc!", Item); 236 Error_Msg_N 237 ("\use gnatchop -c to process configuration pragmas!", Item); 238 raise Unrecoverable_Error; 239 end if; 240 241 -- Otherwise configuration pragmas are simply prepended to the 242 -- context of the current unit. 243 244 else 245 Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas); 246 Set_Context_Items (Comp_Unit_Node, Config_Pragmas); 247 end if; 248 end if; 249 250 -- Check for PRIVATE. Note that for the moment we allow this in 251 -- Ada_83 mode, since we do not yet know if we are compiling a 252 -- predefined unit, and if we are then it would be allowed anyway. 253 254 if Token = Tok_Private then 255 Private_Sloc := Token_Ptr; 256 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); 257 258 if Style_Check then 259 Style.Check_Indentation; 260 end if; 261 262 Save_Scan_State (Scan_State); -- at PRIVATE 263 Scan; -- past PRIVATE 264 265 if Token = Tok_Separate then 266 Error_Msg_SP ("cannot have private subunits!"); 267 268 elsif Token = Tok_Package then 269 Scan; -- past PACKAGE 270 271 if Token = Tok_Body then 272 Restore_Scan_State (Scan_State); -- to PRIVATE 273 Error_Msg_SC ("cannot have private package body!"); 274 Scan; -- ignore PRIVATE 275 276 else 277 Restore_Scan_State (Scan_State); -- to PRIVATE 278 Scan; -- past PRIVATE 279 Set_Private_Present (Comp_Unit_Node, True); 280 end if; 281 282 elsif Token = Tok_Procedure 283 or else Token = Tok_Function 284 or else Token = Tok_Generic 285 then 286 Set_Private_Present (Comp_Unit_Node, True); 287 end if; 288 end if; 289 290 -- Loop to find our way to a compilation unit token 291 292 loop 293 exit when Token in Token_Class_Cunit and then Token /= Tok_With; 294 295 exit when Bad_Spelling_Of (Tok_Package) 296 or else Bad_Spelling_Of (Tok_Function) 297 or else Bad_Spelling_Of (Tok_Generic) 298 or else Bad_Spelling_Of (Tok_Separate) 299 or else Bad_Spelling_Of (Tok_Procedure); 300 301 -- Allow task and protected for nice error recovery purposes 302 303 exit when Token = Tok_Task 304 or else Token = Tok_Protected; 305 306 if Token = Tok_With then 307 Error_Msg_SC ("misplaced WITH"); 308 Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); 309 310 elsif Bad_Spelling_Of (Tok_With) then 311 Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node)); 312 313 else 314 if Operating_Mode = Check_Syntax and then Token = Tok_EOF then 315 316 -- Do not complain if there is a pragma No_Body 317 318 if not No_Body then 319 Error_Msg_SC ("??file contains no compilation units"); 320 end if; 321 322 else 323 Error_Msg_SC ("compilation unit expected"); 324 Cunit_Error_Flag := True; 325 Resync_Cunit; 326 end if; 327 328 -- If we are at an end of file, then just quit, the above error 329 -- message was complaint enough. 330 331 if Token = Tok_EOF then 332 return Error; 333 end if; 334 end if; 335 end loop; 336 337 -- We have a compilation unit token, so that's a reasonable choice for 338 -- determining the standard casing convention used for keywords in case 339 -- it hasn't already been done on seeing a WITH or PRIVATE. 340 341 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); 342 343 if Style_Check then 344 Style.Check_Indentation; 345 end if; 346 347 -- Remaining processing depends on particular type of compilation unit 348 349 if Token = Tok_Package then 350 351 -- A common error is to omit the body keyword after package. We can 352 -- often diagnose this early on (before getting loads of errors from 353 -- contained subprogram bodies), by knowing that the file we 354 -- are compiling has a name that requires a body to be found. 355 356 Save_Scan_State (Scan_State); 357 Scan; -- past Package keyword 358 359 if Token /= Tok_Body 360 and then 361 Get_Expected_Unit_Type 362 (File_Name (Current_Source_File)) = Expect_Body 363 then 364 Error_Msg_BC -- CODEFIX 365 ("keyword BODY expected here '[see file name']"); 366 Restore_Scan_State (Scan_State); 367 Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod_Pexp)); 368 else 369 Restore_Scan_State (Scan_State); 370 Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam_Pexp)); 371 end if; 372 373 elsif Token = Tok_Generic then 374 Set_Unit (Comp_Unit_Node, P_Generic); 375 376 elsif Token = Tok_Separate then 377 Set_Unit (Comp_Unit_Node, P_Subunit); 378 379 elsif Token = Tok_Function 380 or else Token = Tok_Not 381 or else Token = Tok_Overriding 382 or else Token = Tok_Procedure 383 then 384 Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Pexp)); 385 386 -- A little bit of an error recovery check here. If we just scanned 387 -- a subprogram declaration (as indicated by an SIS entry being 388 -- active), then if the following token is BEGIN or an identifier, 389 -- or a token which can reasonably start a declaration but cannot 390 -- start a compilation unit, then we assume that the semicolon in 391 -- the declaration should have been IS. 392 393 if SIS_Entry_Active then 394 395 if Token = Tok_Begin 396 or else Token = Tok_Identifier 397 or else Token in Token_Class_Deckn 398 then 399 Push_Scope_Stack; 400 Scopes (Scope.Last).Etyp := E_Name; 401 Scopes (Scope.Last).Sloc := SIS_Sloc; 402 Scopes (Scope.Last).Ecol := SIS_Ecol; 403 Scopes (Scope.Last).Lreq := False; 404 SIS_Entry_Active := False; 405 406 -- If we had a missing semicolon in the declaration, then 407 -- change the message to from <missing ";"> to <missing "is"> 408 409 if SIS_Missing_Semicolon_Message /= No_Error_Msg then 410 Change_Error_Text -- Replace: "missing "";"" " 411 (SIS_Missing_Semicolon_Message, "missing IS"); 412 413 -- Otherwise we saved the semicolon position, so complain 414 415 else 416 Error_Msg -- CODEFIX 417 (""";"" should be IS", SIS_Semicolon_Sloc); 418 end if; 419 420 Body_Node := Unit (Comp_Unit_Node); 421 Specification_Node := Specification (Body_Node); 422 Change_Node (Body_Node, N_Subprogram_Body); 423 Set_Specification (Body_Node, Specification_Node); 424 Parse_Decls_Begin_End (Body_Node); 425 Set_Unit (Comp_Unit_Node, Body_Node); 426 end if; 427 428 -- If we scanned a subprogram body, make sure we did not have private 429 430 elsif Private_Sloc /= No_Location 431 and then 432 Nkind (Unit (Comp_Unit_Node)) not in N_Subprogram_Instantiation 433 and then 434 Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration 435 then 436 Error_Msg ("cannot have private subprogram body", Private_Sloc); 437 438 -- P_Subprogram can yield an abstract subprogram, but this cannot 439 -- be a compilation unit. Treat as a subprogram declaration. 440 441 elsif 442 Nkind (Unit (Comp_Unit_Node)) = N_Abstract_Subprogram_Declaration 443 then 444 Error_Msg_N 445 ("compilation unit cannot be abstract subprogram", 446 Unit (Comp_Unit_Node)); 447 448 Unit_Node := 449 New_Node (N_Subprogram_Declaration, Sloc (Comp_Unit_Node)); 450 Set_Specification (Unit_Node, 451 Specification (Unit (Comp_Unit_Node))); 452 Set_Unit (Comp_Unit_Node, Unit_Node); 453 end if; 454 455 -- Otherwise we have TASK. This is not really an acceptable token, 456 -- but we accept it to improve error recovery. 457 458 elsif Token = Tok_Task then 459 Scan; -- Past TASK 460 461 if Token = Tok_Type then 462 Error_Msg_SP 463 ("task type cannot be used as compilation unit"); 464 else 465 Error_Msg_SP 466 ("task declaration cannot be used as compilation unit"); 467 end if; 468 469 -- If in check syntax mode, accept the task anyway. This is done 470 -- particularly to improve the behavior of GNATCHOP in this case. 471 472 if Operating_Mode = Check_Syntax then 473 Set_Unit (Comp_Unit_Node, P_Task); 474 475 -- If not in syntax only mode, treat this as horrible error 476 477 else 478 Cunit_Error_Flag := True; 479 return Error; 480 end if; 481 482 else pragma Assert (Token = Tok_Protected); 483 Scan; -- Past PROTECTED 484 485 if Token = Tok_Type then 486 Error_Msg_SP 487 ("protected type cannot be used as compilation unit"); 488 else 489 Error_Msg_SP 490 ("protected declaration cannot be used as compilation unit"); 491 end if; 492 493 -- If in check syntax mode, accept protected anyway. This is done 494 -- particularly to improve the behavior of GNATCHOP in this case. 495 496 if Operating_Mode = Check_Syntax then 497 Set_Unit (Comp_Unit_Node, P_Protected); 498 499 -- If not in syntax only mode, treat this as horrible error 500 501 else 502 Cunit_Error_Flag := True; 503 return Error; 504 end if; 505 end if; 506 507 -- Here is where locate the compilation unit entity. This is a little 508 -- tricky, since it is buried in various places. 509 510 Unit_Node := Unit (Comp_Unit_Node); 511 512 -- Another error from which it is hard to recover 513 514 if Nkind (Unit_Node) in N_Subprogram_Body_Stub | N_Package_Body_Stub then 515 Cunit_Error_Flag := True; 516 return Error; 517 end if; 518 519 -- Only try this if we got an OK unit 520 521 if Unit_Node /= Error then 522 if Nkind (Unit_Node) = N_Subunit then 523 Unit_Node := Proper_Body (Unit_Node); 524 end if; 525 526 if Nkind (Unit_Node) in N_Generic_Declaration then 527 Unit_Node := Specification (Unit_Node); 528 end if; 529 530 if Nkind (Unit_Node) in N_Package_Declaration 531 | N_Subprogram_Declaration 532 | N_Subprogram_Body 533 | N_Subprogram_Renaming_Declaration 534 then 535 Unit_Node := Specification (Unit_Node); 536 537 elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then 538 if Ada_Version = Ada_83 then 539 Error_Msg_N 540 ("(Ada 83) library unit renaming not allowed", Unit_Node); 541 end if; 542 end if; 543 544 if Nkind (Unit_Node) in N_Task_Body 545 | N_Protected_Body 546 | N_Task_Type_Declaration 547 | N_Protected_Type_Declaration 548 | N_Single_Task_Declaration 549 | N_Single_Protected_Declaration 550 then 551 Name_Node := Defining_Identifier (Unit_Node); 552 553 elsif Nkind (Unit_Node) in N_Function_Instantiation 554 | N_Function_Specification 555 | N_Generic_Function_Renaming_Declaration 556 | N_Generic_Package_Renaming_Declaration 557 | N_Generic_Procedure_Renaming_Declaration 558 or else Nkind (Unit_Node) in N_Package_Body 559 | N_Package_Instantiation 560 | N_Package_Renaming_Declaration 561 | N_Package_Specification 562 | N_Procedure_Instantiation 563 | N_Procedure_Specification 564 then 565 Name_Node := Defining_Unit_Name (Unit_Node); 566 567 elsif Nkind (Unit_Node) = N_Expression_Function then 568 Error_Msg_SP 569 ("expression function cannot be used as compilation unit"); 570 return Comp_Unit_Node; 571 572 -- Anything else is a serious error, abandon scan 573 574 else 575 raise Error_Resync; 576 end if; 577 578 Set_Sloc (Comp_Unit_Node, Sloc (Name_Node)); 579 Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node)); 580 581 -- Set Entity field in file table. Easier now that we have name. 582 -- Note that this is also skipped if we had a bad unit 583 584 if Nkind (Name_Node) = N_Defining_Program_Unit_Name then 585 Set_Cunit_Entity 586 (Current_Source_Unit, Defining_Identifier (Name_Node)); 587 else 588 Set_Cunit_Entity (Current_Source_Unit, Name_Node); 589 end if; 590 591 Set_Unit_Name 592 (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node))); 593 594 -- If we had a bad unit, make sure the fatal flag is set in the file 595 -- table entry, since this is surely a fatal error and also set our 596 -- flag to inhibit the requirement that we be at end of file. 597 598 else 599 Cunit_Error_Flag := True; 600 Set_Fatal_Error (Current_Source_Unit, Error_Detected); 601 end if; 602 603 -- Clear away any missing semicolon indication, we are done with that 604 -- unit, so what's done is done, and we don't want anything hanging 605 -- around from the attempt to parse it. 606 607 SIS_Entry_Active := False; 608 609 -- Scan out pragmas after unit 610 611 while Token = Tok_Pragma loop 612 Save_Scan_State (Scan_State); 613 614 -- If we are in syntax scan mode allowing multiple units, then start 615 -- the next unit if we encounter a configuration pragma, or a source 616 -- reference pragma. We take care not to actually scan the pragma in 617 -- this case (we don't want it to take effect for the current unit). 618 619 if Operating_Mode = Check_Syntax then 620 Scan; -- past Pragma 621 622 if Token = Tok_Identifier 623 and then 624 (Is_Configuration_Pragma_Name (Token_Name) 625 or else Token_Name = Name_Source_Reference) 626 then 627 Restore_Scan_State (Scan_State); -- to Pragma 628 exit; 629 end if; 630 end if; 631 632 -- Otherwise eat the pragma, it definitely belongs with the 633 -- current unit, and not with the following unit. 634 635 Restore_Scan_State (Scan_State); -- to Pragma 636 P := P_Pragma; 637 638 if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then 639 Set_Pragmas_After 640 (Aux_Decls_Node (Comp_Unit_Node), New_List); 641 end if; 642 643 Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))); 644 end loop; 645 646 -- Cancel effect of any outstanding pragma Warnings (Off) 647 648 Set_Warnings_Mode_On (Scan_Ptr); 649 650 -- Ada 83 error checks 651 652 if Ada_Version = Ada_83 then 653 654 -- Check we did not with any child units 655 656 Item := First (Context_Items (Comp_Unit_Node)); 657 while Present (Item) loop 658 if Nkind (Item) = N_With_Clause 659 and then Nkind (Name (Item)) /= N_Identifier 660 then 661 Error_Msg_N ("(Ada 83) child units not allowed", Item); 662 end if; 663 664 Next (Item); 665 end loop; 666 667 -- Check that we did not have a PRIVATE keyword present 668 669 if Private_Present (Comp_Unit_Node) then 670 Error_Msg 671 ("(Ada 83) private units not allowed", Private_Sloc); 672 end if; 673 end if; 674 675 -- If no serious error, then output possible unit information line 676 -- for gnatchop if we are in syntax only, list units mode. 677 678 if not Cunit_Error_Flag 679 and then List_Units 680 and then Operating_Mode = Check_Syntax 681 then 682 Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present); 683 end if; 684 685 -- And now we should be at the end of file 686 687 if Token /= Tok_EOF then 688 689 -- If we already had to scan for a compilation unit, then don't 690 -- give any further error message, since it just seems to make 691 -- things worse, and we already gave a serious error message. 692 693 if Cunit_Error_Flag then 694 null; 695 696 -- If we are in check syntax mode, then we allow multiple units 697 -- so we just return with Token not set to Tok_EOF and no message. 698 699 elsif Operating_Mode = Check_Syntax then 700 return Comp_Unit_Node; 701 702 -- We also allow multiple units if we are in multiple unit mode 703 704 elsif Multiple_Unit_Index /= 0 then 705 706 -- Skip tokens to end of file, so that the -gnatl listing 707 -- will be complete in this situation, but no need to parse 708 -- the remaining units; no style checking either. 709 710 declare 711 Save_Style_Check : constant Boolean := Style_Check; 712 713 begin 714 Style_Check := False; 715 716 while Token /= Tok_EOF loop 717 Scan; 718 end loop; 719 720 Style_Check := Save_Style_Check; 721 end; 722 723 return Comp_Unit_Node; 724 725 -- Otherwise we have an error. We suppress the error message 726 -- if we already had a fatal error, since this stops junk 727 -- cascaded messages in some situations. 728 729 else 730 if Fatal_Error (Current_Source_Unit) /= Error_Detected then 731 if Token in Token_Class_Cunit then 732 Error_Msg_SC 733 ("end of file expected, " & 734 "file can have only one compilation unit"); 735 else 736 Error_Msg_SC ("end of file expected"); 737 end if; 738 end if; 739 end if; 740 741 -- Skip tokens to end of file, so that the -gnatl listing 742 -- will be complete in this situation, but no error checking 743 -- other than that provided at the token level. 744 745 while Token /= Tok_EOF loop 746 Scan; 747 end loop; 748 749 return Error; 750 751 -- Normal return (we were at the end of file as expected) 752 753 else 754 return Comp_Unit_Node; 755 end if; 756 757 exception 758 759 -- An error resync is a serious bomb, so indicate result unit no good 760 761 when Error_Resync => 762 Set_Fatal_Error (Current_Source_Unit, Error_Detected); 763 return Error; 764 end P_Compilation_Unit; 765 766 -------------------------- 767 -- 10.1.1 Library Item -- 768 -------------------------- 769 770 -- Parsed by P_Compilation_Unit (10.1.1) 771 772 -------------------------------------- 773 -- 10.1.1 Library Unit Declaration -- 774 -------------------------------------- 775 776 -- Parsed by P_Compilation_Unit (10.1.1) 777 778 ------------------------------------------------ 779 -- 10.1.1 Library Unit Renaming Declaration -- 780 ------------------------------------------------ 781 782 -- Parsed by P_Compilation_Unit (10.1.1) 783 784 ------------------------------- 785 -- 10.1.1 Library Unit Body -- 786 ------------------------------- 787 788 -- Parsed by P_Compilation_Unit (10.1.1) 789 790 ------------------------------ 791 -- 10.1.1 Parent Unit Name -- 792 ------------------------------ 793 794 -- Parsed (as a name) by its parent construct 795 796 ---------------------------- 797 -- 10.1.2 Context Clause -- 798 ---------------------------- 799 800 -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM} 801 802 -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE 803 804 -- WITH_CLAUSE ::= 805 -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME}; 806 -- Note: the two qualifiers are Ada 2005 extensions. 807 808 -- WITH_TYPE_CLAUSE ::= 809 -- with type type_NAME is access; | with type type_NAME is tagged; 810 -- Note: this form is obsolete (old GNAT extension). 811 812 -- Error recovery: Cannot raise Error_Resync 813 814 function P_Context_Clause return List_Id is 815 Item_List : List_Id; 816 Has_Limited : Boolean := False; 817 Has_Private : Boolean := False; 818 Scan_State : Saved_Scan_State; 819 With_Node : Node_Id; 820 First_Flag : Boolean; 821 822 begin 823 Item_List := New_List; 824 825 -- Get keyword casing from WITH keyword in case not set yet 826 827 if Token = Tok_With then 828 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); 829 end if; 830 831 -- Loop through context items 832 833 loop 834 if Style_Check then 835 Style.Check_Indentation; 836 end if; 837 838 -- Gather any pragmas appearing in the context clause 839 840 P_Pragmas_Opt (Item_List); 841 842 -- Processing for WITH clause 843 844 -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH, 845 -- PRIVATE WITH, or both. 846 847 if Token = Tok_Limited then 848 Has_Limited := True; 849 Has_Private := False; 850 Scan; -- past LIMITED 851 852 -- In the context, LIMITED can only appear in a with_clause 853 854 if Token = Tok_Private then 855 Has_Private := True; 856 Scan; -- past PRIVATE 857 end if; 858 859 if Token /= Tok_With then 860 Error_Msg_SC -- CODEFIX 861 ("unexpected LIMITED ignored"); 862 end if; 863 864 Error_Msg_Ada_2005_Extension ("`LIMITED WITH`"); 865 866 elsif Token = Tok_Private then 867 Has_Limited := False; 868 Has_Private := True; 869 Save_Scan_State (Scan_State); 870 Scan; -- past PRIVATE 871 872 if Token /= Tok_With then 873 874 -- Keyword is beginning of private child unit 875 876 Restore_Scan_State (Scan_State); -- to PRIVATE 877 return Item_List; 878 end if; 879 880 Error_Msg_Ada_2005_Extension ("`PRIVATE WITH`"); 881 882 else 883 Has_Limited := False; 884 Has_Private := False; 885 end if; 886 887 if Token = Tok_With then 888 Scan; -- past WITH 889 890 if Token = Tok_Type then 891 892 -- WITH TYPE is an obsolete GNAT specific extension 893 894 Error_Msg_SP ("`WITH TYPE` is an obsolete 'G'N'A'T extension"); 895 Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead"); 896 897 Scan; -- past TYPE 898 899 T_Is; 900 901 if Token = Tok_Tagged then 902 Scan; 903 904 elsif Token = Tok_Access then 905 Scan; 906 907 else 908 Error_Msg_SC ("expect tagged or access qualifier"); 909 end if; 910 911 TF_Semicolon; 912 913 else 914 First_Flag := True; 915 916 -- Loop through names in one with clause, generating a separate 917 -- N_With_Clause node for each name encountered. 918 919 loop 920 With_Node := New_Node (N_With_Clause, Token_Ptr); 921 Append (With_Node, Item_List); 922 923 -- Note that we allow with'ing of child units, even in 924 -- Ada 83 mode, since presumably if this is not desired, 925 -- then the compilation of the child unit itself is the 926 -- place where such an "error" should be caught. 927 928 Set_Name (With_Node, P_Qualified_Simple_Name); 929 if Name (With_Node) = Error then 930 Remove (With_Node); 931 end if; 932 933 Set_First_Name (With_Node, First_Flag); 934 Set_Limited_Present (With_Node, Has_Limited); 935 Set_Private_Present (With_Node, Has_Private); 936 First_Flag := False; 937 938 -- All done if no comma 939 940 exit when Token /= Tok_Comma; 941 942 -- If comma is followed by compilation unit token 943 -- or by USE, or PRAGMA, then it should have been a 944 -- semicolon after all 945 946 Save_Scan_State (Scan_State); 947 Scan; -- past comma 948 949 if Token in Token_Class_Cunit 950 or else Token = Tok_Use 951 or else Token = Tok_Pragma 952 then 953 Restore_Scan_State (Scan_State); 954 exit; 955 end if; 956 end loop; 957 958 Set_Last_Name (With_Node, True); 959 TF_Semicolon; 960 end if; 961 962 -- Processing for USE clause 963 964 elsif Token = Tok_Use then 965 P_Use_Clause (Item_List); 966 967 -- Anything else is end of context clause 968 969 else 970 exit; 971 end if; 972 end loop; 973 974 return Item_List; 975 end P_Context_Clause; 976 977 -------------------------- 978 -- 10.1.2 Context Item -- 979 -------------------------- 980 981 -- Parsed by P_Context_Clause (10.1.2) 982 983 ------------------------- 984 -- 10.1.2 With Clause -- 985 ------------------------- 986 987 -- Parsed by P_Context_Clause (10.1.2) 988 989 ----------------------- 990 -- 10.1.3 Body Stub -- 991 ----------------------- 992 993 -- Subprogram stub parsed by P_Subprogram (6.1) 994 -- Package stub parsed by P_Package (7.1) 995 -- Task stub parsed by P_Task (9.1) 996 -- Protected stub parsed by P_Protected (9.4) 997 998 ---------------------------------- 999 -- 10.1.3 Subprogram Body Stub -- 1000 ---------------------------------- 1001 1002 -- Parsed by P_Subprogram (6.1) 1003 1004 ------------------------------- 1005 -- 10.1.3 Package Body Stub -- 1006 ------------------------------- 1007 1008 -- Parsed by P_Package (7.1) 1009 1010 ---------------------------- 1011 -- 10.1.3 Task Body Stub -- 1012 ---------------------------- 1013 1014 -- Parsed by P_Task (9.1) 1015 1016 --------------------------------- 1017 -- 10.1.3 Protected Body Stub -- 1018 --------------------------------- 1019 1020 -- Parsed by P_Protected (9.4) 1021 1022 --------------------- 1023 -- 10.1.3 Subunit -- 1024 --------------------- 1025 1026 -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY 1027 1028 -- PARENT_UNIT_NAME ::= NAME 1029 1030 -- The caller has checked that the initial token is SEPARATE 1031 1032 -- Error recovery: cannot raise Error_Resync 1033 1034 function P_Subunit return Node_Id is 1035 Subunit_Node : Node_Id; 1036 Body_Node : Node_Id; 1037 1038 begin 1039 Subunit_Node := New_Node (N_Subunit, Token_Ptr); 1040 Body_Node := Error; -- in case no good body found 1041 Scan; -- past SEPARATE; 1042 1043 U_Left_Paren; 1044 Set_Name (Subunit_Node, P_Qualified_Simple_Name); 1045 U_Right_Paren; 1046 1047 Ignore (Tok_Semicolon); 1048 1049 if Token = Tok_Function 1050 or else Token = Tok_Not 1051 or else Token = Tok_Overriding 1052 or else Token = Tok_Procedure 1053 then 1054 Body_Node := P_Subprogram (Pf_Pbod_Pexp); 1055 1056 elsif Token = Tok_Package then 1057 Body_Node := P_Package (Pf_Pbod_Pexp); 1058 1059 elsif Token = Tok_Protected then 1060 Scan; -- past PROTECTED 1061 1062 if Token = Tok_Body then 1063 Body_Node := P_Protected; 1064 else 1065 Error_Msg_AP ("BODY expected"); 1066 return Error; 1067 end if; 1068 1069 elsif Token = Tok_Task then 1070 Scan; -- past TASK 1071 1072 if Token = Tok_Body then 1073 Body_Node := P_Task; 1074 else 1075 Error_Msg_AP ("BODY expected"); 1076 return Error; 1077 end if; 1078 1079 else 1080 Error_Msg_SC ("proper body expected"); 1081 return Error; 1082 end if; 1083 1084 Set_Proper_Body (Subunit_Node, Body_Node); 1085 return Subunit_Node; 1086 end P_Subunit; 1087 1088 ------------------ 1089 -- Set_Location -- 1090 ------------------ 1091 1092 function Set_Location return Source_Ptr is 1093 Physical : Boolean; 1094 Loc : Source_Ptr; 1095 Scan_State : Saved_Scan_State; 1096 1097 begin 1098 -- A special check. If the first token is pragma, and this is a 1099 -- Source_Reference pragma, then do NOT eat previous comments, since 1100 -- the Source_Reference pragma is required to be the first line in 1101 -- the source file. 1102 1103 if Token = Tok_Pragma then 1104 Save_Scan_State (Scan_State); 1105 Scan; -- past Pragma 1106 1107 if Token = Tok_Identifier 1108 and then Token_Name = Name_Source_Reference 1109 then 1110 Restore_Scan_State (Scan_State); 1111 return Token_Ptr; 1112 end if; 1113 1114 Restore_Scan_State (Scan_State); 1115 end if; 1116 1117 -- Otherwise acquire previous comments and blank lines 1118 1119 if Prev_Token = No_Token then 1120 return Source_First (Current_Source_File); 1121 1122 else 1123 Loc := Prev_Token_Ptr; 1124 loop 1125 exit when Loc = Token_Ptr; 1126 1127 -- Should we worry about UTF_32 line terminators here 1128 1129 if Source (Loc) in Line_Terminator then 1130 Skip_Line_Terminators (Loc, Physical); 1131 exit when Physical; 1132 end if; 1133 1134 Loc := Loc + 1; 1135 end loop; 1136 1137 return Loc; 1138 end if; 1139 end Set_Location; 1140 1141 ------------------ 1142 -- Unit_Display -- 1143 ------------------ 1144 1145 -- The format of the generated line, as expected by GNATCHOP is 1146 1147 -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file} 1148 1149 -- where 1150 1151 -- {unit} unit name with terminating (spec) or (body) 1152 -- {line} starting line number 1153 -- {offs} offset to start of text in file 1154 -- {file} source file name 1155 1156 -- The SR parameter is present only if a source reference pragma was 1157 -- scanned for this unit. The significance is that gnatchop should not 1158 -- attempt to add another one. 1159 1160 procedure Unit_Display 1161 (Cunit : Node_Id; 1162 Loc : Source_Ptr; 1163 SR_Present : Boolean) 1164 is 1165 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit); 1166 Sind : constant Source_File_Index := Source_Index (Unum); 1167 Unam : constant Unit_Name_Type := Unit_Name (Unum); 1168 1169 begin 1170 if List_Units then 1171 Write_Str ("Unit "); 1172 Write_Unit_Name (Unit_Name (Unum)); 1173 Unit_Location (Sind, Loc); 1174 1175 if SR_Present then 1176 Write_Str (", SR"); 1177 end if; 1178 1179 Write_Str (", file name "); 1180 Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit)); 1181 Write_Eol; 1182 end if; 1183 end Unit_Display; 1184 1185 ------------------- 1186 -- Unit_Location -- 1187 ------------------- 1188 1189 procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is 1190 Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc); 1191 -- Should the above be the physical line number ??? 1192 1193 begin 1194 Write_Str (" line "); 1195 Write_Int (Int (Line)); 1196 1197 Write_Str (", file offset "); 1198 Write_Int (Int (Loc) - Int (Source_First (Sind))); 1199 end Unit_Location; 1200 1201end Ch10; 1202