gcc/ada/par-ch10.adb

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