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