1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P A R . C H 1 2 -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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 30separate (Par) 31package body Ch12 is 32 33 -- Local functions, used only in this chapter 34 35 function P_Formal_Derived_Type_Definition return Node_Id; 36 function P_Formal_Discrete_Type_Definition return Node_Id; 37 function P_Formal_Fixed_Point_Definition return Node_Id; 38 function P_Formal_Floating_Point_Definition return Node_Id; 39 function P_Formal_Modular_Type_Definition return Node_Id; 40 function P_Formal_Package_Declaration return Node_Id; 41 function P_Formal_Private_Type_Definition return Node_Id; 42 function P_Formal_Signed_Integer_Type_Definition return Node_Id; 43 function P_Formal_Subprogram_Declaration return Node_Id; 44 function P_Formal_Type_Declaration return Node_Id; 45 function P_Formal_Type_Definition return Node_Id; 46 function P_Generic_Association return Node_Id; 47 48 procedure P_Formal_Object_Declarations (Decls : List_Id); 49 -- Scans one or more formal object declarations and appends them to 50 -- Decls. Scans more than one declaration only in the case where the 51 -- source has a declaration with multiple defining identifiers. 52 53 -------------------------------- 54 -- 12.1 Generic (also 8.5.5) -- 55 -------------------------------- 56 57 -- This routine parses either one of the forms of a generic declaration 58 -- or a generic renaming declaration. 59 60 -- GENERIC_DECLARATION ::= 61 -- GENERIC_SUBPROGRAM_DECLARATION | GENERIC_PACKAGE_DECLARATION 62 63 -- GENERIC_SUBPROGRAM_DECLARATION ::= 64 -- GENERIC_FORMAL_PART SUBPROGRAM_SPECIFICATION 65 -- [ASPECT_SPECIFICATIONS]; 66 67 -- GENERIC_PACKAGE_DECLARATION ::= 68 -- GENERIC_FORMAL_PART PACKAGE_SPECIFICATION 69 -- [ASPECT_SPECIFICATIONS]; 70 71 -- GENERIC_FORMAL_PART ::= 72 -- generic {GENERIC_FORMAL_PARAMETER_DECLARATION | USE_CLAUSE} 73 74 -- GENERIC_RENAMING_DECLARATION ::= 75 -- generic package DEFINING_PROGRAM_UNIT_NAME 76 -- renames generic_package_NAME 77 -- [ASPECT_SPECIFICATIONS]; 78 -- | generic procedure DEFINING_PROGRAM_UNIT_NAME 79 -- renames generic_procedure_NAME 80 -- [ASPECT_SPECIFICATIONS]; 81 -- | generic function DEFINING_PROGRAM_UNIT_NAME 82 -- renames generic_function_NAME 83 -- [ASPECT_SPECIFICATIONS]; 84 85 -- GENERIC_FORMAL_PARAMETER_DECLARATION ::= 86 -- FORMAL_OBJECT_DECLARATION 87 -- | FORMAL_TYPE_DECLARATION 88 -- | FORMAL_SUBPROGRAM_DECLARATION 89 -- | FORMAL_PACKAGE_DECLARATION 90 91 -- The caller has checked that the initial token is GENERIC 92 93 -- Error recovery: can raise Error_Resync 94 95 function P_Generic return Node_Id is 96 Gen_Sloc : constant Source_Ptr := Token_Ptr; 97 Gen_Decl : Node_Id; 98 Decl_Node : Node_Id; 99 Decls : List_Id; 100 Def_Unit : Node_Id; 101 Ren_Token : Token_Type; 102 Scan_State : Saved_Scan_State; 103 104 begin 105 Scan; -- past GENERIC 106 107 if Token = Tok_Private then 108 Error_Msg_SC -- CODEFIX 109 ("PRIVATE goes before GENERIC, not after"); 110 Scan; -- past junk PRIVATE token 111 end if; 112 113 Save_Scan_State (Scan_State); -- at token past GENERIC 114 115 -- Check for generic renaming declaration case 116 117 if Token = Tok_Package 118 or else Token = Tok_Function 119 or else Token = Tok_Procedure 120 then 121 Ren_Token := Token; 122 Scan; -- scan past PACKAGE, FUNCTION or PROCEDURE 123 124 if Token = Tok_Identifier then 125 Def_Unit := P_Defining_Program_Unit_Name; 126 127 Check_Misspelling_Of (Tok_Renames); 128 129 if Token = Tok_Renames then 130 if Ren_Token = Tok_Package then 131 Decl_Node := New_Node 132 (N_Generic_Package_Renaming_Declaration, Gen_Sloc); 133 134 elsif Ren_Token = Tok_Procedure then 135 Decl_Node := New_Node 136 (N_Generic_Procedure_Renaming_Declaration, Gen_Sloc); 137 138 else -- Ren_Token = Tok_Function then 139 Decl_Node := New_Node 140 (N_Generic_Function_Renaming_Declaration, Gen_Sloc); 141 end if; 142 143 Scan; -- past RENAMES 144 Set_Defining_Unit_Name (Decl_Node, Def_Unit); 145 Set_Name (Decl_Node, P_Name); 146 147 P_Aspect_Specifications (Decl_Node, Semicolon => False); 148 TF_Semicolon; 149 return Decl_Node; 150 end if; 151 end if; 152 end if; 153 154 -- Fall through if this is *not* a generic renaming declaration 155 156 Restore_Scan_State (Scan_State); 157 Decls := New_List; 158 159 -- Loop through generic parameter declarations and use clauses 160 161 Decl_Loop : loop 162 P_Pragmas_Opt (Decls); 163 164 if Token = Tok_Private then 165 Error_Msg_S ("generic private child packages not permitted"); 166 Scan; -- past PRIVATE 167 end if; 168 169 if Token = Tok_Use then 170 Append (P_Use_Clause, Decls); 171 else 172 -- Parse a generic parameter declaration 173 174 if Token = Tok_Identifier then 175 P_Formal_Object_Declarations (Decls); 176 177 elsif Token = Tok_Type then 178 Append (P_Formal_Type_Declaration, Decls); 179 180 elsif Token = Tok_With then 181 Scan; -- past WITH 182 183 if Token = Tok_Package then 184 Append (P_Formal_Package_Declaration, Decls); 185 186 elsif Token = Tok_Procedure or Token = Tok_Function then 187 Append (P_Formal_Subprogram_Declaration, Decls); 188 189 else 190 Error_Msg_BC -- CODEFIX 191 ("FUNCTION, PROCEDURE or PACKAGE expected here"); 192 Resync_Past_Semicolon; 193 end if; 194 195 elsif Token = Tok_Subtype then 196 Error_Msg_SC ("subtype declaration not allowed " & 197 "as generic parameter declaration!"); 198 Resync_Past_Semicolon; 199 200 else 201 exit Decl_Loop; 202 end if; 203 end if; 204 end loop Decl_Loop; 205 206 -- Generic formal part is scanned, scan out subprogram or package spec 207 208 if Token = Tok_Package then 209 Gen_Decl := New_Node (N_Generic_Package_Declaration, Gen_Sloc); 210 Set_Specification (Gen_Decl, P_Package (Pf_Spcn)); 211 212 -- Aspects have been parsed by the package spec. Move them to the 213 -- generic declaration where they belong. 214 215 Move_Aspects (Specification (Gen_Decl), Gen_Decl); 216 217 else 218 Gen_Decl := New_Node (N_Generic_Subprogram_Declaration, Gen_Sloc); 219 Set_Specification (Gen_Decl, P_Subprogram_Specification); 220 221 if Nkind (Defining_Unit_Name (Specification (Gen_Decl))) = 222 N_Defining_Program_Unit_Name 223 and then Scope.Last > 0 224 then 225 Error_Msg_SP ("child unit allowed only at library level"); 226 end if; 227 228 P_Aspect_Specifications (Gen_Decl); 229 end if; 230 231 Set_Generic_Formal_Declarations (Gen_Decl, Decls); 232 return Gen_Decl; 233 end P_Generic; 234 235 ------------------------------- 236 -- 12.1 Generic Declaration -- 237 ------------------------------- 238 239 -- Parsed by P_Generic (12.1) 240 241 ------------------------------------------ 242 -- 12.1 Generic Subprogram Declaration -- 243 ------------------------------------------ 244 245 -- Parsed by P_Generic (12.1) 246 247 --------------------------------------- 248 -- 12.1 Generic Package Declaration -- 249 --------------------------------------- 250 251 -- Parsed by P_Generic (12.1) 252 253 ------------------------------- 254 -- 12.1 Generic Formal Part -- 255 ------------------------------- 256 257 -- Parsed by P_Generic (12.1) 258 259 ------------------------------------------------- 260 -- 12.1 Generic Formal Parameter Declaration -- 261 ------------------------------------------------- 262 263 -- Parsed by P_Generic (12.1) 264 265 --------------------------------- 266 -- 12.3 Generic Instantiation -- 267 --------------------------------- 268 269 -- Generic package instantiation parsed by P_Package (7.1) 270 -- Generic procedure instantiation parsed by P_Subprogram (6.1) 271 -- Generic function instantiation parsed by P_Subprogram (6.1) 272 273 ------------------------------- 274 -- 12.3 Generic Actual Part -- 275 ------------------------------- 276 277 -- GENERIC_ACTUAL_PART ::= 278 -- (GENERIC_ASSOCIATION {, GENERIC_ASSOCIATION}) 279 280 -- Returns a list of generic associations, or Empty if none are present 281 282 -- Error recovery: cannot raise Error_Resync 283 284 function P_Generic_Actual_Part_Opt return List_Id is 285 Association_List : List_Id; 286 287 begin 288 -- Figure out if a generic actual part operation is present. Clearly 289 -- there is no generic actual part if the current token is semicolon 290 -- or if we have aspect specifications present. 291 292 if Token = Tok_Semicolon or else Aspect_Specifications_Present then 293 return No_List; 294 295 -- If we don't have a left paren, then we have an error, and the job 296 -- is to figure out whether a left paren or semicolon was intended. 297 -- We assume a missing left paren (and hence a generic actual part 298 -- present) if the current token is not on a new line, or if it is 299 -- indented from the subprogram token. Otherwise assume missing 300 -- semicolon (which will be diagnosed by caller) and no generic part 301 302 elsif Token /= Tok_Left_Paren 303 and then Token_Is_At_Start_Of_Line 304 and then Start_Column <= Scope.Table (Scope.Last).Ecol 305 then 306 return No_List; 307 308 -- Otherwise we have a generic actual part (either a left paren is 309 -- present, or we have decided that there must be a missing left paren) 310 311 else 312 Association_List := New_List; 313 T_Left_Paren; 314 315 loop 316 Append (P_Generic_Association, Association_List); 317 exit when not Comma_Present; 318 end loop; 319 320 T_Right_Paren; 321 return Association_List; 322 end if; 323 324 end P_Generic_Actual_Part_Opt; 325 326 ------------------------------- 327 -- 12.3 Generic Association -- 328 ------------------------------- 329 330 -- GENERIC_ASSOCIATION ::= 331 -- [generic_formal_parameter_SELECTOR_NAME =>] 332 -- EXPLICIT_GENERIC_ACTUAL_PARAMETER 333 334 -- EXPLICIT_GENERIC_ACTUAL_PARAMETER ::= 335 -- EXPRESSION | variable_NAME | subprogram_NAME 336 -- | entry_NAME | SUBTYPE_MARK | package_instance_NAME 337 338 -- Error recovery: cannot raise Error_Resync 339 340 function P_Generic_Association return Node_Id is 341 Scan_State : Saved_Scan_State; 342 Param_Name_Node : Node_Id; 343 Generic_Assoc_Node : Node_Id; 344 345 begin 346 Generic_Assoc_Node := New_Node (N_Generic_Association, Token_Ptr); 347 348 -- Ada 2005: an association can be given by: others => <> 349 350 if Token = Tok_Others then 351 if Ada_Version < Ada_2005 then 352 Error_Msg_SP 353 ("partial parameterization of formal packages" 354 & " is an Ada 2005 extension"); 355 Error_Msg_SP 356 ("\unit must be compiled with -gnat05 switch"); 357 end if; 358 359 Scan; -- past OTHERS 360 361 if Token /= Tok_Arrow then 362 Error_Msg_BC ("expect arrow after others"); 363 else 364 Scan; -- past arrow 365 end if; 366 367 if Token /= Tok_Box then 368 Error_Msg_BC ("expect Box after arrow"); 369 else 370 Scan; -- past box 371 end if; 372 373 -- Source position of the others choice is beginning of construct 374 375 return New_Node (N_Others_Choice, Sloc (Generic_Assoc_Node)); 376 end if; 377 378 if Token in Token_Class_Desig then 379 Param_Name_Node := Token_Node; 380 Save_Scan_State (Scan_State); -- at designator 381 Scan; -- past simple name or operator symbol 382 383 if Token = Tok_Arrow then 384 Scan; -- past arrow 385 Set_Selector_Name (Generic_Assoc_Node, Param_Name_Node); 386 else 387 Restore_Scan_State (Scan_State); -- to designator 388 end if; 389 end if; 390 391 -- In Ada 2005 the actual can be a box 392 393 if Token = Tok_Box then 394 Scan; 395 Set_Box_Present (Generic_Assoc_Node); 396 Set_Explicit_Generic_Actual_Parameter (Generic_Assoc_Node, Empty); 397 398 else 399 Set_Explicit_Generic_Actual_Parameter 400 (Generic_Assoc_Node, P_Expression); 401 end if; 402 403 return Generic_Assoc_Node; 404 end P_Generic_Association; 405 406 --------------------------------------------- 407 -- 12.3 Explicit Generic Actual Parameter -- 408 --------------------------------------------- 409 410 -- Parsed by P_Generic_Association (12.3) 411 412 -------------------------------------- 413 -- 12.4 Formal Object Declarations -- 414 -------------------------------------- 415 416 -- FORMAL_OBJECT_DECLARATION ::= 417 -- DEFINING_IDENTIFIER_LIST : 418 -- MODE [NULL_EXCLUSION] SUBTYPE_MARK [:= DEFAULT_EXPRESSION] 419 -- [ASPECT_SPECIFICATIONS]; 420 -- | DEFINING_IDENTIFIER_LIST : 421 -- MODE ACCESS_DEFINITION [:= DEFAULT_EXPRESSION]; 422 -- [ASPECT_SPECIFICATIONS]; 423 424 -- The caller has checked that the initial token is an identifier 425 426 -- Error recovery: cannot raise Error_Resync 427 428 procedure P_Formal_Object_Declarations (Decls : List_Id) is 429 Decl_Node : Node_Id; 430 Ident : Nat; 431 Not_Null_Present : Boolean := False; 432 Num_Idents : Nat; 433 Scan_State : Saved_Scan_State; 434 435 Idents : array (Int range 1 .. 4096) of Entity_Id; 436 -- This array holds the list of defining identifiers. The upper bound 437 -- of 4096 is intended to be essentially infinite, and we do not even 438 -- bother to check for it being exceeded. 439 440 begin 441 Idents (1) := P_Defining_Identifier (C_Comma_Colon); 442 Num_Idents := 1; 443 while Comma_Present loop 444 Num_Idents := Num_Idents + 1; 445 Idents (Num_Idents) := P_Defining_Identifier (C_Comma_Colon); 446 end loop; 447 448 T_Colon; 449 450 -- If there are multiple identifiers, we repeatedly scan the 451 -- type and initialization expression information by resetting 452 -- the scan pointer (so that we get completely separate trees 453 -- for each occurrence). 454 455 if Num_Idents > 1 then 456 Save_Scan_State (Scan_State); 457 end if; 458 459 -- Loop through defining identifiers in list 460 461 Ident := 1; 462 Ident_Loop : loop 463 Decl_Node := New_Node (N_Formal_Object_Declaration, Token_Ptr); 464 Set_Defining_Identifier (Decl_Node, Idents (Ident)); 465 P_Mode (Decl_Node); 466 467 Not_Null_Present := P_Null_Exclusion; -- Ada 2005 (AI-423) 468 469 -- Ada 2005 (AI-423): Formal object with an access definition 470 471 if Token = Tok_Access then 472 473 -- The access definition is still parsed and set even though 474 -- the compilation may not use the proper switch. This action 475 -- ensures the required local error recovery. 476 477 Set_Access_Definition (Decl_Node, 478 P_Access_Definition (Not_Null_Present)); 479 480 if Ada_Version < Ada_2005 then 481 Error_Msg_SP 482 ("access definition not allowed in formal object " & 483 "declaration"); 484 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 485 end if; 486 487 -- Formal object with a subtype mark 488 489 else 490 Set_Null_Exclusion_Present (Decl_Node, Not_Null_Present); 491 Set_Subtype_Mark (Decl_Node, P_Subtype_Mark_Resync); 492 end if; 493 494 No_Constraint; 495 Set_Default_Expression (Decl_Node, Init_Expr_Opt); 496 P_Aspect_Specifications (Decl_Node); 497 498 if Ident > 1 then 499 Set_Prev_Ids (Decl_Node, True); 500 end if; 501 502 if Ident < Num_Idents then 503 Set_More_Ids (Decl_Node, True); 504 end if; 505 506 Append (Decl_Node, Decls); 507 508 exit Ident_Loop when Ident = Num_Idents; 509 Ident := Ident + 1; 510 Restore_Scan_State (Scan_State); 511 end loop Ident_Loop; 512 end P_Formal_Object_Declarations; 513 514 ----------------------------------- 515 -- 12.5 Formal Type Declaration -- 516 ----------------------------------- 517 518 -- FORMAL_TYPE_DECLARATION ::= 519 -- type DEFINING_IDENTIFIER [DISCRIMINANT_PART] 520 -- is FORMAL_TYPE_DEFINITION 521 -- [ASPECT_SPECIFICATIONS]; 522 523 -- The caller has checked that the initial token is TYPE 524 525 -- Error recovery: cannot raise Error_Resync 526 527 function P_Formal_Type_Declaration return Node_Id is 528 Decl_Node : Node_Id; 529 Def_Node : Node_Id; 530 531 begin 532 Decl_Node := New_Node (N_Formal_Type_Declaration, Token_Ptr); 533 Scan; -- past TYPE 534 Set_Defining_Identifier (Decl_Node, P_Defining_Identifier); 535 536 if P_Unknown_Discriminant_Part_Opt then 537 Set_Unknown_Discriminants_Present (Decl_Node, True); 538 else 539 Set_Discriminant_Specifications 540 (Decl_Node, P_Known_Discriminant_Part_Opt); 541 end if; 542 543 if Token = Tok_Semicolon then 544 545 -- Ada 2012: Incomplete formal type 546 547 Scan; -- past semicolon 548 549 Error_Msg_Ada_2012_Feature 550 ("formal incomplete type", Sloc (Decl_Node)); 551 552 Set_Formal_Type_Definition 553 (Decl_Node, 554 New_Node (N_Formal_Incomplete_Type_Definition, Token_Ptr)); 555 return Decl_Node; 556 557 else 558 T_Is; 559 end if; 560 561 Def_Node := P_Formal_Type_Definition; 562 563 if Nkind (Def_Node) = N_Formal_Incomplete_Type_Definition then 564 Error_Msg_Ada_2012_Feature 565 ("formal incomplete type", Sloc (Decl_Node)); 566 end if; 567 568 if Def_Node /= Error then 569 Set_Formal_Type_Definition (Decl_Node, Def_Node); 570 P_Aspect_Specifications (Decl_Node); 571 572 else 573 Decl_Node := Error; 574 575 -- If we have aspect specifications, skip them 576 577 if Aspect_Specifications_Present then 578 P_Aspect_Specifications (Error); 579 580 -- If we have semicolon, skip it to avoid cascaded errors 581 582 elsif Token = Tok_Semicolon then 583 Scan; -- past semicolon 584 end if; 585 end if; 586 587 return Decl_Node; 588 end P_Formal_Type_Declaration; 589 590 ---------------------------------- 591 -- 12.5 Formal Type Definition -- 592 ---------------------------------- 593 594 -- FORMAL_TYPE_DEFINITION ::= 595 -- FORMAL_PRIVATE_TYPE_DEFINITION 596 -- | FORMAL_INCOMPLETE_TYPE_DEFINITION 597 -- | FORMAL_DERIVED_TYPE_DEFINITION 598 -- | FORMAL_DISCRETE_TYPE_DEFINITION 599 -- | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION 600 -- | FORMAL_MODULAR_TYPE_DEFINITION 601 -- | FORMAL_FLOATING_POINT_DEFINITION 602 -- | FORMAL_ORDINARY_FIXED_POINT_DEFINITION 603 -- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION 604 -- | FORMAL_ARRAY_TYPE_DEFINITION 605 -- | FORMAL_ACCESS_TYPE_DEFINITION 606 -- | FORMAL_INTERFACE_TYPE_DEFINITION 607 608 -- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION 609 610 -- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION 611 612 -- FORMAL_INTERFACE_TYPE_DEFINITION ::= INTERFACE_TYPE_DEFINITION 613 614 function P_Formal_Type_Definition return Node_Id is 615 Scan_State : Saved_Scan_State; 616 Typedef_Node : Node_Id; 617 618 begin 619 if Token_Name = Name_Abstract then 620 Check_95_Keyword (Tok_Abstract, Tok_Tagged); 621 end if; 622 623 if Token_Name = Name_Tagged then 624 Check_95_Keyword (Tok_Tagged, Tok_Private); 625 Check_95_Keyword (Tok_Tagged, Tok_Limited); 626 end if; 627 628 case Token is 629 630 -- Mostly we can tell what we have from the initial token. The one 631 -- exception is ABSTRACT, where we have to scan ahead to see if we 632 -- have a formal derived type or a formal private type definition. 633 634 -- In addition, in Ada 2005 LIMITED may appear after abstract, so 635 -- that the lookahead must be extended by one more token. 636 637 when Tok_Abstract => 638 Save_Scan_State (Scan_State); 639 Scan; -- past ABSTRACT 640 641 if Token = Tok_New then 642 Restore_Scan_State (Scan_State); -- to ABSTRACT 643 return P_Formal_Derived_Type_Definition; 644 645 elsif Token = Tok_Limited then 646 Scan; -- past LIMITED 647 648 if Token = Tok_New then 649 Restore_Scan_State (Scan_State); -- to ABSTRACT 650 return P_Formal_Derived_Type_Definition; 651 652 else 653 Restore_Scan_State (Scan_State); -- to ABSTRACT 654 return P_Formal_Private_Type_Definition; 655 end if; 656 657 -- Ada 2005 (AI-443): Abstract synchronized formal derived type 658 659 elsif Token = Tok_Synchronized then 660 Restore_Scan_State (Scan_State); -- to ABSTRACT 661 return P_Formal_Derived_Type_Definition; 662 663 else 664 Restore_Scan_State (Scan_State); -- to ABSTRACT 665 return P_Formal_Private_Type_Definition; 666 end if; 667 668 when Tok_Access => 669 return P_Access_Type_Definition; 670 671 when Tok_Array => 672 return P_Array_Type_Definition; 673 674 when Tok_Delta => 675 return P_Formal_Fixed_Point_Definition; 676 677 when Tok_Digits => 678 return P_Formal_Floating_Point_Definition; 679 680 when Tok_Interface => -- Ada 2005 (AI-251) 681 return P_Interface_Type_Definition (Abstract_Present => False); 682 683 when Tok_Left_Paren => 684 return P_Formal_Discrete_Type_Definition; 685 686 when Tok_Limited => 687 Save_Scan_State (Scan_State); 688 Scan; -- past LIMITED 689 690 if Token = Tok_Interface then 691 Typedef_Node := 692 P_Interface_Type_Definition (Abstract_Present => False); 693 Set_Limited_Present (Typedef_Node); 694 return Typedef_Node; 695 696 elsif Token = Tok_New then 697 Restore_Scan_State (Scan_State); -- to LIMITED 698 return P_Formal_Derived_Type_Definition; 699 700 else 701 if Token = Tok_Abstract then 702 Error_Msg_SC -- CODEFIX 703 ("ABSTRACT must come before LIMITED"); 704 Scan; -- past improper ABSTRACT 705 706 if Token = Tok_New then 707 Restore_Scan_State (Scan_State); -- to LIMITED 708 return P_Formal_Derived_Type_Definition; 709 710 else 711 Restore_Scan_State (Scan_State); 712 return P_Formal_Private_Type_Definition; 713 end if; 714 end if; 715 716 Restore_Scan_State (Scan_State); 717 return P_Formal_Private_Type_Definition; 718 end if; 719 720 when Tok_Mod => 721 return P_Formal_Modular_Type_Definition; 722 723 when Tok_New => 724 return P_Formal_Derived_Type_Definition; 725 726 when Tok_Not => 727 if P_Null_Exclusion then 728 Typedef_Node := P_Access_Type_Definition; 729 Set_Null_Exclusion_Present (Typedef_Node); 730 return Typedef_Node; 731 732 else 733 Error_Msg_SC ("expect valid formal access definition!"); 734 Resync_Past_Semicolon; 735 return Error; 736 end if; 737 738 when Tok_Private => 739 return P_Formal_Private_Type_Definition; 740 741 when Tok_Tagged => 742 if Next_Token_Is (Tok_Semicolon) then 743 Typedef_Node := 744 New_Node (N_Formal_Incomplete_Type_Definition, Token_Ptr); 745 Set_Tagged_Present (Typedef_Node); 746 747 Scan; -- past tagged 748 return Typedef_Node; 749 750 else 751 return P_Formal_Private_Type_Definition; 752 end if; 753 754 when Tok_Range => 755 return P_Formal_Signed_Integer_Type_Definition; 756 757 when Tok_Record => 758 Error_Msg_SC ("record not allowed in generic type definition!"); 759 Discard_Junk_Node (P_Record_Definition); 760 return Error; 761 762 -- Ada 2005 (AI-345): Task, Protected or Synchronized interface or 763 -- (AI-443): Synchronized formal derived type declaration. 764 765 when Tok_Protected | 766 Tok_Synchronized | 767 Tok_Task => 768 769 declare 770 Saved_Token : constant Token_Type := Token; 771 772 begin 773 Scan; -- past TASK, PROTECTED or SYNCHRONIZED 774 775 -- Synchronized derived type 776 777 if Token = Tok_New then 778 Typedef_Node := P_Formal_Derived_Type_Definition; 779 780 if Saved_Token = Tok_Synchronized then 781 Set_Synchronized_Present (Typedef_Node); 782 else 783 Error_Msg_SC ("invalid kind of formal derived type"); 784 end if; 785 786 -- Interface 787 788 else 789 Typedef_Node := 790 P_Interface_Type_Definition (Abstract_Present => False); 791 792 case Saved_Token is 793 when Tok_Task => 794 Set_Task_Present (Typedef_Node); 795 796 when Tok_Protected => 797 Set_Protected_Present (Typedef_Node); 798 799 when Tok_Synchronized => 800 Set_Synchronized_Present (Typedef_Node); 801 802 when others => 803 null; 804 end case; 805 end if; 806 807 return Typedef_Node; 808 end; 809 810 when others => 811 Error_Msg_BC ("expecting generic type definition here"); 812 Resync_Past_Semicolon; 813 return Error; 814 815 end case; 816 end P_Formal_Type_Definition; 817 818 -------------------------------------------- 819 -- 12.5.1 Formal Private Type Definition -- 820 -------------------------------------------- 821 822 -- FORMAL_PRIVATE_TYPE_DEFINITION ::= 823 -- [[abstract] tagged] [limited] private 824 825 -- The caller has checked the initial token is PRIVATE, ABSTRACT, 826 -- TAGGED or LIMITED 827 828 -- Error recovery: cannot raise Error_Resync 829 830 function P_Formal_Private_Type_Definition return Node_Id is 831 Def_Node : Node_Id; 832 833 begin 834 Def_Node := New_Node (N_Formal_Private_Type_Definition, Token_Ptr); 835 836 if Token = Tok_Abstract then 837 Scan; -- past ABSTRACT 838 839 if Token_Name = Name_Tagged then 840 Check_95_Keyword (Tok_Tagged, Tok_Private); 841 Check_95_Keyword (Tok_Tagged, Tok_Limited); 842 end if; 843 844 if Token /= Tok_Tagged then 845 Error_Msg_SP ("ABSTRACT must be followed by TAGGED"); 846 else 847 Set_Abstract_Present (Def_Node, True); 848 end if; 849 end if; 850 851 if Token = Tok_Tagged then 852 Set_Tagged_Present (Def_Node, True); 853 Scan; -- past TAGGED 854 end if; 855 856 if Token = Tok_Limited then 857 Set_Limited_Present (Def_Node, True); 858 Scan; -- past LIMITED 859 end if; 860 861 if Token = Tok_Abstract then 862 if Prev_Token = Tok_Tagged then 863 Error_Msg_SC -- CODEFIX 864 ("ABSTRACT must come before TAGGED"); 865 elsif Prev_Token = Tok_Limited then 866 Error_Msg_SC -- CODEFIX 867 ("ABSTRACT must come before LIMITED"); 868 end if; 869 870 Resync_Past_Semicolon; 871 872 elsif Token = Tok_Tagged then 873 Error_Msg_SC -- CODEFIX 874 ("TAGGED must come before LIMITED"); 875 Resync_Past_Semicolon; 876 end if; 877 878 Set_Sloc (Def_Node, Token_Ptr); 879 T_Private; 880 881 if Token = Tok_Tagged then -- CODEFIX 882 Error_Msg_SC ("TAGGED must come before PRIVATE"); 883 Scan; -- past TAGGED 884 885 elsif Token = Tok_Abstract then -- CODEFIX 886 Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE"); 887 Scan; -- past ABSTRACT 888 889 if Token = Tok_Tagged then 890 Scan; -- past TAGGED 891 end if; 892 end if; 893 894 return Def_Node; 895 end P_Formal_Private_Type_Definition; 896 897 -------------------------------------------- 898 -- 12.5.1 Formal Derived Type Definition -- 899 -------------------------------------------- 900 901 -- FORMAL_DERIVED_TYPE_DEFINITION ::= 902 -- [abstract] [limited | synchronized] 903 -- new SUBTYPE_MARK [[and INTERFACE_LIST] with private] 904 905 -- The caller has checked the initial token(s) is/are NEW, ABSTRACT NEW, 906 -- or LIMITED NEW, ABSTRACT LIMITED NEW, SYNCHRONIZED NEW or ABSTRACT 907 -- SYNCHRONIZED NEW. 908 909 -- Error recovery: cannot raise Error_Resync 910 911 function P_Formal_Derived_Type_Definition return Node_Id is 912 Def_Node : Node_Id; 913 914 begin 915 Def_Node := New_Node (N_Formal_Derived_Type_Definition, Token_Ptr); 916 917 if Token = Tok_Abstract then 918 Set_Abstract_Present (Def_Node); 919 Scan; -- past ABSTRACT 920 end if; 921 922 if Token = Tok_Limited then 923 Set_Limited_Present (Def_Node); 924 Scan; -- past LIMITED 925 926 if Ada_Version < Ada_2005 then 927 Error_Msg_SP 928 ("LIMITED in derived type is an Ada 2005 extension"); 929 Error_Msg_SP 930 ("\unit must be compiled with -gnat05 switch"); 931 end if; 932 933 elsif Token = Tok_Synchronized then 934 Set_Synchronized_Present (Def_Node); 935 Scan; -- past SYNCHRONIZED 936 937 if Ada_Version < Ada_2005 then 938 Error_Msg_SP 939 ("SYNCHRONIZED in derived type is an Ada 2005 extension"); 940 Error_Msg_SP 941 ("\unit must be compiled with -gnat05 switch"); 942 end if; 943 end if; 944 945 if Token = Tok_Abstract then 946 Scan; -- past ABSTRACT, diagnosed already in caller. 947 end if; 948 949 Scan; -- past NEW; 950 Set_Subtype_Mark (Def_Node, P_Subtype_Mark); 951 No_Constraint; 952 953 -- Ada 2005 (AI-251): Deal with interfaces 954 955 if Token = Tok_And then 956 Scan; -- past AND 957 958 if Ada_Version < Ada_2005 then 959 Error_Msg_SP 960 ("abstract interface is an Ada 2005 extension"); 961 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 962 end if; 963 964 Set_Interface_List (Def_Node, New_List); 965 966 loop 967 Append (P_Qualified_Simple_Name, Interface_List (Def_Node)); 968 exit when Token /= Tok_And; 969 Scan; -- past AND 970 end loop; 971 end if; 972 973 if Token = Tok_With then 974 Scan; -- past WITH 975 Set_Private_Present (Def_Node, True); 976 T_Private; 977 978 elsif Token = Tok_Tagged then 979 Scan; 980 981 if Token = Tok_Private then 982 Error_Msg_SC -- CODEFIX 983 ("TAGGED should be WITH"); 984 Set_Private_Present (Def_Node, True); 985 T_Private; 986 else 987 Ignore (Tok_Tagged); 988 end if; 989 end if; 990 991 return Def_Node; 992 end P_Formal_Derived_Type_Definition; 993 994 --------------------------------------------- 995 -- 12.5.2 Formal Discrete Type Definition -- 996 --------------------------------------------- 997 998 -- FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>) 999 1000 -- The caller has checked the initial token is left paren 1001 1002 -- Error recovery: cannot raise Error_Resync 1003 1004 function P_Formal_Discrete_Type_Definition return Node_Id is 1005 Def_Node : Node_Id; 1006 1007 begin 1008 Def_Node := New_Node (N_Formal_Discrete_Type_Definition, Token_Ptr); 1009 Scan; -- past left paren 1010 T_Box; 1011 T_Right_Paren; 1012 return Def_Node; 1013 end P_Formal_Discrete_Type_Definition; 1014 1015 --------------------------------------------------- 1016 -- 12.5.2 Formal Signed Integer Type Definition -- 1017 --------------------------------------------------- 1018 1019 -- FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <> 1020 1021 -- The caller has checked the initial token is RANGE 1022 1023 -- Error recovery: cannot raise Error_Resync 1024 1025 function P_Formal_Signed_Integer_Type_Definition return Node_Id is 1026 Def_Node : Node_Id; 1027 1028 begin 1029 Def_Node := 1030 New_Node (N_Formal_Signed_Integer_Type_Definition, Token_Ptr); 1031 Scan; -- past RANGE 1032 T_Box; 1033 return Def_Node; 1034 end P_Formal_Signed_Integer_Type_Definition; 1035 1036 -------------------------------------------- 1037 -- 12.5.2 Formal Modular Type Definition -- 1038 -------------------------------------------- 1039 1040 -- FORMAL_MODULAR_TYPE_DEFINITION ::= mod <> 1041 1042 -- The caller has checked the initial token is MOD 1043 1044 -- Error recovery: cannot raise Error_Resync 1045 1046 function P_Formal_Modular_Type_Definition return Node_Id is 1047 Def_Node : Node_Id; 1048 1049 begin 1050 Def_Node := 1051 New_Node (N_Formal_Modular_Type_Definition, Token_Ptr); 1052 Scan; -- past MOD 1053 T_Box; 1054 return Def_Node; 1055 end P_Formal_Modular_Type_Definition; 1056 1057 ---------------------------------------------- 1058 -- 12.5.2 Formal Floating Point Definition -- 1059 ---------------------------------------------- 1060 1061 -- FORMAL_FLOATING_POINT_DEFINITION ::= digits <> 1062 1063 -- The caller has checked the initial token is DIGITS 1064 1065 -- Error recovery: cannot raise Error_Resync 1066 1067 function P_Formal_Floating_Point_Definition return Node_Id is 1068 Def_Node : Node_Id; 1069 1070 begin 1071 Def_Node := 1072 New_Node (N_Formal_Floating_Point_Definition, Token_Ptr); 1073 Scan; -- past DIGITS 1074 T_Box; 1075 return Def_Node; 1076 end P_Formal_Floating_Point_Definition; 1077 1078 ------------------------------------------- 1079 -- 12.5.2 Formal Fixed Point Definition -- 1080 ------------------------------------------- 1081 1082 -- This routine parses either a formal ordinary fixed point definition 1083 -- or a formal decimal fixed point definition: 1084 1085 -- FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <> 1086 1087 -- FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <> 1088 1089 -- The caller has checked the initial token is DELTA 1090 1091 -- Error recovery: cannot raise Error_Resync 1092 1093 function P_Formal_Fixed_Point_Definition return Node_Id is 1094 Def_Node : Node_Id; 1095 Delta_Sloc : Source_Ptr; 1096 1097 begin 1098 Delta_Sloc := Token_Ptr; 1099 Scan; -- past DELTA 1100 T_Box; 1101 1102 if Token = Tok_Digits then 1103 Def_Node := 1104 New_Node (N_Formal_Decimal_Fixed_Point_Definition, Delta_Sloc); 1105 Scan; -- past DIGITS 1106 T_Box; 1107 else 1108 Def_Node := 1109 New_Node (N_Formal_Ordinary_Fixed_Point_Definition, Delta_Sloc); 1110 end if; 1111 1112 return Def_Node; 1113 end P_Formal_Fixed_Point_Definition; 1114 1115 ---------------------------------------------------- 1116 -- 12.5.2 Formal Ordinary Fixed Point Definition -- 1117 ---------------------------------------------------- 1118 1119 -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) 1120 1121 --------------------------------------------------- 1122 -- 12.5.2 Formal Decimal Fixed Point Definition -- 1123 --------------------------------------------------- 1124 1125 -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) 1126 1127 ------------------------------------------ 1128 -- 12.5.3 Formal Array Type Definition -- 1129 ------------------------------------------ 1130 1131 -- Parsed by P_Formal_Type_Definition (12.5) 1132 1133 ------------------------------------------- 1134 -- 12.5.4 Formal Access Type Definition -- 1135 ------------------------------------------- 1136 1137 -- Parsed by P_Formal_Type_Definition (12.5) 1138 1139 ----------------------------------------- 1140 -- 12.6 Formal Subprogram Declaration -- 1141 ----------------------------------------- 1142 1143 -- FORMAL_SUBPROGRAM_DECLARATION ::= 1144 -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION 1145 -- | FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION 1146 1147 -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION ::= 1148 -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT] 1149 -- [ASPECT_SPECIFICATIONS]; 1150 1151 -- FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION ::= 1152 -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT] 1153 -- [ASPECT_SPECIFICATIONS]; 1154 1155 -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> 1156 1157 -- DEFAULT_NAME ::= NAME | null 1158 1159 -- The caller has checked that the initial tokens are WITH FUNCTION or 1160 -- WITH PROCEDURE, and the initial WITH has been scanned out. 1161 1162 -- A null default is an Ada 2005 feature 1163 1164 -- Error recovery: cannot raise Error_Resync 1165 1166 function P_Formal_Subprogram_Declaration return Node_Id is 1167 Prev_Sloc : constant Source_Ptr := Prev_Token_Ptr; 1168 Spec_Node : constant Node_Id := P_Subprogram_Specification; 1169 Def_Node : Node_Id; 1170 1171 begin 1172 if Token = Tok_Is then 1173 T_Is; -- past IS, skip extra IS or ";" 1174 1175 if Token = Tok_Abstract then 1176 Def_Node := 1177 New_Node (N_Formal_Abstract_Subprogram_Declaration, Prev_Sloc); 1178 Scan; -- past ABSTRACT 1179 1180 if Ada_Version < Ada_2005 then 1181 Error_Msg_SP 1182 ("formal abstract subprograms are an Ada 2005 extension"); 1183 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 1184 end if; 1185 1186 else 1187 Def_Node := 1188 New_Node (N_Formal_Concrete_Subprogram_Declaration, Prev_Sloc); 1189 end if; 1190 1191 Set_Specification (Def_Node, Spec_Node); 1192 1193 if Token = Tok_Semicolon then 1194 null; 1195 1196 elsif Aspect_Specifications_Present then 1197 null; 1198 1199 elsif Token = Tok_Box then 1200 Set_Box_Present (Def_Node, True); 1201 Scan; -- past <> 1202 1203 elsif Token = Tok_Null then 1204 if Ada_Version < Ada_2005 then 1205 Error_Msg_SP 1206 ("null default subprograms are an Ada 2005 extension"); 1207 Error_Msg_SP ("\unit must be compiled with -gnat05 switch"); 1208 end if; 1209 1210 if Nkind (Spec_Node) = N_Procedure_Specification then 1211 Set_Null_Present (Spec_Node); 1212 else 1213 Error_Msg_SP ("only procedures can be null"); 1214 end if; 1215 1216 Scan; -- past NULL 1217 1218 else 1219 Set_Default_Name (Def_Node, P_Name); 1220 end if; 1221 1222 else 1223 Def_Node := 1224 New_Node (N_Formal_Concrete_Subprogram_Declaration, Prev_Sloc); 1225 Set_Specification (Def_Node, Spec_Node); 1226 end if; 1227 1228 P_Aspect_Specifications (Def_Node); 1229 return Def_Node; 1230 end P_Formal_Subprogram_Declaration; 1231 1232 ------------------------------ 1233 -- 12.6 Subprogram Default -- 1234 ------------------------------ 1235 1236 -- Parsed by P_Formal_Procedure_Declaration (12.6) 1237 1238 ------------------------ 1239 -- 12.6 Default Name -- 1240 ------------------------ 1241 1242 -- Parsed by P_Formal_Procedure_Declaration (12.6) 1243 1244 -------------------------------------- 1245 -- 12.7 Formal Package Declaration -- 1246 -------------------------------------- 1247 1248 -- FORMAL_PACKAGE_DECLARATION ::= 1249 -- with package DEFINING_IDENTIFIER 1250 -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART 1251 -- [ASPECT_SPECIFICATIONS]; 1252 1253 -- FORMAL_PACKAGE_ACTUAL_PART ::= 1254 -- ([OTHERS =>] <>) | 1255 -- [GENERIC_ACTUAL_PART] 1256 -- (FORMAL_PACKAGE_ASSOCIATION {, FORMAL_PACKAGE_ASSOCIATION} 1257 -- [, OTHERS => <>) 1258 1259 -- FORMAL_PACKAGE_ASSOCIATION ::= 1260 -- GENERIC_ASSOCIATION 1261 -- | GENERIC_FORMAL_PARAMETER_SELECTOR_NAME => <> 1262 1263 -- The caller has checked that the initial tokens are WITH PACKAGE, 1264 -- and the initial WITH has been scanned out (so Token = Tok_Package). 1265 1266 -- Error recovery: cannot raise Error_Resync 1267 1268 function P_Formal_Package_Declaration return Node_Id is 1269 Def_Node : Node_Id; 1270 Scan_State : Saved_Scan_State; 1271 1272 begin 1273 Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr); 1274 Scan; -- past PACKAGE 1275 Set_Defining_Identifier (Def_Node, P_Defining_Identifier (C_Is)); 1276 T_Is; 1277 T_New; 1278 Set_Name (Def_Node, P_Qualified_Simple_Name); 1279 1280 if Token = Tok_Left_Paren then 1281 Save_Scan_State (Scan_State); -- at the left paren 1282 Scan; -- past the left paren 1283 1284 if Token = Tok_Box then 1285 Set_Box_Present (Def_Node, True); 1286 Scan; -- past box 1287 T_Right_Paren; 1288 1289 else 1290 Restore_Scan_State (Scan_State); -- to the left paren 1291 Set_Generic_Associations (Def_Node, P_Generic_Actual_Part_Opt); 1292 end if; 1293 end if; 1294 1295 P_Aspect_Specifications (Def_Node); 1296 return Def_Node; 1297 end P_Formal_Package_Declaration; 1298 1299 -------------------------------------- 1300 -- 12.7 Formal Package Actual Part -- 1301 -------------------------------------- 1302 1303 -- Parsed by P_Formal_Package_Declaration (12.7) 1304 1305end Ch12; 1306