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