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 (Unit_Node) = N_Subprogram_Body_Stub
 512         or else Nkind (Unit_Node) = N_Package_Body_Stub
 513       then
 514          Cunit_Error_Flag := True;
 515          return Error;
 516       end if;
 517
 518       --  Only try this if we got an OK unit!
 519
 520       if Unit_Node /= Error then
 521          if Nkind (Unit_Node) = N_Subunit then
 522             Unit_Node := Proper_Body (Unit_Node);
 523          end if;
 524
 525          if Nkind (Unit_Node) in N_Generic_Declaration then
 526             Unit_Node := Specification (Unit_Node);
 527          end if;
 528
 529          if Nkind (Unit_Node) = N_Package_Declaration
 530            or else Nkind (Unit_Node) = N_Subprogram_Declaration
 531            or else Nkind (Unit_Node) = N_Subprogram_Body
 532            or else Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration
 533          then
 534             Unit_Node := Specification (Unit_Node);
 535
 536          elsif Nkind (Unit_Node) = N_Subprogram_Renaming_Declaration then
 537             if Ada_Version = Ada_83 then
 538                Error_Msg_N
 539                  ("(Ada 83) library unit renaming not allowed", Unit_Node);
 540             end if;
 541          end if;
 542
 543          if Nkind (Unit_Node) = N_Task_Body
 544            or else Nkind (Unit_Node) = N_Protected_Body
 545            or else Nkind (Unit_Node) = N_Task_Type_Declaration
 546            or else Nkind (Unit_Node) = N_Protected_Type_Declaration
 547            or else Nkind (Unit_Node) = N_Single_Task_Declaration
 548            or else Nkind (Unit_Node) = N_Single_Protected_Declaration
 549          then
 550             Name_Node := Defining_Identifier (Unit_Node);
 551
 552          elsif Nkind (Unit_Node) = N_Function_Instantiation
 553            or else Nkind (Unit_Node) = N_Function_Specification
 554            or else Nkind (Unit_Node) = N_Generic_Function_Renaming_Declaration
 555            or else Nkind (Unit_Node) = N_Generic_Package_Renaming_Declaration
 556            or else Nkind (Unit_Node) = N_Generic_Procedure_Renaming_Declaration
 557            or else Nkind (Unit_Node) = N_Package_Body
 558            or else Nkind (Unit_Node) = N_Package_Instantiation
 559            or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
 560            or else Nkind (Unit_Node) = N_Package_Specification
 561            or else Nkind (Unit_Node) = N_Procedure_Instantiation
 562            or else Nkind (Unit_Node) = N_Procedure_Specification
 563          then
 564             Name_Node := Defining_Unit_Name (Unit_Node);
 565
 566          elsif Nkind (Unit_Node) = N_Parameterized_Expression then
 567             Error_Msg_SP
 568               ("parameterized expression 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
1207 end Ch10;