gcc/ada/par-ch6.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P A R . C H 6                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.1 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 pragma Style_Checks (All_Checks);
  30 --  Turn off subprogram body ordering check. Subprograms are in order
  31 --  by RM section rather than alphabetical
  32
  33 with Sinfo.CN; use Sinfo.CN;
  34
  35 separate (Par)
  36 package body Ch6 is
  37
  38    --  Local subprograms, used only in this chapter
  39
  40    function P_Defining_Designator        return Node_Id;
  41    function P_Defining_Operator_Symbol   return Node_Id;
  42
  43    procedure Check_Junk_Semicolon_Before_Return;
  44    --  Check for common error of junk semicolon before RETURN keyword of
  45    --  function specification. If present, skip over it with appropriate
  46    --  error message, leaving Scan_Ptr pointing to the RETURN after. This
  47    --  routine also deals with a possibly misspelled version of Return.
  48
  49    ----------------------------------------
  50    -- Check_Junk_Semicolon_Before_Return --
  51    ----------------------------------------
  52
  53    procedure Check_Junk_Semicolon_Before_Return is
  54       Scan_State : Saved_Scan_State;
  55
  56    begin
  57       if Token = Tok_Semicolon then
  58          Save_Scan_State (Scan_State);
  59          Scan; -- past the semicolon
  60
  61          if Token = Tok_Return then
  62             Restore_Scan_State (Scan_State);
  63             Error_Msg_SC ("Unexpected semicolon ignored");
  64             Scan; -- rescan past junk semicolon
  65
  66          else
  67             Restore_Scan_State (Scan_State);
  68          end if;
  69
  70       elsif Bad_Spelling_Of (Tok_Return) then
  71          null;
  72       end if;
  73    end Check_Junk_Semicolon_Before_Return;
  74
  75    -----------------------------------------------------
  76    -- 6.1  Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) --
  77    -----------------------------------------------------
  78
  79    --  This routine scans out a subprogram declaration, subprogram body,
  80    --  subprogram renaming declaration or subprogram generic instantiation.
  81
  82    --  SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION;
  83
  84    --  ABSTRACT_SUBPROGRAM_DECLARATION ::=
  85    --    SUBPROGRAM_SPECIFICATION is abstract;
  86
  87    --  SUBPROGRAM_SPECIFICATION ::=
  88    --      procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
  89    --    | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
  90
  91    --  PARAMETER_PROFILE ::= [FORMAL_PART]
  92
  93    --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
  94
  95    --  SUBPROGRAM_BODY ::=
  96    --    SUBPROGRAM_SPECIFICATION is
  97    --      DECLARATIVE_PART
  98    --    begin
  99    --      HANDLED_SEQUENCE_OF_STATEMENTS
 100    --    end [DESIGNATOR];
 101
 102    --  SUBPROGRAM_RENAMING_DECLARATION ::=
 103    --    SUBPROGRAM_SPECIFICATION renames callable_entity_NAME;
 104
 105    --  SUBPROGRAM_BODY_STUB ::=
 106    --    SUBPROGRAM_SPECIFICATION is separate;
 107
 108    --  GENERIC_INSTANTIATION ::=
 109    --    procedure DEFINING_PROGRAM_UNIT_NAME is
 110    --      new generic_procedure_NAME [GENERIC_ACTUAL_PART];
 111    --  | function DEFINING_DESIGNATOR is
 112    --      new generic_function_NAME [GENERIC_ACTUAL_PART];
 113
 114    --  The value in Pf_Flags indicates which of these possible declarations
 115    --  is acceptable to the caller:
 116
 117    --    Pf_Flags.Decl                 Set if declaration OK
 118    --    Pf_Flags.Gins                 Set if generic instantiation OK
 119    --    Pf_Flags.Pbod                 Set if proper body OK
 120    --    Pf_Flags.Rnam                 Set if renaming declaration OK
 121    --    Pf_Flags.Stub                 Set if body stub OK
 122
 123    --  If an inappropriate form is encountered, it is scanned out but an
 124    --  error message indicating that it is appearing in an inappropriate
 125    --  context is issued. The only possible values for Pf_Flags are those
 126    --  defined as constants in the Par package.
 127
 128    --  The caller has checked that the initial token is FUNCTION or PROCEDURE
 129
 130    --  Error recovery: cannot raise Error_Resync
 131
 132    function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is
 133       Specification_Node : Node_Id;
 134       Name_Node   : Node_Id;
 135       Fpart_List  : List_Id;
 136       Fpart_Sloc  : Source_Ptr;
 137       Return_Node : Node_Id;
 138       Inst_Node   : Node_Id;
 139       Body_Node   : Node_Id;
 140       Decl_Node   : Node_Id;
 141       Rename_Node : Node_Id;
 142       Absdec_Node : Node_Id;
 143       Stub_Node   : Node_Id;
 144       Fproc_Sloc  : Source_Ptr;
 145       Func        : Boolean;
 146       Scan_State  : Saved_Scan_State;
 147
 148    begin
 149       --  Set up scope stack entry. Note that the Labl field will be set later
 150
 151       SIS_Entry_Active := False;
 152       SIS_Missing_Semicolon_Message := No_Error_Msg;
 153       Push_Scope_Stack;
 154       Scope.Table (Scope.Last).Sloc := Token_Ptr;
 155       Scope.Table (Scope.Last).Etyp := E_Name;
 156       Scope.Table (Scope.Last).Ecol := Start_Column;
 157       Scope.Table (Scope.Last).Lreq := False;
 158
 159       Func := (Token = Tok_Function);
 160       Fproc_Sloc := Token_Ptr;
 161       Scan; -- past FUNCTION or PROCEDURE
 162       Ignore (Tok_Type);
 163       Ignore (Tok_Body);
 164
 165       if Func then
 166          Name_Node := P_Defining_Designator;
 167
 168          if Nkind (Name_Node) = N_Defining_Operator_Symbol
 169            and then Scope.Last = 1
 170          then
 171             Error_Msg_SP ("operator symbol not allowed at library level");
 172             Name_Node := New_Entity (N_Defining_Identifier, Sloc (Name_Node));
 173
 174             --  Set name from file name, we need some junk name, and that's
 175             --  as good as anything. This is only approximate, since we do
 176             --  not do anything with non-standard name translations.
 177
 178             Get_Name_String (File_Name (Current_Source_File));
 179
 180             for J in 1 .. Name_Len loop
 181                if Name_Buffer (J) = '.' then
 182                   Name_Len := J - 1;
 183                   exit;
 184                end if;
 185             end loop;
 186
 187             Set_Chars (Name_Node, Name_Find);
 188             Set_Error_Posted (Name_Node);
 189          end if;
 190
 191       else
 192          Name_Node := P_Defining_Program_Unit_Name;
 193       end if;
 194
 195       Scope.Table (Scope.Last).Labl := Name_Node;
 196
 197       if Token = Tok_Colon then
 198          Error_Msg_SC ("redundant colon ignored");
 199          Scan; -- past colon
 200       end if;
 201
 202       --  Deal with generic instantiation, the one case in which we do not
 203       --  have a subprogram specification as part of whatever we are parsing
 204
 205       if Token = Tok_Is then
 206          Save_Scan_State (Scan_State); -- at the IS
 207          T_Is; -- checks for redundant IS's
 208
 209          if Token = Tok_New then
 210             if not Pf_Flags.Gins then
 211                Error_Msg_SC ("generic instantiation not allowed here!");
 212             end if;
 213
 214             Scan; -- past NEW
 215
 216             if Func then
 217                Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
 218                Set_Name (Inst_Node, P_Function_Name);
 219             else
 220                Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc);
 221                Set_Name (Inst_Node, P_Qualified_Simple_Name);
 222             end if;
 223
 224             Set_Defining_Unit_Name (Inst_Node, Name_Node);
 225             Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
 226             TF_Semicolon;
 227             Pop_Scope_Stack; -- Don't need scope stack entry in this case
 228             return Inst_Node;
 229
 230          else
 231             Restore_Scan_State (Scan_State); -- to the IS
 232          end if;
 233       end if;
 234
 235       --  If not a generic instantiation, then we definitely have a subprogram
 236       --  specification (all possibilities at this stage include one here)
 237
 238       Fpart_Sloc := Token_Ptr;
 239
 240       Check_Misspelling_Of (Tok_Return);
 241
 242       --  Scan formal part. First a special error check. If we have an
 243       --  identifier here, then we have a definite error. If this identifier
 244       --  is on the same line as the designator, then we assume it is the
 245       --  first formal after a missing left parenthesis
 246
 247       if Token = Tok_Identifier
 248         and then not Token_Is_At_Start_Of_Line
 249       then
 250             T_Left_Paren; -- to generate message
 251             Fpart_List := P_Formal_Part;
 252
 253       --  Otherwise scan out an optional formal part in the usual manner
 254
 255       else
 256          Fpart_List := P_Parameter_Profile;
 257       end if;
 258
 259       --  We treat what we have as a function specification if FUNCTION was
 260       --  used, or if a RETURN is present. This gives better error recovery
 261       --  since later RETURN statements will be valid in either case.
 262
 263       Check_Junk_Semicolon_Before_Return;
 264       Return_Node := Error;
 265
 266       if Token = Tok_Return then
 267          if not Func then
 268             Error_Msg ("PROCEDURE should be FUNCTION", Fproc_Sloc);
 269             Func := True;
 270          end if;
 271
 272          Scan; -- past RETURN
 273          Return_Node := P_Subtype_Mark;
 274          No_Constraint;
 275
 276       else
 277          if Func then
 278             Ignore (Tok_Right_Paren);
 279             TF_Return;
 280          end if;
 281       end if;
 282
 283       if Func then
 284          Specification_Node :=
 285            New_Node (N_Function_Specification, Fproc_Sloc);
 286          Set_Subtype_Mark (Specification_Node, Return_Node);
 287
 288       else
 289          Specification_Node :=
 290            New_Node (N_Procedure_Specification, Fproc_Sloc);
 291       end if;
 292
 293       Set_Defining_Unit_Name (Specification_Node, Name_Node);
 294       Set_Parameter_Specifications (Specification_Node, Fpart_List);
 295
 296       --  Error check: barriers not allowed on protected functions/procedures
 297
 298       if Token = Tok_When then
 299          if Func then
 300             Error_Msg_SC ("barrier not allowed on function, only on entry");
 301          else
 302             Error_Msg_SC ("barrier not allowed on procedure, only on entry");
 303          end if;
 304
 305          Scan; -- past WHEN
 306          Discard_Junk_Node (P_Expression);
 307       end if;
 308
 309       --  Deal with case of semicolon ending a subprogram declaration
 310
 311       if Token = Tok_Semicolon then
 312          if not Pf_Flags.Decl then
 313             T_Is;
 314          end if;
 315
 316          Scan; -- past semicolon
 317
 318          --  If semicolon is immediately followed by IS, then ignore the
 319          --  semicolon, and go process the body.
 320
 321          if Token = Tok_Is then
 322             Error_Msg_SP ("unexpected semicolon ignored");
 323             T_Is; -- ignroe redundant IS's
 324             goto Subprogram_Body;
 325
 326          --  If BEGIN follows in an appropriate column, we immediately
 327          --  commence the error action of assuming that the previous
 328          --  subprogram declaration should have been a subprogram body,
 329          --  i.e. that the terminating semicolon should have been IS.
 330
 331          elsif Token = Tok_Begin
 332             and then Start_Column >= Scope.Table (Scope.Last).Ecol
 333          then
 334             Error_Msg_SP (""";"" should be IS!");
 335             goto Subprogram_Body;
 336
 337          else
 338             goto Subprogram_Declaration;
 339          end if;
 340
 341       --  Case of not followed by semicolon
 342
 343       else
 344          --  Subprogram renaming declaration case
 345
 346          Check_Misspelling_Of (Tok_Renames);
 347
 348          if Token = Tok_Renames then
 349             if not Pf_Flags.Rnam then
 350                Error_Msg_SC ("renaming declaration not allowed here!");
 351             end if;
 352
 353             Rename_Node :=
 354               New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr);
 355             Scan; -- past RENAMES
 356             Set_Name (Rename_Node, P_Name);
 357             Set_Specification (Rename_Node, Specification_Node);
 358             TF_Semicolon;
 359             Pop_Scope_Stack;
 360             return Rename_Node;
 361
 362          --  Case of IS following subprogram specification
 363
 364          elsif Token = Tok_Is then
 365             T_Is; -- ignore redundant Is's
 366
 367             if Token_Name = Name_Abstract then
 368                Check_95_Keyword (Tok_Abstract, Tok_Semicolon);
 369             end if;
 370
 371             --  Deal nicely with (now obsolete) use of <> in place of abstract
 372
 373             if Token = Tok_Box then
 374                Error_Msg_SC ("ABSTRACT expected");
 375                Token := Tok_Abstract;
 376             end if;
 377
 378             --  Abstract subprogram declaration case
 379
 380             if Token = Tok_Abstract then
 381                Absdec_Node :=
 382                  New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr);
 383                Set_Specification (Absdec_Node, Specification_Node);
 384                Pop_Scope_Stack; -- discard unneeded entry
 385                Scan; -- past ABSTRACT
 386                TF_Semicolon;
 387                return Absdec_Node;
 388
 389             --  Check for IS NEW with Formal_Part present and handle nicely
 390
 391             elsif Token = Tok_New then
 392                Error_Msg
 393                  ("formal part not allowed in instantiation", Fpart_Sloc);
 394                Scan; -- past NEW
 395
 396                if Func then
 397                   Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
 398                else
 399                   Inst_Node :=
 400                     New_Node (N_Procedure_Instantiation, Fproc_Sloc);
 401                end if;
 402
 403                Set_Defining_Unit_Name (Inst_Node, Name_Node);
 404                Set_Name (Inst_Node, P_Name);
 405                Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
 406                TF_Semicolon;
 407                Pop_Scope_Stack; -- Don't need scope stack entry in this case
 408                return Inst_Node;
 409
 410             else
 411                goto Subprogram_Body;
 412             end if;
 413
 414          --  Here we have a missing IS or missing semicolon, we always guess
 415          --  a missing semicolon, since we are pretty good at fixing up a
 416          --  semicolon which should really be an IS
 417
 418          else
 419             Error_Msg_AP ("missing "";""");
 420             SIS_Missing_Semicolon_Message := Get_Msg_Id;
 421             goto Subprogram_Declaration;
 422          end if;
 423       end if;
 424
 425       --  Processing for subprogram body
 426
 427       <<Subprogram_Body>>
 428          if not Pf_Flags.Pbod then
 429             Error_Msg_SP ("subprogram body not allowed here!");
 430          end if;
 431
 432          --  Subprogram body stub case
 433
 434          if Separate_Present then
 435             if not Pf_Flags.Stub then
 436                Error_Msg_SC ("body stub not allowed here!");
 437             end if;
 438
 439             if Nkind (Name_Node) = N_Defining_Operator_Symbol then
 440                Error_Msg
 441                  ("operator symbol cannot be used as subunit name",
 442                   Sloc (Name_Node));
 443             end if;
 444
 445             Stub_Node :=
 446               New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node));
 447             Set_Specification (Stub_Node, Specification_Node);
 448             Scan; -- past SEPARATE
 449             Pop_Scope_Stack;
 450             TF_Semicolon;
 451             return Stub_Node;
 452
 453          --  Subprogram body case
 454
 455          else
 456             --  Here is the test for a suspicious IS (i.e. one that looks
 457             --  like it might more properly be a semicolon). See separate
 458             --  section discussing use of IS instead of semicolon in
 459             --  package Parse.
 460
 461             if (Token in Token_Class_Declk
 462                   or else
 463                 Token = Tok_Identifier)
 464               and then Start_Column <= Scope.Table (Scope.Last).Ecol
 465               and then Scope.Last /= 1
 466             then
 467                Scope.Table (Scope.Last).Etyp := E_Suspicious_Is;
 468                Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr;
 469             end if;
 470
 471             Body_Node :=
 472               New_Node (N_Subprogram_Body, Sloc (Specification_Node));
 473             Set_Specification (Body_Node, Specification_Node);
 474             Parse_Decls_Begin_End (Body_Node);
 475             return Body_Node;
 476          end if;
 477
 478       --  Processing for subprogram declaration
 479
 480       <<Subprogram_Declaration>>
 481          Decl_Node :=
 482            New_Node (N_Subprogram_Declaration, Sloc (Specification_Node));
 483          Set_Specification (Decl_Node, Specification_Node);
 484
 485          --  If this is a context in which a subprogram body is permitted,
 486          --  set active SIS entry in case (see section titled "Handling
 487          --  Semicolon Used in Place of IS" in body of Parser package)
 488          --  Note that SIS_Missing_Semicolon_Message is already set properly.
 489
 490          if Pf_Flags.Pbod then
 491             SIS_Labl := Scope.Table (Scope.Last).Labl;
 492             SIS_Sloc := Scope.Table (Scope.Last).Sloc;
 493             SIS_Ecol := Scope.Table (Scope.Last).Ecol;
 494             SIS_Declaration_Node := Decl_Node;
 495             SIS_Semicolon_Sloc := Prev_Token_Ptr;
 496             SIS_Entry_Active := True;
 497          end if;
 498
 499          Pop_Scope_Stack;
 500          return Decl_Node;
 501
 502    end P_Subprogram;
 503
 504    ---------------------------------
 505    -- 6.1  Subprogram Declaration --
 506    ---------------------------------
 507
 508    --  Parsed by P_Subprogram (6.1)
 509
 510    ------------------------------------------
 511    -- 6.1  Abstract Subprogram Declaration --
 512    ------------------------------------------
 513
 514    --  Parsed by P_Subprogram (6.1)
 515
 516    -----------------------------------
 517    -- 6.1  Subprogram Specification --
 518    -----------------------------------
 519
 520    --  SUBPROGRAM_SPECIFICATION ::=
 521    --      procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
 522    --    | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE
 523
 524    --  PARAMETER_PROFILE ::= [FORMAL_PART]
 525
 526    --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK
 527
 528    --  Subprogram specifications that appear in subprogram declarations
 529    --  are parsed by P_Subprogram (6.1). This routine is used in other
 530    --  contexts where subprogram specifications occur.
 531
 532    --  Note: this routine does not affect the scope stack in any way
 533
 534    --  Error recovery: can raise Error_Resync
 535
 536    function P_Subprogram_Specification return Node_Id is
 537       Specification_Node : Node_Id;
 538
 539    begin
 540       if Token = Tok_Function then
 541          Specification_Node := New_Node (N_Function_Specification, Token_Ptr);
 542          Scan; -- past FUNCTION
 543          Ignore (Tok_Body);
 544          Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator);
 545          Set_Parameter_Specifications
 546            (Specification_Node, P_Parameter_Profile);
 547          Check_Junk_Semicolon_Before_Return;
 548          TF_Return;
 549          Set_Subtype_Mark (Specification_Node, P_Subtype_Mark);
 550          No_Constraint;
 551          return Specification_Node;
 552
 553       elsif Token = Tok_Procedure then
 554          Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr);
 555          Scan; -- past PROCEDURE
 556          Ignore (Tok_Body);
 557          Set_Defining_Unit_Name
 558            (Specification_Node, P_Defining_Program_Unit_Name);
 559          Set_Parameter_Specifications
 560            (Specification_Node, P_Parameter_Profile);
 561          return Specification_Node;
 562
 563       else
 564          Error_Msg_SC ("subprogram specification expected");
 565          raise Error_Resync;
 566       end if;
 567    end P_Subprogram_Specification;
 568
 569    ---------------------
 570    -- 6.1  Designator --
 571    ---------------------
 572
 573    --  DESIGNATOR ::=
 574    --    [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL
 575
 576    --  The caller has checked that the initial token is an identifier,
 577    --  operator symbol, or string literal. Note that we don't bother to
 578    --  do much error diagnosis in this routine, since it is only used for
 579    --  the label on END lines, and the routines in package Par.Endh will
 580    --  check that the label is appropriate.
 581
 582    --  Error recovery: cannot raise Error_Resync
 583
 584    function P_Designator return Node_Id is
 585       Ident_Node  : Node_Id;
 586       Name_Node   : Node_Id;
 587       Prefix_Node : Node_Id;
 588
 589       function Real_Dot return Boolean;
 590       --  Tests if a current token is an interesting period, i.e. is followed
 591       --  by an identifier or operator symbol or string literal. If not, it is
 592       --  probably just incorrect punctuation to be caught by our caller. Note
 593       --  that the case of an operator symbol or string literal is also an
 594       --  error, but that is an error that we catch here. If the result is
 595       --  True, a real dot has been scanned and we are positioned past it,
 596       --  if the result is False, the scan position is unchanged.
 597
 598       function Real_Dot return Boolean is
 599          Scan_State  : Saved_Scan_State;
 600
 601       begin
 602          if Token /= Tok_Dot then
 603             return False;
 604
 605          else
 606             Save_Scan_State (Scan_State);
 607             Scan; -- past dot
 608
 609             if Token = Tok_Identifier
 610               or else Token = Tok_Operator_Symbol
 611               or else Token = Tok_String_Literal
 612             then
 613                return True;
 614
 615             else
 616                Restore_Scan_State (Scan_State);
 617                return False;
 618             end if;
 619          end if;
 620       end Real_Dot;
 621
 622    --  Start of processing for P_Designator
 623
 624    begin
 625       Ident_Node := Token_Node;
 626       Scan; -- past initial token
 627
 628       if Prev_Token = Tok_Operator_Symbol
 629         or else Prev_Token = Tok_String_Literal
 630         or else not Real_Dot
 631       then
 632          return Ident_Node;
 633
 634       --  Child name case
 635
 636       else
 637          Prefix_Node := Ident_Node;
 638
 639          --  Loop through child names, on entry to this loop, Prefix contains
 640          --  the name scanned so far, and Ident_Node is the last identifier.
 641
 642          loop
 643             Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
 644             Set_Prefix (Name_Node, Prefix_Node);
 645             Ident_Node := P_Identifier;
 646             Set_Selector_Name (Name_Node, Ident_Node);
 647             Prefix_Node := Name_Node;
 648             exit when not Real_Dot;
 649          end loop;
 650
 651          --  On exit from the loop, Ident_Node is the last identifier scanned,
 652          --  i.e. the defining identifier, and Prefix_Node is a node for the
 653          --  entire name, structured (incorrectly!) as a selected component.
 654
 655          Name_Node := Prefix (Prefix_Node);
 656          Change_Node (Prefix_Node, N_Designator);
 657          Set_Name (Prefix_Node, Name_Node);
 658          Set_Identifier (Prefix_Node, Ident_Node);
 659          return Prefix_Node;
 660       end if;
 661
 662    exception
 663       when Error_Resync =>
 664          while Token = Tok_Dot or else Token = Tok_Identifier loop
 665             Scan;
 666          end loop;
 667
 668          return Error;
 669    end P_Designator;
 670
 671    ------------------------------
 672    -- 6.1  Defining Designator --
 673    ------------------------------
 674
 675    --  DEFINING_DESIGNATOR ::=
 676    --    DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL
 677
 678    --  Error recovery: cannot raise Error_Resync
 679
 680    function P_Defining_Designator return Node_Id is
 681    begin
 682       if Token = Tok_Operator_Symbol then
 683          return P_Defining_Operator_Symbol;
 684
 685       elsif Token = Tok_String_Literal then
 686          Error_Msg_SC ("invalid operator name");
 687          Scan; -- past junk string
 688          return Error;
 689
 690       else
 691          return P_Defining_Program_Unit_Name;
 692       end if;
 693    end P_Defining_Designator;
 694
 695    -------------------------------------
 696    -- 6.1  Defining Program Unit Name --
 697    -------------------------------------
 698
 699    --  DEFINING_PROGRAM_UNIT_NAME ::=
 700    --    [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER
 701
 702    --  Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level
 703
 704    --  Error recovery: cannot raise Error_Resync
 705
 706    function P_Defining_Program_Unit_Name return Node_Id is
 707       Ident_Node  : Node_Id;
 708       Name_Node   : Node_Id;
 709       Prefix_Node : Node_Id;
 710
 711    begin
 712       --  Set identifier casing if not already set and scan initial identifier
 713
 714       if Token = Tok_Identifier
 715         and then Identifier_Casing (Current_Source_File) = Unknown
 716       then
 717          Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing);
 718       end if;
 719
 720       Ident_Node := P_Identifier;
 721       Merge_Identifier (Ident_Node, Tok_Return);
 722
 723       --  Normal case (not child library unit name)
 724
 725       if Token /= Tok_Dot then
 726          Change_Identifier_To_Defining_Identifier (Ident_Node);
 727          return Ident_Node;
 728
 729       --  Child library unit name case
 730
 731       else
 732          if Scope.Last > 1 then
 733             Error_Msg_SP ("child unit allowed only at library level");
 734             raise Error_Resync;
 735
 736          elsif Ada_83 then
 737             Error_Msg_SP ("(Ada 83) child unit not allowed!");
 738
 739          end if;
 740
 741          Prefix_Node := Ident_Node;
 742
 743          --  Loop through child names, on entry to this loop, Prefix contains
 744          --  the name scanned so far, and Ident_Node is the last identifier.
 745
 746          loop
 747             exit when Token /= Tok_Dot;
 748             Name_Node := New_Node (N_Selected_Component, Token_Ptr);
 749             Scan; -- past period
 750             Set_Prefix (Name_Node, Prefix_Node);
 751             Ident_Node := P_Identifier;
 752             Set_Selector_Name (Name_Node, Ident_Node);
 753             Prefix_Node := Name_Node;
 754          end loop;
 755
 756          --  On exit from the loop, Ident_Node is the last identifier scanned,
 757          --  i.e. the defining identifier, and Prefix_Node is a node for the
 758          --  entire name, structured (incorrectly!) as a selected component.
 759
 760          Name_Node := Prefix (Prefix_Node);
 761          Change_Node (Prefix_Node, N_Defining_Program_Unit_Name);
 762          Set_Name (Prefix_Node, Name_Node);
 763          Change_Identifier_To_Defining_Identifier (Ident_Node);
 764          Set_Defining_Identifier (Prefix_Node, Ident_Node);
 765
 766          --  All set with unit name parsed
 767
 768          return Prefix_Node;
 769       end if;
 770
 771    exception
 772       when Error_Resync =>
 773          while Token = Tok_Dot or else Token = Tok_Identifier loop
 774             Scan;
 775          end loop;
 776
 777          return Error;
 778    end P_Defining_Program_Unit_Name;
 779
 780    --------------------------
 781    -- 6.1  Operator Symbol --
 782    --------------------------
 783
 784    --  OPERATOR_SYMBOL ::= STRING_LITERAL
 785
 786    --  Operator symbol is returned by the scanner as Tok_Operator_Symbol
 787
 788    -----------------------------------
 789    -- 6.1  Defining Operator Symbol --
 790    -----------------------------------
 791
 792    --  DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL
 793
 794    --  The caller has checked that the initial symbol is an operator symbol
 795
 796    function P_Defining_Operator_Symbol return Node_Id is
 797       Op_Node : Node_Id;
 798
 799    begin
 800       Op_Node := Token_Node;
 801       Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node);
 802       Scan; -- past operator symbol
 803       return Op_Node;
 804    end P_Defining_Operator_Symbol;
 805
 806    ----------------------------
 807    -- 6.1  Parameter_Profile --
 808    ----------------------------
 809
 810    --  PARAMETER_PROFILE ::= [FORMAL_PART]
 811
 812    --  Empty is returned if no formal part is present
 813
 814    --  Error recovery: cannot raise Error_Resync
 815
 816    function P_Parameter_Profile return List_Id is
 817    begin
 818       if Token = Tok_Left_Paren then
 819          Scan; -- part left paren
 820          return P_Formal_Part;
 821       else
 822          return No_List;
 823       end if;
 824    end P_Parameter_Profile;
 825
 826    ---------------------------------------
 827    -- 6.1  Parameter And Result Profile --
 828    ---------------------------------------
 829
 830    --  Parsed by its parent construct, which uses P_Parameter_Profile to
 831    --  parse the parameters, and P_Subtype_Mark to parse the return type.
 832
 833    ----------------------
 834    -- 6.1  Formal part --
 835    ----------------------
 836
 837    --  FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION})
 838
 839    --  PARAMETER_SPECIFICATION ::=
 840    --    DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK
 841    --      [:= DEFAULT_EXPRESSION]
 842    --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
 843    --      [:= DEFAULT_EXPRESSION]
 844
 845    --  This scans the construct Formal_Part. The caller has already checked
 846    --  that the initial token is a left parenthesis, and skipped past it, so
 847    --  that on entry Token is the first token following the left parenthesis.
 848
 849    --  Error recovery: cannot raise Error_Resync
 850
 851    function P_Formal_Part return List_Id is
 852       Specification_List : List_Id;
 853       Specification_Node : Node_Id;
 854       Scan_State         : Saved_Scan_State;
 855       Num_Idents         : Nat;
 856       Ident              : Nat;
 857       Ident_Sloc         : Source_Ptr;
 858
 859       Idents : array (Int range 1 .. 4096) of Entity_Id;
 860       --  This array holds the list of defining identifiers. The upper bound
 861       --  of 4096 is intended to be essentially infinite, and we do not even
 862       --  bother to check for it being exceeded.
 863
 864    begin
 865       Specification_List := New_List;
 866
 867       Specification_Loop : loop
 868          begin
 869             if Token = Tok_Pragma then
 870                P_Pragmas_Misplaced;
 871             end if;
 872
 873             Ignore (Tok_Left_Paren);
 874             Ident_Sloc := Token_Ptr;
 875             Idents (1) := P_Defining_Identifier;
 876             Num_Idents := 1;
 877
 878             Ident_Loop : loop
 879                exit Ident_Loop when Token = Tok_Colon;
 880
 881                --  The only valid tokens are colon and comma, so if we have
 882                --  neither do a bit of investigation to see which is the
 883                --  better choice for insertion.
 884
 885                if Token /= Tok_Comma then
 886
 887                   --  Assume colon if IN or OUT keyword found
 888
 889                   exit Ident_Loop when Token = Tok_In or else Token = Tok_Out;
 890
 891                   --  Otherwise scan ahead
 892
 893                   Save_Scan_State (Scan_State);
 894                   Look_Ahead : loop
 895
 896                      --  If we run into a semicolon, then assume that a
 897                      --  colon was missing, e.g.  Parms (X Y; ...). Also
 898                      --  assume missing colon on EOF (a real disaster!)
 899                      --  and on a right paren, e.g. Parms (X Y), and also
 900                      --  on an assignment symbol, e.g. Parms (X Y := ..)
 901
 902                      if Token = Tok_Semicolon
 903                        or else Token = Tok_Right_Paren
 904                        or else Token = Tok_EOF
 905                        or else Token = Tok_Colon_Equal
 906                      then
 907                         Restore_Scan_State (Scan_State);
 908                         exit Ident_Loop;
 909
 910                      --  If we run into a colon, assume that we had a missing
 911                      --  comma, e.g. Parms (A B : ...). Also assume a missing
 912                      --  comma if we hit another comma, e.g. Parms (A B, C ..)
 913
 914                      elsif Token = Tok_Colon
 915                        or else Token = Tok_Comma
 916                      then
 917                         Restore_Scan_State (Scan_State);
 918                         exit Look_Ahead;
 919                      end if;
 920
 921                      Scan;
 922                   end loop Look_Ahead;
 923                end if;
 924
 925                --  Here if a comma is present, or to be assumed
 926
 927                T_Comma;
 928                Num_Idents := Num_Idents + 1;
 929                Idents (Num_Idents) := P_Defining_Identifier;
 930             end loop Ident_Loop;
 931
 932             --  Fall through the loop on encountering a colon, or deciding
 933             --  that there is a missing colon.
 934
 935             T_Colon;
 936
 937             --  If there are multiple identifiers, we repeatedly scan the
 938             --  type and initialization expression information by resetting
 939             --  the scan pointer (so that we get completely separate trees
 940             --  for each occurrence).
 941
 942             if Num_Idents > 1 then
 943                Save_Scan_State (Scan_State);
 944             end if;
 945
 946             --  Loop through defining identifiers in list
 947
 948             Ident := 1;
 949
 950             Ident_List_Loop : loop
 951                Specification_Node :=
 952                  New_Node (N_Parameter_Specification, Ident_Sloc);
 953                Set_Defining_Identifier (Specification_Node, Idents (Ident));
 954
 955                if Token = Tok_Access then
 956                   if Ada_83 then
 957                      Error_Msg_SC ("(Ada 83) access parameters not allowed");
 958                   end if;
 959
 960                   Set_Parameter_Type
 961                     (Specification_Node, P_Access_Definition);
 962
 963                else
 964                   P_Mode (Specification_Node);
 965
 966                   if Token = Tok_Procedure
 967                        or else
 968                      Token = Tok_Function
 969                   then
 970                      Error_Msg_SC ("formal subprogram parameter not allowed");
 971                      Scan;
 972
 973                      if Token = Tok_Left_Paren then
 974                         Discard_Junk_List (P_Formal_Part);
 975                      end if;
 976
 977                      if Token = Tok_Return then
 978                         Scan;
 979                         Discard_Junk_Node (P_Subtype_Mark);
 980                      end if;
 981
 982                      Set_Parameter_Type (Specification_Node, Error);
 983
 984                   else
 985                      Set_Parameter_Type (Specification_Node, P_Subtype_Mark);
 986                      No_Constraint;
 987                   end if;
 988                end if;
 989
 990                Set_Expression (Specification_Node, Init_Expr_Opt (True));
 991
 992                if Ident > 1 then
 993                   Set_Prev_Ids (Specification_Node, True);
 994                end if;
 995
 996                if Ident < Num_Idents then
 997                   Set_More_Ids (Specification_Node, True);
 998                end if;
 999
