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