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