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-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 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 Scope.Table (Scope.Last).Etyp := E_Name; 401 Scope.Table (Scope.Last).Sloc := SIS_Sloc; 402 Scope.Table (Scope.Last).Ecol := SIS_Ecol; 403 Scope.Table (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_In (Unit_Node, 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_In (Unit_Node, 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_In (Unit_Node, 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_In (Unit_Node, 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 559 Nkind_In (Unit_Node, N_Package_Body, 560 N_Package_Instantiation, 561 N_Package_Renaming_Declaration, 562 N_Package_Specification, 563 N_Procedure_Instantiation, 564 N_Procedure_Specification) 565 then 566 Name_Node := Defining_Unit_Name (Unit_Node); 567 568 elsif Nkind (Unit_Node) = N_Expression_Function then 569 Error_Msg_SP 570 ("expression function cannot be used as compilation unit"); 571 return Comp_Unit_Node; 572 573 -- Anything else is a serious error, abandon scan 574 575 else 576 raise Error_Resync; 577 end if; 578 579 Set_Sloc (Comp_Unit_Node, Sloc (Name_Node)); 580 Set_Sloc (Aux_Decls_Node (Comp_Unit_Node), Sloc (Name_Node)); 581 582 -- Set Entity field in file table. Easier now that we have name. 583 -- Note that this is also skipped if we had a bad unit 584 585 if Nkind (Name_Node) = N_Defining_Program_Unit_Name then 586 Set_Cunit_Entity 587 (Current_Source_Unit, Defining_Identifier (Name_Node)); 588 else 589 Set_Cunit_Entity (Current_Source_Unit, Name_Node); 590 end if; 591 592 Set_Unit_Name 593 (Current_Source_Unit, Get_Unit_Name (Unit (Comp_Unit_Node))); 594 595 -- If we had a bad unit, make sure the fatal flag is set in the file 596 -- table entry, since this is surely a fatal error and also set our 597 -- flag to inhibit the requirement that we be at end of file. 598 599 else 600 Cunit_Error_Flag := True; 601 Set_Fatal_Error (Current_Source_Unit, Error_Detected); 602 end if; 603 604 -- Clear away any missing semicolon indication, we are done with that 605 -- unit, so what's done is done, and we don't want anything hanging 606 -- around from the attempt to parse it. 607 608 SIS_Entry_Active := False; 609 610 -- Scan out pragmas after unit 611 612 while Token = Tok_Pragma loop 613 Save_Scan_State (Scan_State); 614 615 -- If we are in syntax scan mode allowing multiple units, then start 616 -- the next unit if we encounter a configuration pragma, or a source 617 -- reference pragma. We take care not to actually scan the pragma in 618 -- this case (we don't want it to take effect for the current unit). 619 620 if Operating_Mode = Check_Syntax then 621 Scan; -- past Pragma 622 623 if Token = Tok_Identifier 624 and then 625 (Is_Configuration_Pragma_Name (Token_Name) 626 or else Token_Name = Name_Source_Reference) 627 then 628 Restore_Scan_State (Scan_State); -- to Pragma 629 exit; 630 end if; 631 end if; 632 633 -- Otherwise eat the pragma, it definitely belongs with the 634 -- current unit, and not with the following unit. 635 636 Restore_Scan_State (Scan_State); -- to Pragma 637 P := P_Pragma; 638 639 if No (Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))) then 640 Set_Pragmas_After 641 (Aux_Decls_Node (Comp_Unit_Node), New_List); 642 end if; 643 644 Append (P, Pragmas_After (Aux_Decls_Node (Comp_Unit_Node))); 645 end loop; 646 647 -- Cancel effect of any outstanding pragma Warnings (Off) 648 649 Set_Warnings_Mode_On (Scan_Ptr); 650 651 -- Ada 83 error checks 652 653 if Ada_Version = Ada_83 then 654 655 -- Check we did not with any child units 656 657 Item := First (Context_Items (Comp_Unit_Node)); 658 while Present (Item) loop 659 if Nkind (Item) = N_With_Clause 660 and then Nkind (Name (Item)) /= N_Identifier 661 then 662 Error_Msg_N ("(Ada 83) child units not allowed", Item); 663 end if; 664 665 Next (Item); 666 end loop; 667 668 -- Check that we did not have a PRIVATE keyword present 669 670 if Private_Present (Comp_Unit_Node) then 671 Error_Msg 672 ("(Ada 83) private units not allowed", Private_Sloc); 673 end if; 674 end if; 675 676 -- If no serious error, then output possible unit information line 677 -- for gnatchop if we are in syntax only, list units mode. 678 679 if not Cunit_Error_Flag 680 and then List_Units 681 and then Operating_Mode = Check_Syntax 682 then 683 Unit_Display (Comp_Unit_Node, Cunit_Location, SR_Present); 684 end if; 685 686 -- And now we should be at the end of file 687 688 if Token /= Tok_EOF then 689 690 -- If we already had to scan for a compilation unit, then don't 691 -- give any further error message, since it just seems to make 692 -- things worse, and we already gave a serious error message. 693 694 if Cunit_Error_Flag then 695 null; 696 697 -- If we are in check syntax mode, then we allow multiple units 698 -- so we just return with Token not set to Tok_EOF and no message. 699 700 elsif Operating_Mode = Check_Syntax then 701 return Comp_Unit_Node; 702 703 -- We also allow multiple units if we are in multiple unit mode 704 705 elsif Multiple_Unit_Index /= 0 then 706 707 -- Skip tokens to end of file, so that the -gnatl listing 708 -- will be complete in this situation, but no need to parse 709 -- the remaining units; no style checking either. 710 711 declare 712 Save_Style_Check : constant Boolean := Style_Check; 713 714 begin 715 Style_Check := False; 716 717 while Token /= Tok_EOF loop 718 Scan; 719 end loop; 720 721 Style_Check := Save_Style_Check; 722 end; 723 724 return Comp_Unit_Node; 725 726 -- Otherwise we have an error. We suppress the error message 727 -- if we already had a fatal error, since this stops junk 728 -- cascaded messages in some situations. 729 730 else 731 if Fatal_Error (Current_Source_Unit) /= Error_Detected then 732 if Token in Token_Class_Cunit then 733 Error_Msg_SC 734 ("end of file expected, " & 735 "file can have only one compilation unit"); 736 else 737 Error_Msg_SC ("end of file expected"); 738 end if; 739 end if; 740 end if; 741 742 -- Skip tokens to end of file, so that the -gnatl listing 743 -- will be complete in this situation, but no error checking 744 -- other than that provided at the token level. 745 746 while Token /= Tok_EOF loop 747 Scan; 748 end loop; 749 750 return Error; 751 752 -- Normal return (we were at the end of file as expected) 753 754 else 755 return Comp_Unit_Node; 756 end if; 757 758 exception 759 760 -- An error resync is a serious bomb, so indicate result unit no good 761 762 when Error_Resync => 763 Set_Fatal_Error (Current_Source_Unit, Error_Detected); 764 return Error; 765 end P_Compilation_Unit; 766 767 -------------------------- 768 -- 10.1.1 Library Item -- 769 -------------------------- 770 771 -- Parsed by P_Compilation_Unit (10.1.1) 772 773 -------------------------------------- 774 -- 10.1.1 Library Unit Declaration -- 775 -------------------------------------- 776 777 -- Parsed by P_Compilation_Unit (10.1.1) 778 779 ------------------------------------------------ 780 -- 10.1.1 Library Unit Renaming Declaration -- 781 ------------------------------------------------ 782 783 -- Parsed by P_Compilation_Unit (10.1.1) 784 785 ------------------------------- 786 -- 10.1.1 Library Unit Body -- 787 ------------------------------- 788 789 -- Parsed by P_Compilation_Unit (10.1.1) 790 791 ------------------------------ 792 -- 10.1.1 Parent Unit Name -- 793 ------------------------------ 794 795 -- Parsed (as a name) by its parent construct 796 797 ---------------------------- 798 -- 10.1.2 Context Clause -- 799 ---------------------------- 800 801 -- CONTEXT_CLAUSE ::= {CONTEXT_ITEM} 802 803 -- CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE 804 805 -- WITH_CLAUSE ::= 806 -- [LIMITED] [PRIVATE] with library_unit_NAME {,library_unit_NAME}; 807 -- Note: the two qualifiers are Ada 2005 extensions. 808 809 -- WITH_TYPE_CLAUSE ::= 810 -- with type type_NAME is access; | with type type_NAME is tagged; 811 -- Note: this form is obsolete (old GNAT extension). 812 813 -- Error recovery: Cannot raise Error_Resync 814 815 function P_Context_Clause return List_Id is 816 Item_List : List_Id; 817 Has_Limited : Boolean := False; 818 Has_Private : Boolean := False; 819 Scan_State : Saved_Scan_State; 820 With_Node : Node_Id; 821 First_Flag : Boolean; 822 823 begin 824 Item_List := New_List; 825 826 -- Get keyword casing from WITH keyword in case not set yet 827 828 if Token = Tok_With then 829 Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing); 830 end if; 831 832 -- Loop through context items 833 834 loop 835 if Style_Check then 836 Style.Check_Indentation; 837 end if; 838 839 -- Gather any pragmas appearing in the context clause 840 841 P_Pragmas_Opt (Item_List); 842 843 -- Processing for WITH clause 844 845 -- Ada 2005 (AI-50217, AI-262): First check for LIMITED WITH, 846 -- PRIVATE WITH, or both. 847 848 if Token = Tok_Limited then 849 Has_Limited := True; 850 Has_Private := False; 851 Scan; -- past LIMITED 852 853 -- In the context, LIMITED can only appear in a with_clause 854 855 if Token = Tok_Private then 856 Has_Private := True; 857 Scan; -- past PRIVATE 858 end if; 859 860 if Token /= Tok_With then 861 Error_Msg_SC -- CODEFIX 862 ("unexpected LIMITED ignored"); 863 end if; 864 865 if Ada_Version < Ada_2005 then 866 Error_Msg_SP ("LIMITED WITH is an Ada 2005 extension"); 867 Error_Msg_SP 868 ("\unit must be compiled with -gnat05 switch"); 869 end if; 870 871 elsif Token = Tok_Private then 872 Has_Limited := False; 873 Has_Private := True; 874 Save_Scan_State (Scan_State); 875 Scan; -- past PRIVATE 876 877 if Token /= Tok_With then 878 879 -- Keyword is beginning of private child unit 880 881 Restore_Scan_State (Scan_State); -- to PRIVATE 882 return Item_List; 883 884 elsif Ada_Version < Ada_2005 then 885 Error_Msg_SP ("`PRIVATE WITH` is an Ada 2005 extension"); 886 Error_Msg_SP 887 ("\unit must be compiled with -gnat05 switch"); 888 end if; 889 890 else 891 Has_Limited := False; 892 Has_Private := False; 893 end if; 894 895 if Token = Tok_With then 896 Scan; -- past WITH 897 898 if Token = Tok_Type then 899 900 -- WITH TYPE is an obsolete GNAT specific extension 901 902 Error_Msg_SP ("`WITH TYPE` is an obsolete 'G'N'A'T extension"); 903 Error_Msg_SP ("\use Ada 2005 `LIMITED WITH` clause instead"); 904 905 Scan; -- past TYPE 906 907 T_Is; 908 909 if Token = Tok_Tagged then 910 Scan; 911 912 elsif Token = Tok_Access then 913 Scan; 914 915 else 916 Error_Msg_SC ("expect tagged or access qualifier"); 917 end if; 918 919 TF_Semicolon; 920 921 else 922 First_Flag := True; 923 924 -- Loop through names in one with clause, generating a separate 925 -- N_With_Clause node for each name encountered. 926 927 loop 928 With_Node := New_Node (N_With_Clause, Token_Ptr); 929 Append (With_Node, Item_List); 930 931 -- Note that we allow with'ing of child units, even in 932 -- Ada 83 mode, since presumably if this is not desired, 933 -- then the compilation of the child unit itself is the 934 -- place where such an "error" should be caught. 935 936 Set_Name (With_Node, P_Qualified_Simple_Name); 937 if Name (With_Node) = Error then 938 Remove (With_Node); 939 end if; 940 941 Set_First_Name (With_Node, First_Flag); 942 Set_Limited_Present (With_Node, Has_Limited); 943 Set_Private_Present (With_Node, Has_Private); 944 First_Flag := False; 945 946 -- All done if no comma 947 948 exit when Token /= Tok_Comma; 949 950 -- If comma is followed by compilation unit token 951 -- or by USE, or PRAGMA, then it should have been a 952 -- semicolon after all 953 954 Save_Scan_State (Scan_State); 955 Scan; -- past comma 956 957 if Token in Token_Class_Cunit 958 or else Token = Tok_Use 959 or else Token = Tok_Pragma 960 then 961 Restore_Scan_State (Scan_State); 962 exit; 963 end if; 964 end loop; 965 966 Set_Last_Name (With_Node, True); 967 TF_Semicolon; 968 end if; 969 970 -- Processing for USE clause 971 972 elsif Token = Tok_Use then 973 P_Use_Clause (Item_List); 974 975 -- Anything else is end of context clause 976 977 else 978 exit; 979 end if; 980 end loop; 981 982 return Item_List; 983 end P_Context_Clause; 984 985 -------------------------- 986 -- 10.1.2 Context Item -- 987 -------------------------- 988 989 -- Parsed by P_Context_Clause (10.1.2) 990 991 ------------------------- 992 -- 10.1.2 With Clause -- 993 ------------------------- 994 995 -- Parsed by P_Context_Clause (10.1.2) 996 997 ----------------------- 998 -- 10.1.3 Body Stub -- 999 ----------------------- 1000 1001 -- Subprogram stub parsed by P_Subprogram (6.1) 1002 -- Package stub parsed by P_Package (7.1) 1003 -- Task stub parsed by P_Task (9.1) 1004 -- Protected stub parsed by P_Protected (9.4) 1005 1006 ---------------------------------- 1007 -- 10.1.3 Subprogram Body Stub -- 1008 ---------------------------------- 1009 1010 -- Parsed by P_Subprogram (6.1) 1011 1012 ------------------------------- 1013 -- 10.1.3 Package Body Stub -- 1014 ------------------------------- 1015 1016 -- Parsed by P_Package (7.1) 1017 1018 ---------------------------- 1019 -- 10.1.3 Task Body Stub -- 1020 ---------------------------- 1021 1022 -- Parsed by P_Task (9.1) 1023 1024 --------------------------------- 1025 -- 10.1.3 Protected Body Stub -- 1026 --------------------------------- 1027 1028 -- Parsed by P_Protected (9.4) 1029 1030 --------------------- 1031 -- 10.1.3 Subunit -- 1032 --------------------- 1033 1034 -- SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY 1035 1036 -- PARENT_UNIT_NAME ::= NAME 1037 1038 -- The caller has checked that the initial token is SEPARATE 1039 1040 -- Error recovery: cannot raise Error_Resync 1041 1042 function P_Subunit return Node_Id is 1043 Subunit_Node : Node_Id; 1044 Body_Node : Node_Id; 1045 1046 begin 1047 Subunit_Node := New_Node (N_Subunit, Token_Ptr); 1048 Body_Node := Error; -- in case no good body found 1049 Scan; -- past SEPARATE; 1050 1051 U_Left_Paren; 1052 Set_Name (Subunit_Node, P_Qualified_Simple_Name); 1053 U_Right_Paren; 1054 1055 Ignore (Tok_Semicolon); 1056 1057 if Token = Tok_Function 1058 or else Token = Tok_Not 1059 or else Token = Tok_Overriding 1060 or else Token = Tok_Procedure 1061 then 1062 Body_Node := P_Subprogram (Pf_Pbod_Pexp); 1063 1064 elsif Token = Tok_Package then 1065 Body_Node := P_Package (Pf_Pbod_Pexp); 1066 1067 elsif Token = Tok_Protected then 1068 Scan; -- past PROTECTED 1069 1070 if Token = Tok_Body then 1071 Body_Node := P_Protected; 1072 else 1073 Error_Msg_AP ("BODY expected"); 1074 return Error; 1075 end if; 1076 1077 elsif Token = Tok_Task then 1078 Scan; -- past TASK 1079 1080 if Token = Tok_Body then 1081 Body_Node := P_Task; 1082 else 1083 Error_Msg_AP ("BODY expected"); 1084 return Error; 1085 end if; 1086 1087 else 1088 Error_Msg_SC ("proper body expected"); 1089 return Error; 1090 end if; 1091 1092 Set_Proper_Body (Subunit_Node, Body_Node); 1093 return Subunit_Node; 1094 end P_Subunit; 1095 1096 ------------------ 1097 -- Set_Location -- 1098 ------------------ 1099 1100 function Set_Location return Source_Ptr is 1101 Physical : Boolean; 1102 Loc : Source_Ptr; 1103 Scan_State : Saved_Scan_State; 1104 1105 begin 1106 -- A special check. If the first token is pragma, and this is a 1107 -- Source_Reference pragma, then do NOT eat previous comments, since 1108 -- the Source_Reference pragma is required to be the first line in 1109 -- the source file. 1110 1111 if Token = Tok_Pragma then 1112 Save_Scan_State (Scan_State); 1113 Scan; -- past Pragma 1114 1115 if Token = Tok_Identifier 1116 and then Token_Name = Name_Source_Reference 1117 then 1118 Restore_Scan_State (Scan_State); 1119 return Token_Ptr; 1120 end if; 1121 1122 Restore_Scan_State (Scan_State); 1123 end if; 1124 1125 -- Otherwise acquire previous comments and blank lines 1126 1127 if Prev_Token = No_Token then 1128 return Source_First (Current_Source_File); 1129 1130 else 1131 Loc := Prev_Token_Ptr; 1132 loop 1133 exit when Loc = Token_Ptr; 1134 1135 -- Should we worry about UTF_32 line terminators here 1136 1137 if Source (Loc) in Line_Terminator then 1138 Skip_Line_Terminators (Loc, Physical); 1139 exit when Physical; 1140 end if; 1141 1142 Loc := Loc + 1; 1143 end loop; 1144 1145 return Loc; 1146 end if; 1147 end Set_Location; 1148 1149 ------------------ 1150 -- Unit_Display -- 1151 ------------------ 1152 1153 -- The format of the generated line, as expected by GNATCHOP is 1154 1155 -- Unit {unit} line {line}, file offset {offs} [, SR], file name {file} 1156 1157 -- where 1158 1159 -- {unit} unit name with terminating (spec) or (body) 1160 -- {line} starting line number 1161 -- {offs} offset to start of text in file 1162 -- {file} source file name 1163 1164 -- The SR parameter is present only if a source reference pragma was 1165 -- scanned for this unit. The significance is that gnatchop should not 1166 -- attempt to add another one. 1167 1168 procedure Unit_Display 1169 (Cunit : Node_Id; 1170 Loc : Source_Ptr; 1171 SR_Present : Boolean) 1172 is 1173 Unum : constant Unit_Number_Type := Get_Cunit_Unit_Number (Cunit); 1174 Sind : constant Source_File_Index := Source_Index (Unum); 1175 Unam : constant Unit_Name_Type := Unit_Name (Unum); 1176 1177 begin 1178 if List_Units then 1179 Write_Str ("Unit "); 1180 Write_Unit_Name (Unit_Name (Unum)); 1181 Unit_Location (Sind, Loc); 1182 1183 if SR_Present then 1184 Write_Str (", SR"); 1185 end if; 1186 1187 Write_Str (", file name "); 1188 Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit)); 1189 Write_Eol; 1190 end if; 1191 end Unit_Display; 1192 1193 ------------------- 1194 -- Unit_Location -- 1195 ------------------- 1196 1197 procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is 1198 Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc); 1199 -- Should the above be the physical line number ??? 1200 1201 begin 1202 Write_Str (" line "); 1203 Write_Int (Int (Line)); 1204 1205 Write_Str (", file offset "); 1206 Write_Int (Int (Loc) - Int (Source_First (Sind))); 1207 end Unit_Location; 1208 1209end Ch10; 1210