1000                Append (Specification_Node, Specification_List);
1001                exit Ident_List_Loop when Ident = Num_Idents;
1002                Ident := Ident + 1;
1003                Restore_Scan_State (Scan_State);
1004             end loop Ident_List_Loop;
1005
1006          exception
1007             when Error_Resync =>
1008                Resync_Semicolon_List;
1009          end;
1010
1011          if Token = Tok_Semicolon then
1012             Scan; -- past semicolon
1013
1014             --  If we have RETURN or IS after the semicolon, then assume
1015             --  that semicolon should have been a right parenthesis and exit
1016
1017             if Token = Tok_Is or else Token = Tok_Return then
1018                Error_Msg_SP ("expected "")"" in place of "";""");
1019                exit Specification_Loop;
1020             end if;
1021
1022          elsif Token = Tok_Right_Paren then
1023             Scan; -- past right paren
1024             exit Specification_Loop;
1025
1026          --  Special check for common error of using comma instead of semicolon
1027
1028          elsif Token = Tok_Comma then
1029             T_Semicolon;
1030             Scan; -- past comma
1031
1032          --  Special check for omitted separator
1033
1034          elsif Token = Tok_Identifier then
1035             T_Semicolon;
1036
1037          --  If nothing sensible, skip to next semicolon or right paren
1038
1039          else
1040             T_Semicolon;
1041             Resync_Semicolon_List;
1042
1043             if Token = Tok_Semicolon then
1044                Scan; -- past semicolon
1045             else
1046                T_Right_Paren;
1047                exit Specification_Loop;
1048             end if;
1049          end if;
1050       end loop Specification_Loop;
1051
1052       return Specification_List;
1053    end P_Formal_Part;
1054
1055    ----------------------------------
1056    -- 6.1  Parameter Specification --
1057    ----------------------------------
1058
1059    --  Parsed by P_Formal_Part (6.1)
1060
1061    ---------------
1062    -- 6.1  Mode --
1063    ---------------
1064
1065    --  MODE ::= [in] | in out | out
1066
1067    --  There is no explicit node in the tree for the Mode. Instead the
1068    --  In_Present and Out_Present flags are set in the parent node to
1069    --  record the presence of keywords specifying the mode.
1070
1071    --  Error_Recovery: cannot raise Error_Resync
1072
1073    procedure P_Mode (Node : Node_Id) is
1074    begin
1075       if Token = Tok_In then
1076          Scan; -- past IN
1077          Set_In_Present (Node, True);
1078       end if;
1079
1080       if Token = Tok_Out then
1081          Scan; -- past OUT
1082          Set_Out_Present (Node, True);
1083       end if;
1084
1085       if Token = Tok_In then
1086          Error_Msg_SC ("IN must precede OUT in parameter mode");
1087          Scan; -- past IN
1088          Set_In_Present (Node, True);
1089       end if;
1090    end P_Mode;
1091
1092    --------------------------
1093    -- 6.3  Subprogram Body --
1094    --------------------------
1095
1096    --  Parsed by P_Subprogram (6.1)
1097
1098    -----------------------------------
1099    -- 6.4  Procedure Call Statement --
1100    -----------------------------------
1101
1102    --  Parsed by P_Sequence_Of_Statements (5.1)
1103
1104    ------------------------
1105    -- 6.4  Function Call --
1106    ------------------------
1107
1108    --  Parsed by P_Call_Or_Name (4.1)
1109
1110    --------------------------------
1111    -- 6.4  Actual Parameter Part --
1112    --------------------------------
1113
1114    --  Parsed by P_Call_Or_Name (4.1)
1115
1116    --------------------------------
1117    -- 6.4  Parameter Association --
1118    --------------------------------
1119
1120    --  Parsed by P_Call_Or_Name (4.1)
1121
1122    ------------------------------------
1123    -- 6.4  Explicit Actual Parameter --
1124    ------------------------------------
1125
1126    --  Parsed by P_Call_Or_Name (4.1)
1127
1128    ---------------------------
1129    -- 6.5  Return Statement --
1130    ---------------------------
1131
1132    --  RETURN_STATEMENT ::= return [EXPRESSION];
1133
1134    --  The caller has checked that the initial token is RETURN
1135
1136    --  Error recovery: can raise Error_Resync
1137
1138    function P_Return_Statement return Node_Id is
1139       Return_Node : Node_Id;
1140
1141    begin
1142       Return_Node := New_Node (N_Return_Statement, Token_Ptr);
1143
1144       --  Sloc points to RETURN
1145       --  Expression (Op3)
1146
1147       Scan; -- past RETURN
1148
1149       if Token /= Tok_Semicolon then
1150
1151          --  If no semicolon, then scan an expression, except that
1152          --  we avoid trying to scan an expression if we are at an
1153          --  expression terminator since in that case the best error
1154          --  message is probably that we have a missing semicolon.
1155
1156          if Token not in Token_Class_Eterm then
1157             Set_Expression (Return_Node, P_Expression_No_Right_Paren);
1158          end if;
1159       end if;
1160
1161       TF_Semicolon;
1162       return Return_Node;
1163    end P_Return_Statement;
1164
1165 end Ch6;