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