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