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