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