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-2004 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 2,  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 COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 pragma Style_Checks (All_Checks);
  28 --  Turn off subprogram body ordering check. Subprograms are in order
  29 --  by RM section rather than alphabetical
  30
  31 with Fname;    use Fname;
  32 with Fname.UF; use Fname.UF;
  33 with Uname;    use Uname;
  34
  35 separate (Par)
  36 package body Ch10 is
  37
  38    --  Local functions, used only in this chapter
  39
  40    function P_Context_Clause    return List_Id;
  41    function P_Subunit           return Node_Id;
  42
  43    function Set_Location return Source_Ptr;
  44    --  The current compilation unit starts with Token at Token_Ptr. This
  45    --  function determines the corresponding source location for the start
  46    --  of the unit, including any preceding comment lines.
  47
  48    procedure Unit_Display
  49      (Cunit      : Node_Id;
  50       Loc        : Source_Ptr;
  51       SR_Present : Boolean);
  52    --  This procedure is used to generate a line of output for the a unit in
  53    --  the source program. Cunit is the node for the compilation unit, and
  54    --  Loc is the source location for the start of the unit in the source
  55    --  file (which is not necessarily the Sloc of the Cunit node). This
  56    --  output is written to the standard output file for use by gnatchop.
  57
  58    procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr);
  59    --  This routine has the same calling sequence as Unit_Display, but
  60    --  it outputs only the line number and offset of the location, Loc,
  61    --  using Cunit to obtain the proper source file index.
  62
  63    -------------------------
  64    -- 10.1.1  Compilation --
  65    -------------------------
  66
  67    --  COMPILATION ::= {COMPILATION_UNIT}
  68
  69    --  There is no specific parsing routine for a compilation, since we only
  70    --  permit a single compilation in a source file, so there is no explicit
  71    --  occurrence of compilations as such (our representation of a compilation
  72    --  is a series of separate source files).
  73
  74    ------------------------------
  75    -- 10.1.1  Compilation unit --
  76    ------------------------------
  77
  78    --  COMPILATION_UNIT ::=
  79    --    CONTEXT_CLAUSE LIBRARY_ITEM
  80    --  | CONTEXT_CLAUSE SUBUNIT
  81
  82    --  LIBRARY_ITEM ::=
  83    --    private LIBRARY_UNIT_DECLARATION
  84    --  | LIBRARY_UNIT_BODY
  85    --  | [private] LIBRARY_UNIT_RENAMING_DECLARATION
  86
  87    --  LIBRARY_UNIT_DECLARATION ::=
  88    --    SUBPROGRAM_DECLARATION | PACKAGE_DECLARATION
  89    --  | GENERIC_DECLARATION    | GENERIC_INSTANTIATION
  90
  91    --  LIBRARY_UNIT_RENAMING_DECLARATION ::=
  92    --    PACKAGE_RENAMING_DECLARATION
  93    --  | GENERIC_RENAMING_DECLARATION
  94    --  | SUBPROGRAM_RENAMING_DECLARATION
  95
  96    --  LIBRARY_UNIT_BODY ::= SUBPROGRAM_BODY | PACKAGE_BODY
  97
  98    --  Error recovery: cannot raise Error_Resync. If an error occurs, tokens
  99    --  are skipped up to the next possible beginning of a compilation unit.
 100
 101    --  Note: if only configuration pragmas are found, Empty is returned
 102
 103    --  Note: in syntax-only mode, it is possible for P_Compilation_Unit
 104    --  to return strange things that are not really compilation units.
 105    --  This is done to help out gnatchop when it is faced with nonsense.
 106
 107    function P_Compilation_Unit return Node_Id is
 108       Scan_State         : Saved_Scan_State;
 109       Body_Node          : Node_Id;
 110       Specification_Node : Node_Id;
 111       Unit_Node          : Node_Id;
 112       Comp_Unit_Node     : Node_Id;
 113       Name_Node          : Node_Id;
 114       Item               : Node_Id;
 115       Private_Sloc       : Source_Ptr := No_Location;
 116       Config_Pragmas     : List_Id;
 117       P                  : Node_Id;
 118       SR_Present         : Boolean;
 119
 120       Cunit_Error_Flag   : Boolean := False;
 121       --  This flag is set True if we have to scan for a compilation unit
 122       --  token. It is used to ensure clean termination in such cases by
 123       --  not insisting on being at the end of file, and, in the sytax only
 124       --  case by not scanning for additional compilation units.
 125
 126       Cunit_Location : Source_Ptr;
 127       --  Location of unit for unit identification output (List_Unit option)
 128
 129    begin
 130       Num_Library_Units := Num_Library_Units + 1;
 131
 132       --  Set location of the compilation unit if unit list option set
 133       --  and we are in syntax check only mode
 134
 135       if List_Units and then Operating_Mode = Check_Syntax then
 136          Cunit_Location := Set_Location;
 137       else
 138          Cunit_Location := No_Location;
 139       end if;
 140
 141       --  Deal with initial pragmas
 142
 143       Config_Pragmas := No_List;
 144
 145       --  If we have an initial Source_Reference pragma, then remember
 146       --  the fact to generate an NR parameter in the output line.
 147
 148       SR_Present := False;
 149
 150       if Token = Tok_Pragma then
 151          Save_Scan_State (Scan_State);
 152          Item := P_Pragma;
 153
 154          if Item = Error
 155            or else Chars (Item) /= Name_Source_Reference
 156          then
 157             Restore_Scan_State (Scan_State);
 158
 159          else
 160             SR_Present := True;
 161
 162             --  If first unit, record the file name for gnatchop use
 163
 164             if Operating_Mode = Check_Syntax
 165               and then List_Units
 166               and then Num_Library_Units = 1
 167             then
 168                Write_Str ("Source_Reference pragma for file """);
 169                Write_Name (Full_Ref_Name (Current_Source_File));
 170                Write_Char ('"');
 171                Write_Eol;
 172             end if;
 173
 174             Config_Pragmas := New_List (Item);
 175          end if;
 176       end if;
 177
 178       --  Scan out any configuration pragmas
 179
 180       while Token = Tok_Pragma loop
 181          Save_Scan_State (Scan_State);
 182          Item := P_Pragma;
 183
 184          if Item = Error
 185            or else Chars (Item) > Last_Configuration_Pragma_Name
 186          then
 187             Restore_Scan_State (Scan_State);
 188             exit;
 189          end if;
 190
 191          if Config_Pragmas = No_List then
 192             Config_Pragmas := Empty_List;
 193
 194             if Operating_Mode = Check_Syntax and then List_Units then
 195                Write_Str ("Configuration pragmas at");
 196                Unit_Location (Current_Source_File, Cunit_Location);
 197                Write_Eol;
 198             end if;
 199          end if;
 200
 201          Append (Item, Config_Pragmas);
 202          Cunit_Location := Set_Location;
 203       end loop;
 204
 205       --  Establish compilation unit node and scan context items
 206
 207       Comp_Unit_Node := New_Node (N_Compilation_Unit, No_Location);
 208       Set_Cunit (Current_Source_Unit, Comp_Unit_Node);
 209       Set_Context_Items (Comp_Unit_Node, P_Context_Clause);
 210       Set_Aux_Decls_Node
 211         (Comp_Unit_Node, New_Node (N_Compilation_Unit_Aux, No_Location));
 212
 213       if Present (Config_Pragmas) then
 214
 215          --  Check for case of only configuration pragmas present
 216
 217          if Token = Tok_EOF
 218            and then Is_Empty_List (Context_Items (Comp_Unit_Node))
 219          then
 220             if Operating_Mode = Check_Syntax then
 221                return Empty;
 222
 223             else
 224                Item := First (Config_Pragmas);
 225                Error_Msg_N
 226                  ("cannot compile configuration pragmas with gcc", Item);
 227                Error_Msg_N
 228                  ("use gnatchop -c to process configuration pragmas!", Item);
 229                raise Unrecoverable_Error;
 230             end if;
 231
 232          --  Otherwise configuration pragmas are simply prepended to the
 233          --  context of the current unit.
 234
 235          else
 236             Append_List (Context_Items (Comp_Unit_Node), Config_Pragmas);
 237             Set_Context_Items (Comp_Unit_Node, Config_Pragmas);
 238          end if;
 239       end if;
 240
 241       --  Check for PRIVATE. Note that for the moment we allow this in
 242       --  Ada_83 mode, since we do not yet know if we are compiling a
 243       --  predefined unit, and if we are then it would be allowed anyway.
 244
 245       if Token = Tok_Private then
 246          Private_Sloc := Token_Ptr;
 247          Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
 248          if Style_Check then Style.Check_Indentation; end if;
 249
 250          Save_Scan_State (Scan_State); -- at PRIVATE
 251          Scan; -- past PRIVATE
 252
 253          if Token = Tok_Separate then
 254             Error_Msg_SP ("cannot have private subunits!");
 255
 256          elsif Token = Tok_Package then
 257             Scan; -- past PACKAGE
 258
 259             if Token = Tok_Body then
 260                Restore_Scan_State (Scan_State); -- to PRIVATE
 261                Error_Msg_SC ("cannot have private package body!");
 262                Scan; -- ignore PRIVATE
 263
 264             else
 265                Restore_Scan_State (Scan_State); -- to PRIVATE
 266                Scan; -- past PRIVATE
 267                Set_Private_Present (Comp_Unit_Node, True);
 268             end if;
 269
 270          elsif Token = Tok_Procedure
 271            or else Token = Tok_Function
 272            or else Token = Tok_Generic
 273          then
 274             Set_Private_Present (Comp_Unit_Node, True);
 275          end if;
 276       end if;
 277
 278       --  Loop to find our way to a compilation unit token
 279
 280       loop
 281          exit when Token in Token_Class_Cunit and then Token /= Tok_With;
 282
 283          exit when Bad_Spelling_Of (Tok_Package)
 284            or else Bad_Spelling_Of (Tok_Function)
 285            or else Bad_Spelling_Of (Tok_Generic)
 286            or else Bad_Spelling_Of (Tok_Separate)
 287            or else Bad_Spelling_Of (Tok_Procedure);
 288
 289          --  Allow task and protected for nice error recovery purposes
 290
 291          exit when Token = Tok_Task
 292            or else Token = Tok_Protected;
 293
 294          if Token = Tok_With then
 295             Error_Msg_SC ("misplaced WITH");
 296             Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
 297
 298          elsif Bad_Spelling_Of (Tok_With) then
 299             Append_List (P_Context_Clause, Context_Items (Comp_Unit_Node));
 300
 301          else
 302             if Operating_Mode = Check_Syntax and then Token = Tok_EOF then
 303                Error_Msg_SC ("?file contains no compilation units");
 304             else
 305                Error_Msg_SC ("compilation unit expected");
 306                Cunit_Error_Flag := True;
 307                Resync_Cunit;
 308             end if;
 309
 310             --  If we are at an end of file, then just quit, the above error
 311             --  message was complaint enough.
 312
 313             if Token = Tok_EOF then
 314                return Error;
 315             end if;
 316          end if;
 317       end loop;
 318
 319       --  We have a compilation unit token, so that's a reasonable choice for
 320       --  determining the standard casing convention used for keywords in case
 321       --  it hasn't already been done on seeing a WITH or PRIVATE.
 322
 323       Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
 324       if Style_Check then Style.Check_Indentation; end if;
 325
 326       --  Remaining processing depends on particular type of compilation unit
 327
 328       if Token = Tok_Package then
 329
 330          --  A common error is to omit the body keyword after package. We can
 331          --  often diagnose this early on (before getting loads of errors from
 332          --  contained subprogram bodies), by knowing that that the file we
 333          --  are compiling has a name that requires a body to be found.
 334
 335          Save_Scan_State (Scan_State);
 336          Scan; -- past Package keyword
 337
 338          if Token /= Tok_Body
 339            and then
 340              Get_Expected_Unit_Type
 341                (File_Name (Current_Source_File)) = Expect_Body
 342          then
 343             Error_Msg_BC ("keyword BODY expected here [see file name]");
 344             Restore_Scan_State (Scan_State);
 345             Set_Unit (Comp_Unit_Node, P_Package (Pf_Pbod));
 346          else
 347             Restore_Scan_State (Scan_State);
 348             Set_Unit (Comp_Unit_Node, P_Package (Pf_Decl_Gins_Pbod_Rnam));
 349          end if;
 350
 351       elsif Token = Tok_Generic then
 352          Set_Unit (Comp_Unit_Node, P_Generic);
 353
 354       elsif Token = Tok_Separate then
 355          Set_Unit (Comp_Unit_Node, P_Subunit);
 356
 357       elsif Token = Tok_Procedure
 358         or else Token = Tok_Function
 359       then
 360          Set_Unit (Comp_Unit_Node, P_Subprogram (Pf_Decl_Gins_Pbod_Rnam));
 361
 362          --  A little bit of an error recovery check here. If we just scanned
 363          --  a subprogram declaration (as indicated by an SIS entry being
 364          --  active), then if the following token is BEGIN or an identifier,
 365          --  or a token which can reasonably start a declaration but cannot
 366          --  start a compilation unit, then we assume that the semicolon in
 367          --  the declaration should have been IS.
 368
 369          if SIS_Entry_Active then
 370
 371             if Token = Tok_Begin
 372                or else Token = Tok_Identifier
 373                or else Token in Token_Class_Deckn
 374             then
 375                Push_Scope_Stack;
 376                Scope.Table (Scope.Last).Etyp := E_Name;
 377                Scope.Table (Scope.Last).Sloc := SIS_Sloc;
 378                Scope.Table (Scope.Last).Ecol := SIS_Ecol;
 379                Scope.Table (Scope.Last).Lreq := False;
 380                SIS_Entry_Active := False;
 381
 382                --  If we had a missing semicolon in the declaration, then
 383                --  change the message to from <missing ";"> to <missing "is">
 384
 385                if SIS_Missing_Semicolon_Message /= No_Error_Msg then
 386                   Change_Error_Text     -- Replace: "missing "";"" "
 387                     (SIS_Missing_Semicolon_Message, "missing IS");
 388
 389                --  Otherwise we saved the semicolon position, so complain
 390
 391                else
 392                   Error_Msg (""";"" should be IS", SIS_Semicolon_Sloc);
 393                end if;
 394
 395                Body_Node := Unit (Comp_Unit_Node);
 396                Specification_Node := Specification (Body_Node);
 397                Change_Node (Body_Node, N_Subprogram_Body);
 398                Set_Specification (Body_Node, Specification_Node);
 399                Parse_Decls_Begin_End (Body_Node);
 400                Set_Unit (Comp_Unit_Node, Body_Node);
 401             end if;
 402
 403          --  If we scanned a subprogram body, make sure we did not have private
 404
 405          elsif Private_Sloc /= No_Location
 406            and then
 407              Nkind (Unit (Comp_Unit_Node)) /= N_Function_Instantiation
 408            and then
 409              Nkind (Unit (Comp_Unit_Node)) /= N_Procedure_Instantiation
 410            and then
 411              Nkind (Unit (Comp_Unit_Node)) /= N_Subprogram_Renaming_Declaration
 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          --  We also allow multiple units if we are in multiple unit mode
 663
 664          elsif Multiple_Unit_Index /= 0 then
 665
 666             --  Skip tokens to end of file, so that the -gnatl listing
 667             --  will be complete in this situation, but no need to parse
 668             --  the remaining units; no style checking either.
 669
 670             declare
 671                Save_Style_Check : constant Boolean := Style_Check;
 672
 673             begin
 674                Style_Check := False;
 675
 676                while Token /= Tok_EOF loop
 677                   Scan;
 678                end loop;
 679
 680                Style_Check := Save_Style_Check;
 681             end;
 682
 683             return Comp_Unit_Node;
 684
 685          --  Otherwise we have an error. We suppress the error message
 686          --  if we already had a fatal error, since this stops junk
 687          --  cascaded messages in some situations.
 688
 689          else
 690             if not Fatal_Error (Current_Source_Unit) then
 691                if Token in Token_Class_Cunit then
 692                   Error_Msg_SC
 693                     ("end of file expected, " &
 694                      "file can have only one compilation unit");
 695                else
 696                   Error_Msg_SC ("end of file expected");
 697                end if;
 698             end if;
 699          end if;
 700
 701          --  Skip tokens to end of file, so that the -gnatl listing
 702          --  will be complete in this situation, but no error checking
 703          --  other than that provided at the token level.
 704
 705          while Token /= Tok_EOF loop
 706             Scan;
 707          end loop;
 708
 709          return Error;
 710
 711       --  Normal return (we were at the end of file as expected)
 712
 713       else
 714          return Comp_Unit_Node;
 715       end if;
 716
 717    exception
 718
 719       --  An error resync is a serious bomb, so indicate result unit no good
 720
 721       when Error_Resync =>
 722          Set_Fatal_Error (Current_Source_Unit);
 723          return Error;
 724    end P_Compilation_Unit;
 725
 726    --------------------------
 727    -- 10.1.1  Library Item --
 728    --------------------------
 729
 730    --  Parsed by P_Compilation_Unit (10.1.1)
 731
 732    --------------------------------------
 733    -- 10.1.1  Library Unit Declaration --
 734    --------------------------------------
 735
 736    --  Parsed by P_Compilation_Unit (10.1.1)
 737
 738    ------------------------------------------------
 739    -- 10.1.1  Library Unit Renaming Declaration  --
 740    ------------------------------------------------
 741
 742    --  Parsed by P_Compilation_Unit (10.1.1)
 743
 744    -------------------------------
 745    -- 10.1.1  Library Unit Body --
 746    -------------------------------
 747
 748    --  Parsed by P_Compilation_Unit (10.1.1)
 749
 750    ------------------------------
 751    -- 10.1.1  Parent Unit Name --
 752    ------------------------------
 753
 754    --  Parsed (as a name) by its parent construct
 755
 756    ----------------------------
 757    -- 10.1.2  Context Clause --
 758    ----------------------------
 759
 760    --  CONTEXT_CLAUSE ::= {CONTEXT_ITEM}
 761
 762    --  CONTEXT_ITEM ::= WITH_CLAUSE | USE_CLAUSE | WITH_TYPE_CLAUSE
 763
 764    --  WITH_CLAUSE ::=
 765    --  [LIMITED] [PRIVATE]  with library_unit_NAME {,library_unit_NAME};
 766    --  Note: the two qualifiers are ADA0Y extensions.
 767
 768    --  WITH_TYPE_CLAUSE ::=
 769    --    with type type_NAME is access; | with type type_NAME is tagged;
 770    --  Note: this form is obsolete (old GNAT extension).
 771
 772    --  Error recovery: Cannot raise Error_Resync
 773
 774    function P_Context_Clause return List_Id is
 775       Item_List   : List_Id;
 776       Has_Limited : Boolean := False;
 777       Has_Private : Boolean := False;
 778       Scan_State  : Saved_Scan_State;
 779       With_Node   : Node_Id;
 780       First_Flag  : Boolean;
 781
 782    begin
 783       Item_List := New_List;
 784
 785       --  Get keyword casing from WITH keyword in case not set yet
 786
 787       if Token = Tok_With then
 788          Set_Keyword_Casing (Current_Source_File, Determine_Token_Casing);
 789       end if;
 790
 791       --  Loop through context items
 792
 793       loop
 794          if Style_Check then Style.Check_Indentation; end if;
 795
 796          --  Gather any pragmas appearing in the context clause
 797
 798          P_Pragmas_Opt (Item_List);
 799
 800          --  Processing for WITH clause
 801
 802          --  Ada0Y (AI-50217): First check for LIMITED WITH, PRIVATE WITH,
 803          --  or both.
 804
 805          if Token = Tok_Limited then
 806             Has_Limited := True;
 807             Has_Private := False;
 808             Scan; -- past LIMITED
 809
 810             --  In the context, LIMITED can only appear in a with_clause
 811
 812             if Token = Tok_Private then
 813                Has_Private := True;
 814                Scan;  -- past PRIVATE
 815             end if;
 816
 817             if Token /= Tok_With then
 818                Error_Msg_SC ("unexpected LIMITED ignored");
 819             end if;
 820
 821             if not Extensions_Allowed then
 822                Error_Msg_SP ("`LIMITED WITH` is an Ada0X extension");
 823                Error_Msg_SP
 824                  ("\unit must be compiled with -gnatX switch");
 825
 826             end if;
 827
 828          elsif Token = Tok_Private then
 829             Has_Limited := False;
 830             Has_Private := True;
 831             Save_Scan_State (Scan_State);
 832             Scan;  -- past PRIVATE
 833
 834             if Token /= Tok_With then
 835
 836                --  Keyword is beginning of private child unit
 837
 838                Restore_Scan_State (Scan_State); -- to PRIVATE
 839                return Item_List;
 840
 841             elsif not Extensions_Allowed then
 842                Error_Msg_SP ("`PRIVATE WITH` is an Ada0X extension");
 843                Error_Msg_SP
 844                  ("\unit must be compiled with -gnatX switch");
 845             end if;
 846
 847          else
 848             Has_Limited := False;
 849             Has_Private := False;
 850          end if;
 851
 852          if Token = Tok_With then
 853             Scan; -- past WITH
 854
 855             if Token = Tok_Type then
 856
 857                --  WITH TYPE is an extension
 858
 859                if not Extensions_Allowed then
 860                   Error_Msg_SP ("`WITH TYPE` is a non-standard extension");
 861                   Error_Msg_SP ("\unit must be compiled with -gnatX switch");
 862                end if;
 863
 864                Scan;  -- past TYPE
 865                With_Node := New_Node (N_With_Type_Clause, Token_Ptr);
 866                Append (With_Node, Item_List);
 867                Set_Name (With_Node, P_Qualified_Simple_Name);
 868
 869                T_Is;
 870
 871                if Token = Tok_Tagged then
 872                   Set_Tagged_Present (With_Node);
 873                   Scan;
 874
 875                elsif Token = Tok_Access then
 876                   Scan;
 877
 878                else
 879                   Error_Msg_SC ("expect tagged or access qualifier");
 880                end if;
 881
 882                TF_Semicolon;
 883
 884             else
 885                First_Flag := True;
 886
 887                --  Loop through names in one with clause, generating a separate
 888                --  N_With_Clause node for each nam encountered.
 889
 890                loop
 891                   With_Node := New_Node (N_With_Clause, Token_Ptr);
 892                   Append (With_Node, Item_List);
 893
 894                   --  Note that we allow with'ing of child units, even in
 895                   --  Ada 83 mode, since presumably if this is not desired,
 896                   --  then the compilation of the child unit itself is the
 897                   --  place where such an "error" should be caught.
 898
 899                   Set_Name (With_Node, P_Qualified_Simple_Name);
 900                   Set_First_Name (With_Node, First_Flag);
 901                   Set_Limited_Present (With_Node, Has_Limited);
 902                   Set_Private_Present (With_Node, Has_Private);
 903                   First_Flag := False;
 904
 905                   --  All done if no comma
 906
 907                   exit when Token /= Tok_Comma;
 908
 909                   --  If comma is followed by compilation unit token
 910                   --  or by USE, or PRAGMA, then it should have been a
 911                   --  semicolon after all
 912
 913                   Save_Scan_State (Scan_State);
 914                   Scan; -- past comma
 915
 916                   if Token in Token_Class_Cunit
 917                     or else Token = Tok_Use
 918                     or else Token = Tok_Pragma
 919                   then
 920                      Restore_Scan_State (Scan_State);
 921                      exit;
 922                   end if;
 923                end loop;
 924
 925                Set_Last_Name (With_Node, True);
 926                TF_Semicolon;
 927             end if;
 928
 929          --  Processing for USE clause
 930
 931          elsif Token = Tok_Use then
 932             Append (P_Use_Clause, Item_List);
 933
 934          --  Anything else is end of context clause
 935
 936          else
 937             exit;
 938          end if;
 939       end loop;
 940
 941       return Item_List;
 942    end P_Context_Clause;
 943
 944    --------------------------
 945    -- 10.1.2  Context Item --
 946    --------------------------
 947
 948    --  Parsed by P_Context_Clause (10.1.2)
 949
 950    -------------------------
 951    -- 10.1.2  With Clause --
 952    -------------------------
 953
 954    --  Parsed by P_Context_Clause (10.1.2)
 955
 956    -----------------------
 957    -- 10.1.3  Body Stub --
 958    -----------------------
 959
 960    --  Subprogram stub parsed by P_Subprogram (6.1)
 961    --  Package stub parsed by P_Package (7.1)
 962    --  Task stub parsed by P_Task (9.1)
 963    --  Protected stub parsed by P_Protected (9.4)
 964
 965    ----------------------------------
 966    -- 10.1.3  Subprogram Body Stub --
 967    ----------------------------------
 968
 969    --  Parsed by P_Subprogram (6.1)
 970
 971    -------------------------------
 972    -- 10.1.3  Package Body Stub --
 973    -------------------------------
 974
 975    --  Parsed by P_Package (7.1)
 976
 977    ----------------------------
 978    -- 10.1.3  Task Body Stub --
 979    ----------------------------
 980
 981    --  Parsed by P_Task (9.1)
 982
 983    ---------------------------------
 984    -- 10.1.3  Protected Body Stub --
 985    ---------------------------------
 986
 987    --  Parsed by P_Protected (9.4)
 988
 989    ---------------------
 990    -- 10.1.3  Subunit --
 991    ---------------------
 992
 993    --  SUBUNIT ::= separate (PARENT_UNIT_NAME) PROPER_BODY
 994
 995    --  PARENT_UNIT_NAME ::= NAME
 996
 997    --  The caller has checked that the initial token is SEPARATE
 998
 999    --  Error recovery: cannot raise Error_Resync
1000
1001    function P_Subunit return Node_Id is
1002       Subunit_Node : Node_Id;
1003       Body_Node    : Node_Id;
1004
1005    begin
1006       Subunit_Node := New_Node (N_Subunit, Token_Ptr);
1007       Body_Node := Error; -- in case no good body found
1008       Scan; -- past SEPARATE;
1009
1010       T_Left_Paren;
1011       Set_Name (Subunit_Node, P_Qualified_Simple_Name);
1012       T_Right_Paren;
1013
1014       if Token = Tok_Semicolon then
1015          Error_Msg_SC ("unexpected semicolon ignored");
1016          Scan;
1017       end if;
1018
1019       if Token = Tok_Function or else Token = Tok_Procedure then
1020          Body_Node := P_Subprogram (Pf_Pbod);
1021
1022       elsif Token = Tok_Package then
1023          Body_Node := P_Package (Pf_Pbod);
1024
1025       elsif Token = Tok_Protected then
1026          Scan; -- past PROTECTED
1027
1028          if Token = Tok_Body then
1029             Body_Node := P_Protected;
1030          else
1031             Error_Msg_AP ("BODY expected");
1032             return Error;
1033          end if;
1034
1035       elsif Token = Tok_Task then
1036          Scan; -- past TASK
1037
1038          if Token = Tok_Body then
1039             Body_Node := P_Task;
1040          else
1041             Error_Msg_AP ("BODY expected");
1042             return Error;
1043          end if;
1044
1045       else
1046          Error_Msg_SC ("proper body expected");
1047          return Error;
1048       end if;
1049
1050       Set_Proper_Body  (Subunit_Node, Body_Node);
1051       return Subunit_Node;
1052
1053    end P_Subunit;
1054
1055    ------------------
1056    -- Set_Location --
1057    ------------------
1058
1059    function Set_Location return Source_Ptr is
1060       Physical   : Boolean;
1061       Loc        : Source_Ptr;
1062       Scan_State : Saved_Scan_State;
1063
1064    begin
1065       --  A special check. If the first token is pragma, and this is a
1066       --  Source_Reference pragma, then do NOT eat previous comments, since
1067       --  the Source_Reference pragma is required to be the first line in
1068       --  the source file.
1069
1070       if Token = Tok_Pragma then
1071          Save_Scan_State (Scan_State);
1072          Scan; --  past Pragma
1073
1074          if Token = Tok_Identifier
1075            and then Token_Name = Name_Source_Reference
1076          then
1077             Restore_Scan_State (Scan_State);
1078             return Token_Ptr;
1079          end if;
1080
1081          Restore_Scan_State (Scan_State);
1082       end if;
1083
1084       --  Otherwise acquire previous comments and blank lines
1085
1086       if Prev_Token = No_Token then
1087          return Source_First (Current_Source_File);
1088
1089       else
1090          Loc := Prev_Token_Ptr;
1091          loop
1092             exit when Loc = Token_Ptr;
1093
1094             if Source (Loc) in Line_Terminator then
1095                Skip_Line_Terminators (Loc, Physical);
1096                exit when Physical;
1097             end if;
1098
1099             Loc := Loc + 1;
1100          end loop;
1101
1102          return Loc;
1103       end if;
1104    end Set_Location;
1105
1106    ------------------
1107    -- Unit_Display --
1108    ------------------
1109
1110    --  The format of the generated line, as expected by GNATCHOP is
1111
1112    --    Unit {unit} line {line}, file offset {offs} [, SR], file name {file}
1113
1114    --  where
1115
1116    --     {unit}     unit name with terminating (spec) or (body)
1117    --     {line}     starting line number
1118    --     {offs}     offset to start of text in file
1119    --     {file}     source file name
1120
1121    --  The SR parameter is present only if a source reference pragma was
1122    --  scanned for this unit. The significance is that gnatchop should not
1123    --  attempt to add another one.
1124
1125    procedure Unit_Display
1126      (Cunit      : Node_Id;
1127       Loc        : Source_Ptr;
1128       SR_Present : Boolean)
1129    is
1130       Unum : constant Unit_Number_Type    := Get_Cunit_Unit_Number (Cunit);
1131       Sind : constant Source_File_Index   := Source_Index (Unum);
1132       Unam : constant Unit_Name_Type      := Unit_Name (Unum);
1133
1134    begin
1135       if List_Units then
1136          Write_Str ("Unit ");
1137          Write_Unit_Name (Unit_Name (Unum));
1138          Unit_Location (Sind, Loc);
1139
1140          if SR_Present then
1141             Write_Str (", SR");
1142          end if;
1143
1144          Write_Str (", file name ");
1145          Write_Name (Get_File_Name (Unam, Nkind (Unit (Cunit)) = N_Subunit));
1146          Write_Eol;
1147       end if;
1148    end Unit_Display;
1149
1150    -------------------
1151    -- Unit_Location --
1152    -------------------
1153
1154    procedure Unit_Location (Sind : Source_File_Index; Loc : Source_Ptr) is
1155       Line : constant Logical_Line_Number := Get_Logical_Line_Number (Loc);
1156       --  Should the above be the physical line number ???
1157
1158    begin
1159       Write_Str (" line ");
1160       Write_Int (Int (Line));
1161
1162       Write_Str (", file offset ");
1163       Write_Int (Int (Loc) - Int (Source_First (Sind)));
1164    end Unit_Location;
1165
1166 end Ch10;