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