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