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