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-2019, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26pragma Style_Checks (All_Checks); 27-- Turn off subprogram body ordering check. Subprograms are in order 28-- by RM section rather than alphabetical 29 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 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 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