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