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