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