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