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-2013, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26pragma Style_Checks (All_Checks); 27-- Turn off subprogram body ordering check. Subprograms are in order 28-- by RM section rather than alphabetical 29 30with Sinfo.CN; use Sinfo.CN; 31 32separate (Par) 33package body Ch6 is 34 35 -- Local subprograms, used only in this chapter 36 37 function P_Defining_Designator return Node_Id; 38 function P_Defining_Operator_Symbol return Node_Id; 39 function P_Return_Object_Declaration return Node_Id; 40 41 procedure P_Return_Subtype_Indication (Decl_Node : Node_Id); 42 -- Decl_Node is a N_Object_Declaration. Set the Null_Exclusion_Present and 43 -- Object_Definition fields of Decl_Node. 44 45 procedure Check_Junk_Semicolon_Before_Return; 46 -- Check for common error of junk semicolon before RETURN keyword of 47 -- function specification. If present, skip over it with appropriate error 48 -- message, leaving Scan_Ptr pointing to the RETURN after. This routine 49 -- also deals with a possibly misspelled version of Return. 50 51 procedure No_Constraint_Maybe_Expr_Func; 52 -- Called after scanning return subtype to check for missing constraint, 53 -- taking into account the possibility of an occurrence of an expression 54 -- function where the IS has been forgotten. 55 56 ---------------------------------------- 57 -- Check_Junk_Semicolon_Before_Return -- 58 ---------------------------------------- 59 60 procedure Check_Junk_Semicolon_Before_Return is 61 Scan_State : Saved_Scan_State; 62 63 begin 64 if Token = Tok_Semicolon then 65 Save_Scan_State (Scan_State); 66 Scan; -- past the semicolon 67 68 if Token = Tok_Return then 69 Restore_Scan_State (Scan_State); 70 Error_Msg_SC -- CODEFIX 71 ("|extra "";"" ignored"); 72 Scan; -- rescan past junk semicolon 73 else 74 Restore_Scan_State (Scan_State); 75 end if; 76 end if; 77 end Check_Junk_Semicolon_Before_Return; 78 79 ----------------------------------- 80 -- No_Constraint_Maybe_Expr_Func -- 81 ----------------------------------- 82 83 procedure No_Constraint_Maybe_Expr_Func is 84 begin 85 -- If we have a left paren at the start of the line, then assume this is 86 -- the case of an expression function with missing IS. We do not have to 87 -- diagnose the missing IS, that is done elsewhere. We do this game in 88 -- Ada 2012 mode where expression functions are legal. 89 90 if Token = Tok_Left_Paren 91 and Ada_Version >= Ada_2012 92 and Token_Is_At_Start_Of_Line 93 then 94 -- One exception if we have "(token .." then this is a constraint 95 96 declare 97 Scan_State : Saved_Scan_State; 98 99 begin 100 Save_Scan_State (Scan_State); 101 Scan; -- past left paren 102 Scan; -- past following token 103 104 -- If we have "(token .." then restore scan state and treat as 105 -- unexpected constraint. 106 107 if Token = Tok_Dot_Dot then 108 Restore_Scan_State (Scan_State); 109 No_Constraint; 110 111 -- Otherwise we treat this as an expression function 112 113 else 114 Restore_Scan_State (Scan_State); 115 end if; 116 end; 117 118 -- Otherwise use standard routine to check for no constraint present 119 120 else 121 No_Constraint; 122 end if; 123 end No_Constraint_Maybe_Expr_Func; 124 125 ----------------------------------------------------- 126 -- 6.1 Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) -- 127 ----------------------------------------------------- 128 129 -- This routine scans out a subprogram declaration, subprogram body, 130 -- subprogram renaming declaration or subprogram generic instantiation. 131 -- It also handles the new Ada 2012 expression function form 132 133 -- SUBPROGRAM_DECLARATION ::= 134 -- SUBPROGRAM_SPECIFICATION 135 -- [ASPECT_SPECIFICATIONS]; 136 137 -- ABSTRACT_SUBPROGRAM_DECLARATION ::= 138 -- SUBPROGRAM_SPECIFICATION is abstract 139 -- [ASPECT_SPECIFICATIONS]; 140 141 -- SUBPROGRAM_SPECIFICATION ::= 142 -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE 143 -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE 144 145 -- PARAMETER_PROFILE ::= [FORMAL_PART] 146 147 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK 148 149 -- SUBPROGRAM_BODY ::= 150 -- SUBPROGRAM_SPECIFICATION [ASPECT_SPECIFICATIONS] is 151 -- DECLARATIVE_PART 152 -- begin 153 -- HANDLED_SEQUENCE_OF_STATEMENTS 154 -- end [DESIGNATOR]; 155 156 -- SUBPROGRAM_RENAMING_DECLARATION ::= 157 -- SUBPROGRAM_SPECIFICATION renames callable_entity_NAME 158 -- [ASPECT_SPECIFICATIONS]; 159 160 -- SUBPROGRAM_BODY_STUB ::= 161 -- SUBPROGRAM_SPECIFICATION is separate 162 -- [ASPECT_SPECIFICATIONS]; 163 164 -- GENERIC_INSTANTIATION ::= 165 -- procedure DEFINING_PROGRAM_UNIT_NAME is 166 -- new generic_procedure_NAME [GENERIC_ACTUAL_PART] 167 -- [ASPECT_SPECIFICATIONS]; 168 -- | function DEFINING_DESIGNATOR is 169 -- new generic_function_NAME [GENERIC_ACTUAL_PART] 170 -- [ASPECT_SPECIFICATIONS]; 171 172 -- NULL_PROCEDURE_DECLARATION ::= 173 -- SUBPROGRAM_SPECIFICATION is null; 174 175 -- Null procedures are an Ada 2005 feature. A null procedure declaration 176 -- is classified as a basic declarative item, but it is parsed here, with 177 -- other subprogram constructs. 178 179 -- EXPRESSION_FUNCTION ::= 180 -- FUNCTION SPECIFICATION IS (EXPRESSION) 181 -- [ASPECT_SPECIFICATIONS]; 182 183 -- The value in Pf_Flags indicates which of these possible declarations 184 -- is acceptable to the caller: 185 186 -- Pf_Flags.Decl Set if declaration OK 187 -- Pf_Flags.Gins Set if generic instantiation OK 188 -- Pf_Flags.Pbod Set if proper body OK 189 -- Pf_Flags.Rnam Set if renaming declaration OK 190 -- Pf_Flags.Stub Set if body stub OK 191 -- Pf_Flags.Pexp Set if expression function OK 192 193 -- If an inappropriate form is encountered, it is scanned out but an 194 -- error message indicating that it is appearing in an inappropriate 195 -- context is issued. The only possible values for Pf_Flags are those 196 -- defined as constants in the Par package. 197 198 -- The caller has checked that the initial token is FUNCTION, PROCEDURE, 199 -- NOT or OVERRIDING. 200 201 -- Error recovery: cannot raise Error_Resync 202 203 function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is 204 Specification_Node : Node_Id; 205 Name_Node : Node_Id; 206 Aspects : List_Id; 207 Fpart_List : List_Id; 208 Fpart_Sloc : Source_Ptr; 209 Result_Not_Null : Boolean := False; 210 Result_Node : Node_Id; 211 Inst_Node : Node_Id; 212 Body_Node : Node_Id; 213 Decl_Node : Node_Id; 214 Rename_Node : Node_Id; 215 Absdec_Node : Node_Id; 216 Stub_Node : Node_Id; 217 Fproc_Sloc : Source_Ptr; 218 Func : Boolean; 219 Scan_State : Saved_Scan_State; 220 221 -- Flags for optional overriding indication. Two flags are needed, 222 -- to distinguish positive and negative overriding indicators from 223 -- the absence of any indicator. 224 225 Is_Overriding : Boolean := False; 226 Not_Overriding : Boolean := False; 227 228 begin 229 -- Set up scope stack entry. Note that the Labl field will be set later 230 231 SIS_Entry_Active := False; 232 SIS_Missing_Semicolon_Message := No_Error_Msg; 233 Push_Scope_Stack; 234 Scope.Table (Scope.Last).Sloc := Token_Ptr; 235 Scope.Table (Scope.Last).Etyp := E_Name; 236 Scope.Table (Scope.Last).Ecol := Start_Column; 237 Scope.Table (Scope.Last).Lreq := False; 238 239 Aspects := Empty_List; 240 241 -- Ada 2005: Scan leading NOT OVERRIDING indicator 242 243 if Token = Tok_Not then 244 Scan; -- past NOT 245 246 if Token = Tok_Overriding then 247 Scan; -- past OVERRIDING 248 Not_Overriding := True; 249 250 -- Overriding keyword used in non Ada 2005 mode 251 252 elsif Token = Tok_Identifier 253 and then Token_Name = Name_Overriding 254 then 255 Error_Msg_SC ("overriding indicator is an Ada 2005 extension"); 256 Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); 257 Scan; -- past Overriding 258 Not_Overriding := True; 259 260 else 261 Error_Msg_SC -- CODEFIX 262 ("OVERRIDING expected!"); 263 end if; 264 265 -- Ada 2005: scan leading OVERRIDING indicator 266 267 -- Note: in the case of OVERRIDING keyword used in Ada 95 mode, the 268 -- declaration circuit already gave an error message and changed the 269 -- token to Tok_Overriding. 270 271 elsif Token = Tok_Overriding then 272 Scan; -- past OVERRIDING 273 Is_Overriding := True; 274 end if; 275 276 if Is_Overriding or else Not_Overriding then 277 278 -- Note that if we are not in Ada_2005 mode, error messages have 279 -- already been given, so no need to give another message here. 280 281 -- An overriding indicator is allowed for subprogram declarations, 282 -- bodies (including subunits), renamings, stubs, and instantiations. 283 -- The test against Pf_Decl_Pbod is added to account for the case of 284 -- subprograms declared in a protected type, where only subprogram 285 -- declarations and bodies can occur. The Pf_Pbod case is for 286 -- subunits. 287 288 if Pf_Flags /= Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp 289 and then 290 Pf_Flags /= Pf_Decl_Pbod_Pexp 291 and then 292 Pf_Flags /= Pf_Pbod_Pexp 293 then 294 Error_Msg_SC ("overriding indicator not allowed here!"); 295 296 elsif Token /= Tok_Function and then Token /= Tok_Procedure then 297 Error_Msg_SC -- CODEFIX 298 ("FUNCTION or PROCEDURE expected!"); 299 end if; 300 end if; 301 302 Func := (Token = Tok_Function); 303 Fproc_Sloc := Token_Ptr; 304 Scan; -- past FUNCTION or PROCEDURE 305 Ignore (Tok_Type); 306 Ignore (Tok_Body); 307 308 if Func then 309 Name_Node := P_Defining_Designator; 310 311 if Nkind (Name_Node) = N_Defining_Operator_Symbol 312 and then Scope.Last = 1 313 then 314 Error_Msg_SP ("operator symbol not allowed at library level"); 315 Name_Node := New_Entity (N_Defining_Identifier, Sloc (Name_Node)); 316 317 -- Set name from file name, we need some junk name, and that's 318 -- as good as anything. This is only approximate, since we do 319 -- not do anything with non-standard name translations. 320 321 Get_Name_String (File_Name (Current_Source_File)); 322 323 for J in 1 .. Name_Len loop 324 if Name_Buffer (J) = '.' then 325 Name_Len := J - 1; 326 exit; 327 end if; 328 end loop; 329 330 Set_Chars (Name_Node, Name_Find); 331 Set_Error_Posted (Name_Node); 332 end if; 333 334 else 335 Name_Node := P_Defining_Program_Unit_Name; 336 end if; 337 338 Scope.Table (Scope.Last).Labl := Name_Node; 339 Ignore (Tok_Colon); 340 341 -- Deal with generic instantiation, the one case in which we do not 342 -- have a subprogram specification as part of whatever we are parsing 343 344 if Token = Tok_Is then 345 Save_Scan_State (Scan_State); -- at the IS 346 T_Is; -- checks for redundant IS 347 348 if Token = Tok_New then 349 if not Pf_Flags.Gins then 350 Error_Msg_SC ("generic instantiation not allowed here!"); 351 end if; 352 353 Scan; -- past NEW 354 355 if Func then 356 Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); 357 Set_Name (Inst_Node, P_Function_Name); 358 else 359 Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc); 360 Set_Name (Inst_Node, P_Qualified_Simple_Name); 361 end if; 362 363 Set_Defining_Unit_Name (Inst_Node, Name_Node); 364 Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); 365 P_Aspect_Specifications (Inst_Node); 366 Pop_Scope_Stack; -- Don't need scope stack entry in this case 367 368 if Is_Overriding then 369 Set_Must_Override (Inst_Node); 370 371 elsif Not_Overriding then 372 Set_Must_Not_Override (Inst_Node); 373 end if; 374 375 return Inst_Node; 376 377 else 378 Restore_Scan_State (Scan_State); -- to the IS 379 end if; 380 end if; 381 382 -- If not a generic instantiation, then we definitely have a subprogram 383 -- specification (all possibilities at this stage include one here) 384 385 Fpart_Sloc := Token_Ptr; 386 387 Check_Misspelling_Of (Tok_Return); 388 389 -- Scan formal part. First a special error check. If we have an 390 -- identifier here, then we have a definite error. If this identifier 391 -- is on the same line as the designator, then we assume it is the 392 -- first formal after a missing left parenthesis 393 394 if Token = Tok_Identifier 395 and then not Token_Is_At_Start_Of_Line 396 then 397 T_Left_Paren; -- to generate message 398 Fpart_List := P_Formal_Part; 399 400 -- Otherwise scan out an optional formal part in the usual manner 401 402 else 403 Fpart_List := P_Parameter_Profile; 404 end if; 405 406 -- We treat what we have as a function specification if FUNCTION was 407 -- used, or if a RETURN is present. This gives better error recovery 408 -- since later RETURN statements will be valid in either case. 409 410 Check_Junk_Semicolon_Before_Return; 411 Result_Node := Error; 412 413 if Token = Tok_Return then 414 if not Func then 415 Error_Msg -- CODEFIX 416 ("PROCEDURE should be FUNCTION", Fproc_Sloc); 417 Func := True; 418 end if; 419 420 Scan; -- past RETURN 421 422 Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) 423 424 -- Ada 2005 (AI-318-02) 425 426 if Token = Tok_Access then 427 if Ada_Version < Ada_2005 then 428 Error_Msg_SC 429 ("anonymous access result type is an Ada 2005 extension"); 430 Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); 431 end if; 432 433 Result_Node := P_Access_Definition (Result_Not_Null); 434 435 else 436 Result_Node := P_Subtype_Mark; 437 No_Constraint_Maybe_Expr_Func; 438 end if; 439 440 else 441 -- Skip extra parenthesis at end of formal part 442 443 Ignore (Tok_Right_Paren); 444 445 -- For function, scan result subtype 446 447 if Func then 448 TF_Return; 449 450 if Prev_Token = Tok_Return then 451 Result_Node := P_Subtype_Mark; 452 end if; 453 end if; 454 end if; 455 456 if Func then 457 Specification_Node := 458 New_Node (N_Function_Specification, Fproc_Sloc); 459 460 Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null); 461 Set_Result_Definition (Specification_Node, Result_Node); 462 463 else 464 Specification_Node := 465 New_Node (N_Procedure_Specification, Fproc_Sloc); 466 end if; 467 468 Set_Defining_Unit_Name (Specification_Node, Name_Node); 469 Set_Parameter_Specifications (Specification_Node, Fpart_List); 470 471 if Is_Overriding then 472 Set_Must_Override (Specification_Node); 473 474 elsif Not_Overriding then 475 Set_Must_Not_Override (Specification_Node); 476 end if; 477 478 -- Error check: barriers not allowed on protected functions/procedures 479 480 if Token = Tok_When then 481 if Func then 482 Error_Msg_SC ("barrier not allowed on function, only on entry"); 483 else 484 Error_Msg_SC ("barrier not allowed on procedure, only on entry"); 485 end if; 486 487 Scan; -- past WHEN 488 Discard_Junk_Node (P_Expression); 489 end if; 490 491 -- Deal with semicolon followed by IS. We want to treat this as IS 492 493 if Token = Tok_Semicolon then 494 Save_Scan_State (Scan_State); 495 Scan; -- past semicolon 496 497 if Token = Tok_Is then 498 Error_Msg_SP -- CODEFIX 499 ("extra "";"" ignored"); 500 else 501 Restore_Scan_State (Scan_State); 502 end if; 503 end if; 504 505 -- Subprogram declaration ended by aspect specifications 506 507 if Aspect_Specifications_Present then 508 goto Subprogram_Declaration; 509 510 -- Deal with case of semicolon ending a subprogram declaration 511 512 elsif Token = Tok_Semicolon then 513 if not Pf_Flags.Decl then 514 T_Is; 515 end if; 516 517 Save_Scan_State (Scan_State); 518 Scan; -- past semicolon 519 520 -- If semicolon is immediately followed by IS, then ignore the 521 -- semicolon, and go process the body. 522 523 if Token = Tok_Is then 524 Error_Msg_SP -- CODEFIX 525 ("|extra "";"" ignored"); 526 T_Is; -- scan past IS 527 goto Subprogram_Body; 528 529 -- If BEGIN follows in an appropriate column, we immediately 530 -- commence the error action of assuming that the previous 531 -- subprogram declaration should have been a subprogram body, 532 -- i.e. that the terminating semicolon should have been IS. 533 534 elsif Token = Tok_Begin 535 and then Start_Column >= Scope.Table (Scope.Last).Ecol 536 then 537 Error_Msg_SP -- CODEFIX 538 ("|"";"" should be IS!"); 539 goto Subprogram_Body; 540 541 else 542 Restore_Scan_State (Scan_State); 543 goto Subprogram_Declaration; 544 end if; 545 546 -- Case of not followed by semicolon 547 548 else 549 -- Subprogram renaming declaration case 550 551 Check_Misspelling_Of (Tok_Renames); 552 553 if Token = Tok_Renames then 554 if not Pf_Flags.Rnam then 555 Error_Msg_SC ("renaming declaration not allowed here!"); 556 end if; 557 558 Rename_Node := 559 New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr); 560 Scan; -- past RENAMES 561 Set_Name (Rename_Node, P_Name); 562 Set_Specification (Rename_Node, Specification_Node); 563 P_Aspect_Specifications (Rename_Node); 564 TF_Semicolon; 565 Pop_Scope_Stack; 566 return Rename_Node; 567 568 -- Case of IS following subprogram specification 569 570 elsif Token = Tok_Is then 571 T_Is; -- ignore redundant Is's 572 573 if Token_Name = Name_Abstract then 574 Check_95_Keyword (Tok_Abstract, Tok_Semicolon); 575 end if; 576 577 -- Deal nicely with (now obsolete) use of <> in place of abstract 578 579 if Token = Tok_Box then 580 Error_Msg_SC -- CODEFIX 581 ("ABSTRACT expected"); 582 Token := Tok_Abstract; 583 end if; 584 585 -- Abstract subprogram declaration case 586 587 if Token = Tok_Abstract then 588 Absdec_Node := 589 New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr); 590 Set_Specification (Absdec_Node, Specification_Node); 591 Pop_Scope_Stack; -- discard unneeded entry 592 Scan; -- past ABSTRACT 593 P_Aspect_Specifications (Absdec_Node); 594 return Absdec_Node; 595 596 -- Ada 2005 (AI-248): Parse a null procedure declaration 597 598 elsif Token = Tok_Null then 599 if Ada_Version < Ada_2005 then 600 Error_Msg_SP ("null procedures are an Ada 2005 extension"); 601 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 602 end if; 603 604 Scan; -- past NULL 605 606 if Func then 607 Error_Msg_SP ("only procedures can be null"); 608 else 609 Set_Null_Present (Specification_Node); 610 end if; 611 612 goto Subprogram_Declaration; 613 614 -- Check for IS NEW with Formal_Part present and handle nicely 615 616 elsif Token = Tok_New then 617 Error_Msg 618 ("formal part not allowed in instantiation", Fpart_Sloc); 619 Scan; -- past NEW 620 621 if Func then 622 Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc); 623 else 624 Inst_Node := 625 New_Node (N_Procedure_Instantiation, Fproc_Sloc); 626 end if; 627 628 Set_Defining_Unit_Name (Inst_Node, Name_Node); 629 Set_Name (Inst_Node, P_Name); 630 Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt); 631 TF_Semicolon; 632 Pop_Scope_Stack; -- Don't need scope stack entry in this case 633 return Inst_Node; 634 635 else 636 goto Subprogram_Body; 637 end if; 638 639 -- Aspect specifications present 640 641 elsif Aspect_Specifications_Present then 642 goto Subprogram_Declaration; 643 644 -- Here we have a missing IS or missing semicolon 645 646 else 647 -- If the next token is a left paren at the start of a line, then 648 -- this is almost certainly the start of the expression for an 649 -- expression function, so in this case guess a missing IS. 650 651 if Token = Tok_Left_Paren and then Token_Is_At_Start_Of_Line then 652 Error_Msg_AP -- CODEFIX 653 ("missing IS"); 654 655 -- In all other cases, we guess a missing semicolon, since we are 656 -- good at fixing up a semicolon which should really be an IS. 657 658 else 659 Error_Msg_AP -- CODEFIX 660 ("|missing "";"""); 661 SIS_Missing_Semicolon_Message := Get_Msg_Id; 662 goto Subprogram_Declaration; 663 end if; 664 end if; 665 end if; 666 667 -- Processing for stub or subprogram body or expression function 668 669 <<Subprogram_Body>> 670 671 -- Subprogram body stub case 672 673 if Separate_Present then 674 if not Pf_Flags.Stub then 675 Error_Msg_SC ("body stub not allowed here!"); 676 end if; 677 678 if Nkind (Name_Node) = N_Defining_Operator_Symbol then 679 Error_Msg 680 ("operator symbol cannot be used as subunit name", 681 Sloc (Name_Node)); 682 end if; 683 684 Scan; -- past SEPARATE 685 686 Stub_Node := 687 New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node)); 688 Set_Specification (Stub_Node, Specification_Node); 689 690 if Is_Non_Empty_List (Aspects) then 691 Error_Msg 692 ("aspect specifications must come after SEPARATE", 693 Sloc (First (Aspects))); 694 end if; 695 696 P_Aspect_Specifications (Stub_Node, Semicolon => False); 697 TF_Semicolon; 698 Pop_Scope_Stack; 699 return Stub_Node; 700 701 -- Subprogram body or expression function case 702 703 else 704 Scan_Body_Or_Expression_Function : declare 705 706 Body_Is_Hidden_In_SPARK : Boolean; 707 Hidden_Region_Start : Source_Ptr; 708 709 function Likely_Expression_Function return Boolean; 710 -- Returns True if we have a probable case of an expression 711 -- function omitting the parentheses, if so, returns True 712 -- and emits an appropriate error message, else returns False. 713 714 -------------------------------- 715 -- Likely_Expression_Function -- 716 -------------------------------- 717 718 function Likely_Expression_Function return Boolean is 719 begin 720 -- If currently pointing to BEGIN or a declaration keyword 721 -- or a pragma, then we definitely have a subprogram body. 722 -- This is a common case, so worth testing first. 723 724 if Token = Tok_Begin 725 or else Token in Token_Class_Declk 726 or else Token = Tok_Pragma 727 then 728 return False; 729 730 -- Test for tokens which could only start an expression and 731 -- thus signal the case of a expression function. 732 733 elsif Token in Token_Class_Literal 734 or else Token in Token_Class_Unary_Addop 735 or else Token = Tok_Left_Paren 736 or else Token = Tok_Abs 737 or else Token = Tok_Null 738 or else Token = Tok_New 739 or else Token = Tok_Not 740 then 741 null; 742 743 -- Anything other than an identifier must be a body 744 745 elsif Token /= Tok_Identifier then 746 return False; 747 748 -- Here for an identifier 749 750 else 751 -- If the identifier is the first token on its line, then 752 -- let's assume that we have a missing begin and this is 753 -- intended as a subprogram body. However, if the context 754 -- is a function and the unit is a package declaration, a 755 -- body would be illegal, so try for an unparenthesized 756 -- expression function. 757 758 if Token_Is_At_Start_Of_Line then 759 declare 760 -- The enclosing scope entry is a subprogram spec 761 762 Spec_Node : constant Node_Id := 763 Parent 764 (Scope.Table (Scope.Last).Labl); 765 Lib_Node : Node_Id := Spec_Node; 766 767 begin 768 -- Check whether there is an enclosing scope that 769 -- is a package declaration. 770 771 if Scope.Last > 1 then 772 Lib_Node := 773 Parent (Scope.Table (Scope.Last - 1).Labl); 774 end if; 775 776 if Ada_Version >= Ada_2012 777 and then 778 Nkind (Lib_Node) = N_Package_Specification 779 and then 780 Nkind (Spec_Node) = N_Function_Specification 781 then 782 null; 783 else 784 return False; 785 end if; 786 end; 787 788 -- Otherwise we have to scan ahead. If the identifier is 789 -- followed by a colon or a comma, it is a declaration 790 -- and hence we have a subprogram body. Otherwise assume 791 -- a expression function. 792 793 else 794 declare 795 Scan_State : Saved_Scan_State; 796 Tok : Token_Type; 797 798 begin 799 Save_Scan_State (Scan_State); 800 Scan; -- past identifier 801 Tok := Token; 802 Restore_Scan_State (Scan_State); 803 804 if Tok = Tok_Colon or else Tok = Tok_Comma then 805 return False; 806 end if; 807 end; 808 end if; 809 end if; 810 811 -- Fall through if we have a likely expression function 812 813 Error_Msg_SC 814 ("expression function must be enclosed in parentheses"); 815 return True; 816 end Likely_Expression_Function; 817 818 -- Start of processing for Scan_Body_Or_Expression_Function 819 820 begin 821 -- Expression_Function case 822 823 if Token = Tok_Left_Paren 824 or else Likely_Expression_Function 825 then 826 -- Check expression function allowed here 827 828 if not Pf_Flags.Pexp then 829 Error_Msg_SC ("expression function not allowed here!"); 830 end if; 831 832 -- Check we are in Ada 2012 mode 833 834 Error_Msg_Ada_2012_Feature 835 ("!expression function", Token_Ptr); 836 837 -- Catch an illegal placement of the aspect specification 838 -- list: 839 840 -- function_specification 841 -- [aspect_specification] is (expression); 842 843 -- This case is correctly processed by the parser because 844 -- the expression function first appears as a subprogram 845 -- declaration to the parser. 846 847 if Is_Non_Empty_List (Aspects) then 848 Error_Msg 849 ("aspect specifications must come after parenthesized " 850 & "expression", Sloc (First (Aspects))); 851 end if; 852 853 -- Parse out expression and build expression function 854 855 Body_Node := 856 New_Node 857 (N_Expression_Function, Sloc (Specification_Node)); 858 Set_Specification (Body_Node, Specification_Node); 859 Set_Expression (Body_Node, P_Expression); 860 861 -- Expression functions can carry pre/postconditions 862 863 P_Aspect_Specifications (Body_Node); 864 Pop_Scope_Stack; 865 866 -- Subprogram body case 867 868 else 869 -- Check body allowed here 870 871 if not Pf_Flags.Pbod then 872 Error_Msg_SP ("subprogram body not allowed here!"); 873 end if; 874 875 -- Here is the test for a suspicious IS (i.e. one that 876 -- looks like it might more properly be a semicolon). 877 -- See separate section describing use of IS instead 878 -- of semicolon in package Parse. 879 880 if (Token in Token_Class_Declk 881 or else 882 Token = Tok_Identifier) 883 and then Start_Column <= Scope.Table (Scope.Last).Ecol 884 and then Scope.Last /= 1 885 then 886 Scope.Table (Scope.Last).Etyp := E_Suspicious_Is; 887 Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr; 888 end if; 889 890 -- Build and return subprogram body, parsing declarations 891 -- and statement sequence that belong to the body. 892 893 Body_Node := 894 New_Node (N_Subprogram_Body, Sloc (Specification_Node)); 895 Set_Specification (Body_Node, Specification_Node); 896 897 -- If aspects are present, the specification is parsed as 898 -- a subprogram declaration, and we jump here after seeing 899 -- the keyword IS. Attach asspects previously collected to 900 -- the body. 901 902 if Is_Non_Empty_List (Aspects) then 903 Set_Parent (Aspects, Body_Node); 904 Set_Aspect_Specifications (Body_Node, Aspects); 905 end if; 906 907 -- In SPARK, a HIDE directive can be placed at the beginning 908 -- of a subprogram implementation, thus hiding the 909 -- subprogram body from SPARK tool-set. No violation of the 910 -- SPARK restriction should be issued on nodes in a hidden 911 -- part, which is obtained by marking such hidden parts. 912 913 if Token = Tok_SPARK_Hide then 914 Body_Is_Hidden_In_SPARK := True; 915 Hidden_Region_Start := Token_Ptr; 916 Scan; -- past HIDE directive 917 else 918 Body_Is_Hidden_In_SPARK := False; 919 end if; 920 921 Parse_Decls_Begin_End (Body_Node); 922 923 if Body_Is_Hidden_In_SPARK then 924 Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr); 925 end if; 926 end if; 927 928 return Body_Node; 929 end Scan_Body_Or_Expression_Function; 930 end if; 931 932 -- Processing for subprogram declaration 933 934 <<Subprogram_Declaration>> 935 Decl_Node := 936 New_Node (N_Subprogram_Declaration, Sloc (Specification_Node)); 937 Set_Specification (Decl_Node, Specification_Node); 938 Aspects := Get_Aspect_Specifications (Semicolon => False); 939 940 -- Aspects may be present on a subprogram body. The source parsed 941 -- so far is that of its specification, go parse the body and attach 942 -- the collected aspects, if any, to the body. 943 944 if Token = Tok_Is then 945 Scan; 946 goto Subprogram_Body; 947 948 else 949 if Is_Non_Empty_List (Aspects) then 950 Set_Parent (Aspects, Decl_Node); 951 Set_Aspect_Specifications (Decl_Node, Aspects); 952 end if; 953 954 TF_Semicolon; 955 end if; 956 957 -- If this is a context in which a subprogram body is permitted, 958 -- set active SIS entry in case (see section titled "Handling 959 -- Semicolon Used in Place of IS" in body of Parser package) 960 -- Note that SIS_Missing_Semicolon_Message is already set properly. 961 962 if Pf_Flags.Pbod then 963 SIS_Labl := Scope.Table (Scope.Last).Labl; 964 SIS_Sloc := Scope.Table (Scope.Last).Sloc; 965 SIS_Ecol := Scope.Table (Scope.Last).Ecol; 966 SIS_Declaration_Node := Decl_Node; 967 SIS_Semicolon_Sloc := Prev_Token_Ptr; 968 SIS_Entry_Active := True; 969 end if; 970 971 Pop_Scope_Stack; 972 return Decl_Node; 973 end P_Subprogram; 974 975 --------------------------------- 976 -- 6.1 Subprogram Declaration -- 977 --------------------------------- 978 979 -- Parsed by P_Subprogram (6.1) 980 981 ------------------------------------------ 982 -- 6.1 Abstract Subprogram Declaration -- 983 ------------------------------------------ 984 985 -- Parsed by P_Subprogram (6.1) 986 987 ----------------------------------- 988 -- 6.1 Subprogram Specification -- 989 ----------------------------------- 990 991 -- SUBPROGRAM_SPECIFICATION ::= 992 -- procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE 993 -- | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE 994 995 -- PARAMETER_PROFILE ::= [FORMAL_PART] 996 997 -- PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK 998 999 -- Subprogram specifications that appear in subprogram declarations 1000 -- are parsed by P_Subprogram (6.1). This routine is used in other 1001 -- contexts where subprogram specifications occur. 1002 1003 -- Note: this routine does not affect the scope stack in any way 1004 1005 -- Error recovery: can raise Error_Resync 1006 1007 function P_Subprogram_Specification return Node_Id is 1008 Specification_Node : Node_Id; 1009 Result_Not_Null : Boolean; 1010 Result_Node : Node_Id; 1011 1012 begin 1013 if Token = Tok_Function then 1014 Specification_Node := New_Node (N_Function_Specification, Token_Ptr); 1015 Scan; -- past FUNCTION 1016 Ignore (Tok_Body); 1017 Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator); 1018 Set_Parameter_Specifications 1019 (Specification_Node, P_Parameter_Profile); 1020 Check_Junk_Semicolon_Before_Return; 1021 TF_Return; 1022 1023 Result_Not_Null := P_Null_Exclusion; -- Ada 2005 (AI-231) 1024 1025 -- Ada 2005 (AI-318-02) 1026 1027 if Token = Tok_Access then 1028 if Ada_Version < Ada_2005 then 1029 Error_Msg_SC 1030 ("anonymous access result type is an Ada 2005 extension"); 1031 Error_Msg_SC ("\unit must be compiled with -gnat05 switch"); 1032 end if; 1033 1034 Result_Node := P_Access_Definition (Result_Not_Null); 1035 1036 else 1037 Result_Node := P_Subtype_Mark; 1038 No_Constraint_Maybe_Expr_Func; 1039 end if; 1040 1041 Set_Null_Exclusion_Present (Specification_Node, Result_Not_Null); 1042 Set_Result_Definition (Specification_Node, Result_Node); 1043 return Specification_Node; 1044 1045 elsif Token = Tok_Procedure then 1046 Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr); 1047 Scan; -- past PROCEDURE 1048 Ignore (Tok_Body); 1049 Set_Defining_Unit_Name 1050 (Specification_Node, P_Defining_Program_Unit_Name); 1051 Set_Parameter_Specifications 1052 (Specification_Node, P_Parameter_Profile); 1053 return Specification_Node; 1054 1055 else 1056 Error_Msg_SC ("subprogram specification expected"); 1057 raise Error_Resync; 1058 end if; 1059 end P_Subprogram_Specification; 1060 1061 --------------------- 1062 -- 6.1 Designator -- 1063 --------------------- 1064 1065 -- DESIGNATOR ::= 1066 -- [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL 1067 1068 -- The caller has checked that the initial token is an identifier, 1069 -- operator symbol, or string literal. Note that we don't bother to 1070 -- do much error diagnosis in this routine, since it is only used for 1071 -- the label on END lines, and the routines in package Par.Endh will 1072 -- check that the label is appropriate. 1073 1074 -- Error recovery: cannot raise Error_Resync 1075 1076 function P_Designator return Node_Id is 1077 Ident_Node : Node_Id; 1078 Name_Node : Node_Id; 1079 Prefix_Node : Node_Id; 1080 1081 function Real_Dot return Boolean; 1082 -- Tests if a current token is an interesting period, i.e. is followed 1083 -- by an identifier or operator symbol or string literal. If not, it is 1084 -- probably just incorrect punctuation to be caught by our caller. Note 1085 -- that the case of an operator symbol or string literal is also an 1086 -- error, but that is an error that we catch here. If the result is 1087 -- True, a real dot has been scanned and we are positioned past it, 1088 -- if the result is False, the scan position is unchanged. 1089 1090 -------------- 1091 -- Real_Dot -- 1092 -------------- 1093 1094 function Real_Dot return Boolean is 1095 Scan_State : Saved_Scan_State; 1096 1097 begin 1098 if Token /= Tok_Dot then 1099 return False; 1100 1101 else 1102 Save_Scan_State (Scan_State); 1103 Scan; -- past dot 1104 1105 if Token = Tok_Identifier 1106 or else Token = Tok_Operator_Symbol 1107 or else Token = Tok_String_Literal 1108 then 1109 return True; 1110 1111 else 1112 Restore_Scan_State (Scan_State); 1113 return False; 1114 end if; 1115 end if; 1116 end Real_Dot; 1117 1118 -- Start of processing for P_Designator 1119 1120 begin 1121 Ident_Node := Token_Node; 1122 Scan; -- past initial token 1123 1124 if Prev_Token = Tok_Operator_Symbol 1125 or else Prev_Token = Tok_String_Literal 1126 or else not Real_Dot 1127 then 1128 return Ident_Node; 1129 1130 -- Child name case 1131 1132 else 1133 Prefix_Node := Ident_Node; 1134 1135 -- Loop through child names, on entry to this loop, Prefix contains 1136 -- the name scanned so far, and Ident_Node is the last identifier. 1137 1138 loop 1139 Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr); 1140 Set_Prefix (Name_Node, Prefix_Node); 1141 Ident_Node := P_Identifier; 1142 Set_Selector_Name (Name_Node, Ident_Node); 1143 Prefix_Node := Name_Node; 1144 exit when not Real_Dot; 1145 end loop; 1146 1147 -- On exit from the loop, Ident_Node is the last identifier scanned, 1148 -- i.e. the defining identifier, and Prefix_Node is a node for the 1149 -- entire name, structured (incorrectly) as a selected component. 1150 1151 Name_Node := Prefix (Prefix_Node); 1152 Change_Node (Prefix_Node, N_Designator); 1153 Set_Name (Prefix_Node, Name_Node); 1154 Set_Identifier (Prefix_Node, Ident_Node); 1155 return Prefix_Node; 1156 end if; 1157 1158 exception 1159 when Error_Resync => 1160 while Token = Tok_Dot or else Token = Tok_Identifier loop 1161 Scan; 1162 end loop; 1163 1164 return Error; 1165 end P_Designator; 1166 1167 ------------------------------ 1168 -- 6.1 Defining Designator -- 1169 ------------------------------ 1170 1171 -- DEFINING_DESIGNATOR ::= 1172 -- DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL 1173 1174 -- Error recovery: cannot raise Error_Resync 1175 1176 function P_Defining_Designator return Node_Id is 1177 begin 1178 if Token = Tok_Operator_Symbol then 1179 return P_Defining_Operator_Symbol; 1180 1181 elsif Token = Tok_String_Literal then 1182 Error_Msg_SC ("invalid operator name"); 1183 Scan; -- past junk string 1184 return Error; 1185 1186 else 1187 return P_Defining_Program_Unit_Name; 1188 end if; 1189 end P_Defining_Designator; 1190 1191 ------------------------------------- 1192 -- 6.1 Defining Program Unit Name -- 1193 ------------------------------------- 1194 1195 -- DEFINING_PROGRAM_UNIT_NAME ::= 1196 -- [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER 1197 1198 -- Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level 1199 1200 -- Error recovery: cannot raise Error_Resync 1201 1202 function P_Defining_Program_Unit_Name return Node_Id is 1203 Ident_Node : Node_Id; 1204 Name_Node : Node_Id; 1205 Prefix_Node : Node_Id; 1206 1207 begin 1208 -- Set identifier casing if not already set and scan initial identifier 1209 1210 if Token = Tok_Identifier 1211 and then Identifier_Casing (Current_Source_File) = Unknown 1212 then 1213 Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing); 1214 end if; 1215 1216 Ident_Node := P_Identifier (C_Dot); 1217 Merge_Identifier (Ident_Node, Tok_Return); 1218 1219 -- Normal case (not child library unit name) 1220 1221 if Token /= Tok_Dot then 1222 Change_Identifier_To_Defining_Identifier (Ident_Node); 1223 Warn_If_Standard_Redefinition (Ident_Node); 1224 return Ident_Node; 1225 1226 -- Child library unit name case 1227 1228 else 1229 if Scope.Last > 1 then 1230 Error_Msg_SP ("child unit allowed only at library level"); 1231 raise Error_Resync; 1232 1233 elsif Ada_Version = Ada_83 then 1234 Error_Msg_SP ("(Ada 83) child unit not allowed!"); 1235 1236 end if; 1237 1238 Prefix_Node := Ident_Node; 1239 1240 -- Loop through child names, on entry to this loop, Prefix contains 1241 -- the name scanned so far, and Ident_Node is the last identifier. 1242 1243 loop 1244 exit when Token /= Tok_Dot; 1245 Name_Node := New_Node (N_Selected_Component, Token_Ptr); 1246 Scan; -- past period 1247 Set_Prefix (Name_Node, Prefix_Node); 1248 Ident_Node := P_Identifier (C_Dot); 1249 Set_Selector_Name (Name_Node, Ident_Node); 1250 Prefix_Node := Name_Node; 1251 end loop; 1252 1253 -- On exit from the loop, Ident_Node is the last identifier scanned, 1254 -- i.e. the defining identifier, and Prefix_Node is a node for the 1255 -- entire name, structured (incorrectly) as a selected component. 1256 1257 Name_Node := Prefix (Prefix_Node); 1258 Change_Node (Prefix_Node, N_Defining_Program_Unit_Name); 1259 Set_Name (Prefix_Node, Name_Node); 1260 Change_Identifier_To_Defining_Identifier (Ident_Node); 1261 Warn_If_Standard_Redefinition (Ident_Node); 1262 Set_Defining_Identifier (Prefix_Node, Ident_Node); 1263 1264 -- All set with unit name parsed 1265 1266 return Prefix_Node; 1267 end if; 1268 1269 exception 1270 when Error_Resync => 1271 while Token = Tok_Dot or else Token = Tok_Identifier loop 1272 Scan; 1273 end loop; 1274 1275 return Error; 1276 end P_Defining_Program_Unit_Name; 1277 1278 -------------------------- 1279 -- 6.1 Operator Symbol -- 1280 -------------------------- 1281 1282 -- OPERATOR_SYMBOL ::= STRING_LITERAL 1283 1284 -- Operator symbol is returned by the scanner as Tok_Operator_Symbol 1285 1286 ----------------------------------- 1287 -- 6.1 Defining Operator Symbol -- 1288 ----------------------------------- 1289 1290 -- DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL 1291 1292 -- The caller has checked that the initial symbol is an operator symbol 1293 1294 function P_Defining_Operator_Symbol return Node_Id is 1295 Op_Node : Node_Id; 1296 1297 begin 1298 Op_Node := Token_Node; 1299 Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node); 1300 Scan; -- past operator symbol 1301 return Op_Node; 1302 end P_Defining_Operator_Symbol; 1303 1304 ---------------------------- 1305 -- 6.1 Parameter_Profile -- 1306 ---------------------------- 1307 1308 -- PARAMETER_PROFILE ::= [FORMAL_PART] 1309 1310 -- Empty is returned if no formal part is present 1311 1312 -- Error recovery: cannot raise Error_Resync 1313 1314 function P_Parameter_Profile return List_Id is 1315 begin 1316 if Token = Tok_Left_Paren then 1317 Scan; -- part left paren 1318 return P_Formal_Part; 1319 else 1320 return No_List; 1321 end if; 1322 end P_Parameter_Profile; 1323 1324 --------------------------------------- 1325 -- 6.1 Parameter And Result Profile -- 1326 --------------------------------------- 1327 1328 -- Parsed by its parent construct, which uses P_Parameter_Profile to 1329 -- parse the parameters, and P_Subtype_Mark to parse the return type. 1330 1331 ---------------------- 1332 -- 6.1 Formal part -- 1333 ---------------------- 1334 1335 -- FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION}) 1336 1337 -- PARAMETER_SPECIFICATION ::= 1338 -- DEFINING_IDENTIFIER_LIST : [ALIASED] MODE [NULL_EXCLUSION] 1339 -- SUBTYPE_MARK [:= DEFAULT_EXPRESSION] 1340 -- | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION 1341 -- [:= DEFAULT_EXPRESSION] 1342 1343 -- This scans the construct Formal_Part. The caller has already checked 1344 -- that the initial token is a left parenthesis, and skipped past it, so 1345 -- that on entry Token is the first token following the left parenthesis. 1346 1347 -- Note: The ALIASED keyword is allowed only in Ada 2012 mode (AI 142) 1348 1349 -- Error recovery: cannot raise Error_Resync 1350 1351 function P_Formal_Part return List_Id is 1352 Specification_List : List_Id; 1353 Specification_Node : Node_Id; 1354 Scan_State : Saved_Scan_State; 1355 Num_Idents : Nat; 1356 Ident : Nat; 1357 Ident_Sloc : Source_Ptr; 1358 Not_Null_Present : Boolean := False; 1359 Not_Null_Sloc : Source_Ptr; 1360 1361 Idents : array (Int range 1 .. 4096) of Entity_Id; 1362 -- This array holds the list of defining identifiers. The upper bound 1363 -- of 4096 is intended to be essentially infinite, and we do not even 1364 -- bother to check for it being exceeded. 1365 1366 begin 1367 Specification_List := New_List; 1368 Specification_Loop : loop 1369 begin 1370 if Token = Tok_Pragma then 1371 Error_Msg_SC ("pragma not allowed in formal part"); 1372 Discard_Junk_Node (P_Pragma (Skipping => True)); 1373 end if; 1374 1375 Ignore (Tok_Left_Paren); 1376 Ident_Sloc := Token_Ptr; 1377 Idents (1) := P_Defining_Identifier (C_Comma_Colon); 1378 Num_Idents := 1; 1379 1380 Ident_Loop : loop 1381 exit Ident_Loop when Token = Tok_Colon; 1382 1383 -- The only valid tokens are colon and comma, so if we have 1384 -- neither do a bit of investigation to see which is the 1385 -- better choice for insertion. 1386 1387 if Token /= Tok_Comma then 1388 1389 -- Assume colon if ALIASED, IN or OUT keyword found 1390 1391 exit Ident_Loop when Token = Tok_Aliased or else 1392 Token = Tok_In or else 1393 Token = Tok_Out; 1394 1395 -- Otherwise scan ahead 1396 1397 Save_Scan_State (Scan_State); 1398 Look_Ahead : loop 1399 1400 -- If we run into a semicolon, then assume that a 1401 -- colon was missing, e.g. Parms (X Y; ...). Also 1402 -- assume missing colon on EOF (a real disaster) 1403 -- and on a right paren, e.g. Parms (X Y), and also 1404 -- on an assignment symbol, e.g. Parms (X Y := ..) 1405 1406 if Token = Tok_Semicolon 1407 or else Token = Tok_Right_Paren 1408 or else Token = Tok_EOF 1409 or else Token = Tok_Colon_Equal 1410 then 1411 Restore_Scan_State (Scan_State); 1412 exit Ident_Loop; 1413 1414 -- If we run into a colon, assume that we had a missing 1415 -- comma, e.g. Parms (A B : ...). Also assume a missing 1416 -- comma if we hit another comma, e.g. Parms (A B, C ..) 1417 1418 elsif Token = Tok_Colon 1419 or else Token = Tok_Comma 1420 then 1421 Restore_Scan_State (Scan_State); 1422 exit Look_Ahead; 1423 end if; 1424 1425 Scan; 1426 end loop Look_Ahead; 1427 end if; 1428 1429 -- Here if a comma is present, or to be assumed 1430 1431 T_Comma; 1432 Num_Idents := Num_Idents + 1; 1433 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); 1434 end loop Ident_Loop; 1435 1436 -- Fall through the loop on encountering a colon, or deciding 1437 -- that there is a missing colon. 1438 1439 T_Colon; 1440 1441 -- If there are multiple identifiers, we repeatedly scan the 1442 -- type and initialization expression information by resetting 1443 -- the scan pointer (so that we get completely separate trees 1444 -- for each occurrence). 1445 1446 if Num_Idents > 1 then 1447 Save_Scan_State (Scan_State); 1448 end if; 1449 1450 -- Loop through defining identifiers in list 1451 1452 Ident := 1; 1453 1454 Ident_List_Loop : loop 1455 Specification_Node := 1456 New_Node (N_Parameter_Specification, Ident_Sloc); 1457 Set_Defining_Identifier (Specification_Node, Idents (Ident)); 1458 1459 -- Scan possible ALIASED for Ada 2012 (AI-142) 1460 1461 if Token = Tok_Aliased then 1462 if Ada_Version < Ada_2012 then 1463 Error_Msg_Ada_2012_Feature 1464 ("ALIASED parameter", Token_Ptr); 1465 else 1466 Set_Aliased_Present (Specification_Node); 1467 end if; 1468 1469 Scan; -- past ALIASED 1470 end if; 1471 1472 -- Scan possible NOT NULL for Ada 2005 (AI-231, AI-447) 1473 1474 Not_Null_Sloc := Token_Ptr; 1475 Not_Null_Present := 1476 P_Null_Exclusion (Allow_Anonymous_In_95 => True); 1477 1478 -- Case of ACCESS keyword present 1479 1480 if Token = Tok_Access then 1481 Set_Null_Exclusion_Present 1482 (Specification_Node, Not_Null_Present); 1483 1484 if Ada_Version = Ada_83 then 1485 Error_Msg_SC ("(Ada 83) access parameters not allowed"); 1486 end if; 1487 1488 Set_Parameter_Type 1489 (Specification_Node, 1490 P_Access_Definition (Not_Null_Present)); 1491 1492 -- Case of IN or OUT present 1493 1494 else 1495 if Token = Tok_In or else Token = Tok_Out then 1496 if Not_Null_Present then 1497 Error_Msg 1498 ("`NOT NULL` can only be used with `ACCESS`", 1499 Not_Null_Sloc); 1500 1501 if Token = Tok_In then 1502 Error_Msg 1503 ("\`IN` not allowed together with `ACCESS`", 1504 Not_Null_Sloc); 1505 else 1506 Error_Msg 1507 ("\`OUT` not allowed together with `ACCESS`", 1508 Not_Null_Sloc); 1509 end if; 1510 end if; 1511 1512 P_Mode (Specification_Node); 1513 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-231) 1514 end if; 1515 1516 Set_Null_Exclusion_Present 1517 (Specification_Node, Not_Null_Present); 1518 1519 if Token = Tok_Procedure 1520 or else 1521 Token = Tok_Function 1522 then 1523 Error_Msg_SC ("formal subprogram parameter not allowed"); 1524 Scan; 1525 1526 if Token = Tok_Left_Paren then 1527 Discard_Junk_List (P_Formal_Part); 1528 end if; 1529 1530 if Token = Tok_Return then 1531 Scan; 1532 Discard_Junk_Node (P_Subtype_Mark); 1533 end if; 1534 1535 Set_Parameter_Type (Specification_Node, Error); 1536 1537 else 1538 Set_Parameter_Type (Specification_Node, P_Subtype_Mark); 1539 No_Constraint; 1540 end if; 1541 end if; 1542 1543 Set_Expression (Specification_Node, Init_Expr_Opt (True)); 1544 1545 if Ident > 1 then 1546 Set_Prev_Ids (Specification_Node, True); 1547 end if; 1548 1549 if Ident < Num_Idents then 1550 Set_More_Ids (Specification_Node, True); 1551 end if; 1552 1553 Append (Specification_Node, Specification_List); 1554 exit Ident_List_Loop when Ident = Num_Idents; 1555 Ident := Ident + 1; 1556 Restore_Scan_State (Scan_State); 1557 end loop Ident_List_Loop; 1558 1559 exception 1560 when Error_Resync => 1561 Resync_Semicolon_List; 1562 end; 1563 1564 if Token = Tok_Semicolon then 1565 Save_Scan_State (Scan_State); 1566 Scan; -- past semicolon 1567 1568 -- If we have RETURN or IS after the semicolon, then assume 1569 -- that semicolon should have been a right parenthesis and exit 1570 1571 if Token = Tok_Is or else Token = Tok_Return then 1572 Error_Msg_SP -- CODEFIX 1573 ("|"";"" should be "")"""); 1574 exit Specification_Loop; 1575 end if; 1576 1577 -- If we have a declaration keyword after the semicolon, then 1578 -- assume we had a missing right parenthesis and terminate list 1579 1580 if Token in Token_Class_Declk then 1581 Error_Msg_AP -- CODEFIX 1582 ("missing "")"""); 1583 Restore_Scan_State (Scan_State); 1584 exit Specification_Loop; 1585 end if; 1586 1587 elsif Token = Tok_Right_Paren then 1588 Scan; -- past right paren 1589 exit Specification_Loop; 1590 1591 -- Special check for common error of using comma instead of semicolon 1592 1593 elsif Token = Tok_Comma then 1594 T_Semicolon; 1595 Scan; -- past comma 1596 1597 -- Special check for omitted separator 1598 1599 elsif Token = Tok_Identifier then 1600 T_Semicolon; 1601 1602 -- If nothing sensible, skip to next semicolon or right paren 1603 1604 else 1605 T_Semicolon; 1606 Resync_Semicolon_List; 1607 1608 if Token = Tok_Semicolon then 1609 Scan; -- past semicolon 1610 else 1611 T_Right_Paren; 1612 exit Specification_Loop; 1613 end if; 1614 end if; 1615 end loop Specification_Loop; 1616 1617 return Specification_List; 1618 end P_Formal_Part; 1619 1620 ---------------------------------- 1621 -- 6.1 Parameter Specification -- 1622 ---------------------------------- 1623 1624 -- Parsed by P_Formal_Part (6.1) 1625 1626 --------------- 1627 -- 6.1 Mode -- 1628 --------------- 1629 1630 -- MODE ::= [in] | in out | out 1631 1632 -- There is no explicit node in the tree for the Mode. Instead the 1633 -- In_Present and Out_Present flags are set in the parent node to 1634 -- record the presence of keywords specifying the mode. 1635 1636 -- Error_Recovery: cannot raise Error_Resync 1637 1638 procedure P_Mode (Node : Node_Id) is 1639 begin 1640 if Token = Tok_In then 1641 Scan; -- past IN 1642 Set_In_Present (Node, True); 1643 1644 if Style.Mode_In_Check and then Token /= Tok_Out then 1645 Error_Msg_SP -- CODEFIX 1646 ("(style) IN should be omitted"); 1647 end if; 1648 1649 -- Since Ada 2005, formal objects can have an anonymous access type, 1650 -- and of course carry a mode indicator. 1651 1652 if Token = Tok_Access 1653 and then Nkind (Node) /= N_Formal_Object_Declaration 1654 then 1655 Error_Msg_SP ("IN not allowed together with ACCESS"); 1656 Scan; -- past ACCESS 1657 end if; 1658 end if; 1659 1660 if Token = Tok_Out then 1661 Scan; -- past OUT 1662 Set_Out_Present (Node, True); 1663 end if; 1664 1665 if Token = Tok_In then 1666 Error_Msg_SC ("IN must precede OUT in parameter mode"); 1667 Scan; -- past IN 1668 Set_In_Present (Node, True); 1669 end if; 1670 end P_Mode; 1671 1672 -------------------------- 1673 -- 6.3 Subprogram Body -- 1674 -------------------------- 1675 1676 -- Parsed by P_Subprogram (6.1) 1677 1678 ----------------------------------- 1679 -- 6.4 Procedure Call Statement -- 1680 ----------------------------------- 1681 1682 -- Parsed by P_Sequence_Of_Statements (5.1) 1683 1684 ------------------------ 1685 -- 6.4 Function Call -- 1686 ------------------------ 1687 1688 -- Parsed by P_Name (4.1) 1689 1690 -------------------------------- 1691 -- 6.4 Actual Parameter Part -- 1692 -------------------------------- 1693 1694 -- Parsed by P_Name (4.1) 1695 1696 -------------------------------- 1697 -- 6.4 Parameter Association -- 1698 -------------------------------- 1699 1700 -- Parsed by P_Name (4.1) 1701 1702 ------------------------------------ 1703 -- 6.4 Explicit Actual Parameter -- 1704 ------------------------------------ 1705 1706 -- Parsed by P_Name (4.1) 1707 1708 --------------------------- 1709 -- 6.5 Return Statement -- 1710 --------------------------- 1711 1712 -- SIMPLE_RETURN_STATEMENT ::= return [EXPRESSION]; 1713 -- 1714 -- EXTENDED_RETURN_STATEMENT ::= 1715 -- return DEFINING_IDENTIFIER : [aliased] RETURN_SUBTYPE_INDICATION 1716 -- [:= EXPRESSION] [do 1717 -- HANDLED_SEQUENCE_OF_STATEMENTS 1718 -- end return]; 1719 -- 1720 -- RETURN_SUBTYPE_INDICATION ::= SUBTYPE_INDICATION | ACCESS_DEFINITION 1721 1722 -- RETURN_STATEMENT ::= return [EXPRESSION]; 1723 1724 -- Error recovery: can raise Error_Resync 1725 1726 procedure P_Return_Subtype_Indication (Decl_Node : Node_Id) is 1727 1728 -- Note: We don't need to check Ada_Version here, because this is 1729 -- only called in >= Ada 2005 cases anyway. 1730 1731 Not_Null_Present : constant Boolean := P_Null_Exclusion; 1732 1733 begin 1734 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); 1735 1736 if Token = Tok_Access then 1737 Set_Object_Definition 1738 (Decl_Node, P_Access_Definition (Not_Null_Present)); 1739 else 1740 Set_Object_Definition 1741 (Decl_Node, P_Subtype_Indication (Not_Null_Present)); 1742 end if; 1743 end P_Return_Subtype_Indication; 1744 1745 -- Error recovery: can raise Error_Resync 1746 1747 function P_Return_Object_Declaration return Node_Id is 1748 Return_Obj : Node_Id; 1749 Decl_Node : Node_Id; 1750 1751 begin 1752 Return_Obj := Token_Node; 1753 Change_Identifier_To_Defining_Identifier (Return_Obj); 1754 Warn_If_Standard_Redefinition (Return_Obj); 1755 Decl_Node := New_Node (N_Object_Declaration, Token_Ptr); 1756 Set_Defining_Identifier (Decl_Node, Return_Obj); 1757 1758 Scan; -- past identifier 1759 Scan; -- past : 1760 1761 -- First an error check, if we have two identifiers in a row, a likely 1762 -- possibility is that the first of the identifiers is an incorrectly 1763 -- spelled keyword. See similar check in P_Identifier_Declarations. 1764 1765 if Token = Tok_Identifier then 1766 declare 1767 SS : Saved_Scan_State; 1768 I2 : Boolean; 1769 1770 begin 1771 Save_Scan_State (SS); 1772 Scan; -- past initial identifier 1773 I2 := (Token = Tok_Identifier); 1774 Restore_Scan_State (SS); 1775 1776 if I2 1777 and then 1778 (Bad_Spelling_Of (Tok_Access) or else 1779 Bad_Spelling_Of (Tok_Aliased) or else 1780 Bad_Spelling_Of (Tok_Constant)) 1781 then 1782 null; 1783 end if; 1784 end; 1785 end if; 1786 1787 -- We allow "constant" here (as in "return Result : constant 1788 -- T..."). This is not in the latest RM, but the ARG is considering an 1789 -- AI on the subject (see AI05-0015-1), which we expect to be approved. 1790 1791 if Token = Tok_Constant then 1792 Scan; -- past CONSTANT 1793 Set_Constant_Present (Decl_Node); 1794 1795 if Token = Tok_Aliased then 1796 Error_Msg_SC -- CODEFIX 1797 ("ALIASED should be before CONSTANT"); 1798 Scan; -- past ALIASED 1799 Set_Aliased_Present (Decl_Node); 1800 end if; 1801 1802 elsif Token = Tok_Aliased then 1803 Scan; -- past ALIASED 1804 Set_Aliased_Present (Decl_Node); 1805 1806 -- The restrictions on the use of aliased in an extended return 1807 -- are semantic, not syntactic. 1808 1809 if Token = Tok_Constant then 1810 Scan; -- past CONSTANT 1811 Set_Constant_Present (Decl_Node); 1812 end if; 1813 end if; 1814 1815 P_Return_Subtype_Indication (Decl_Node); 1816 1817 if Token = Tok_Colon_Equal then 1818 Scan; -- past := 1819 Set_Expression (Decl_Node, P_Expression_No_Right_Paren); 1820 end if; 1821 1822 return Decl_Node; 1823 end P_Return_Object_Declaration; 1824 1825 -- Error recovery: can raise Error_Resync 1826 1827 function P_Return_Statement return Node_Id is 1828 -- The caller has checked that the initial token is RETURN 1829 1830 function Is_Simple return Boolean; 1831 -- Scan state is just after RETURN (and is left that way). Determine 1832 -- whether this is a simple or extended return statement by looking 1833 -- ahead for "identifier :", which implies extended. 1834 1835 --------------- 1836 -- Is_Simple -- 1837 --------------- 1838 1839 function Is_Simple return Boolean is 1840 Scan_State : Saved_Scan_State; 1841 Result : Boolean := True; 1842 1843 begin 1844 if Token = Tok_Identifier then 1845 Save_Scan_State (Scan_State); -- at identifier 1846 Scan; -- past identifier 1847 1848 if Token = Tok_Colon then 1849 Result := False; -- It's an extended_return_statement. 1850 end if; 1851 1852 Restore_Scan_State (Scan_State); -- to identifier 1853 end if; 1854 1855 return Result; 1856 end Is_Simple; 1857 1858 Ret_Sloc : constant Source_Ptr := Token_Ptr; 1859 Ret_Strt : constant Column_Number := Start_Column; 1860 Ret_Node : Node_Id; 1861 1862 -- Start of processing for P_Return_Statement 1863 1864 begin 1865 Scan; -- past RETURN 1866 1867 -- Simple_return_statement, no expression, return an 1868 -- N_Simple_Return_Statement node with the expression field left Empty. 1869 1870 if Token = Tok_Semicolon then 1871 Scan; -- past ; 1872 Ret_Node := New_Node (N_Simple_Return_Statement, Ret_Sloc); 1873 1874 -- Non-trivial case 1875 1876 else 1877 -- Simple_return_statement with expression 1878 1879 -- We avoid trying to scan an expression if we are at an 1880 -- expression terminator since in that case the best error 1881 -- message is probably that we have a missing semicolon. 1882 1883 if Is_Simple then 1884 Ret_Node := New_Node (N_Simple_Return_Statement, Ret_Sloc); 1885 1886 if Token not in Token_Class_Eterm then 1887 Set_Expression (Ret_Node, P_Expression_No_Right_Paren); 1888 end if; 1889 1890 -- Extended_return_statement (Ada 2005 only -- AI-318): 1891 1892 else 1893 if Ada_Version < Ada_2005 then 1894 Error_Msg_SP 1895 (" extended_return_statement is an Ada 2005 extension"); 1896 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 1897 end if; 1898 1899 Ret_Node := New_Node (N_Extended_Return_Statement, Ret_Sloc); 1900 Set_Return_Object_Declarations 1901 (Ret_Node, New_List (P_Return_Object_Declaration)); 1902 1903 if Token = Tok_Do then 1904 Push_Scope_Stack; 1905 Scope.Table (Scope.Last).Etyp := E_Return; 1906 Scope.Table (Scope.Last).Ecol := Ret_Strt; 1907 Scope.Table (Scope.Last).Sloc := Ret_Sloc; 1908 1909 Scan; -- past DO 1910 Set_Handled_Statement_Sequence 1911 (Ret_Node, P_Handled_Sequence_Of_Statements); 1912 End_Statements; 1913 1914 -- Do we need to handle Error_Resync here??? 1915 end if; 1916 end if; 1917 1918 TF_Semicolon; 1919 end if; 1920 1921 return Ret_Node; 1922 end P_Return_Statement; 1923 1924end Ch6; 1925