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