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-2021, 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 563 if Token = Tok_Or then 564 Error_Msg_Ada_2022_Feature 565 ("default for formal type", Sloc (Decl_Node)); 566 Scan; -- Past OR 567 568 if Token /= Tok_Use then 569 Error_Msg_SC ("missing USE for default subtype"); 570 else 571 Scan; -- Past USE 572 Set_Default_Subtype_Mark (Decl_Node, P_Name); 573 end if; 574 end if; 575 576 P_Aspect_Specifications (Decl_Node); 577 578 else 579 Decl_Node := Error; 580 581 -- If we have aspect specifications, skip them 582 583 if Aspect_Specifications_Present then 584 P_Aspect_Specifications (Error); 585 586 -- If we have semicolon, skip it to avoid cascaded errors 587 588 elsif Token = Tok_Semicolon then 589 Scan; -- past semicolon 590 end if; 591 end if; 592 593 return Decl_Node; 594 end P_Formal_Type_Declaration; 595 596 ---------------------------------- 597 -- 12.5 Formal Type Definition -- 598 ---------------------------------- 599 600 -- FORMAL_TYPE_DEFINITION ::= 601 -- FORMAL_PRIVATE_TYPE_DEFINITION 602 -- | FORMAL_INCOMPLETE_TYPE_DEFINITION 603 -- | FORMAL_DERIVED_TYPE_DEFINITION 604 -- | FORMAL_DISCRETE_TYPE_DEFINITION 605 -- | FORMAL_SIGNED_INTEGER_TYPE_DEFINITION 606 -- | FORMAL_MODULAR_TYPE_DEFINITION 607 -- | FORMAL_FLOATING_POINT_DEFINITION 608 -- | FORMAL_ORDINARY_FIXED_POINT_DEFINITION 609 -- | FORMAL_DECIMAL_FIXED_POINT_DEFINITION 610 -- | FORMAL_ARRAY_TYPE_DEFINITION 611 -- | FORMAL_ACCESS_TYPE_DEFINITION 612 -- | FORMAL_INTERFACE_TYPE_DEFINITION 613 614 -- FORMAL_ARRAY_TYPE_DEFINITION ::= ARRAY_TYPE_DEFINITION 615 616 -- FORMAL_ACCESS_TYPE_DEFINITION ::= ACCESS_TYPE_DEFINITION 617 618 -- FORMAL_INTERFACE_TYPE_DEFINITION ::= INTERFACE_TYPE_DEFINITION 619 620 function P_Formal_Type_Definition return Node_Id is 621 Scan_State : Saved_Scan_State; 622 Typedef_Node : Node_Id; 623 624 begin 625 if Token_Name = Name_Abstract then 626 Check_95_Keyword (Tok_Abstract, Tok_Tagged); 627 end if; 628 629 if Token_Name = Name_Tagged then 630 Check_95_Keyword (Tok_Tagged, Tok_Private); 631 Check_95_Keyword (Tok_Tagged, Tok_Limited); 632 end if; 633 634 case Token is 635 636 -- Mostly we can tell what we have from the initial token. The one 637 -- exception is ABSTRACT, where we have to scan ahead to see if we 638 -- have a formal derived type or a formal private type definition. 639 640 -- In addition, in Ada 2005 LIMITED may appear after abstract, so 641 -- that the lookahead must be extended by one more token. 642 643 when Tok_Abstract => 644 Save_Scan_State (Scan_State); 645 Scan; -- past ABSTRACT 646 647 if Token = Tok_New then 648 Restore_Scan_State (Scan_State); -- to ABSTRACT 649 return P_Formal_Derived_Type_Definition; 650 651 elsif Token = Tok_Limited then 652 Scan; -- past LIMITED 653 654 if Token = Tok_New then 655 Restore_Scan_State (Scan_State); -- to ABSTRACT 656 return P_Formal_Derived_Type_Definition; 657 658 else 659 Restore_Scan_State (Scan_State); -- to ABSTRACT 660 return P_Formal_Private_Type_Definition; 661 end if; 662 663 -- Ada 2005 (AI-443): Abstract synchronized formal derived type 664 665 elsif Token = Tok_Synchronized then 666 Restore_Scan_State (Scan_State); -- to ABSTRACT 667 return P_Formal_Derived_Type_Definition; 668 669 else 670 Restore_Scan_State (Scan_State); -- to ABSTRACT 671 return P_Formal_Private_Type_Definition; 672 end if; 673 674 when Tok_Access => 675 return P_Access_Type_Definition; 676 677 when Tok_Array => 678 return P_Array_Type_Definition; 679 680 when Tok_Delta => 681 return P_Formal_Fixed_Point_Definition; 682 683 when Tok_Digits => 684 return P_Formal_Floating_Point_Definition; 685 686 when Tok_Interface => -- Ada 2005 (AI-251) 687 return P_Interface_Type_Definition (Abstract_Present => False); 688 689 when Tok_Left_Paren => 690 return P_Formal_Discrete_Type_Definition; 691 692 when Tok_Limited => 693 Save_Scan_State (Scan_State); 694 Scan; -- past LIMITED 695 696 if Token = Tok_Interface then 697 Typedef_Node := 698 P_Interface_Type_Definition (Abstract_Present => False); 699 Set_Limited_Present (Typedef_Node); 700 return Typedef_Node; 701 702 elsif Token = Tok_New then 703 Restore_Scan_State (Scan_State); -- to LIMITED 704 return P_Formal_Derived_Type_Definition; 705 706 else 707 if Token = Tok_Abstract then 708 Error_Msg_SC -- CODEFIX 709 ("ABSTRACT must come before LIMITED"); 710 Scan; -- past improper ABSTRACT 711 712 if Token = Tok_New then 713 Restore_Scan_State (Scan_State); -- to LIMITED 714 return P_Formal_Derived_Type_Definition; 715 716 else 717 Restore_Scan_State (Scan_State); 718 return P_Formal_Private_Type_Definition; 719 end if; 720 end if; 721 722 Restore_Scan_State (Scan_State); 723 return P_Formal_Private_Type_Definition; 724 end if; 725 726 when Tok_Mod => 727 return P_Formal_Modular_Type_Definition; 728 729 when Tok_New => 730 return P_Formal_Derived_Type_Definition; 731 732 when Tok_Not => 733 if P_Null_Exclusion then 734 Typedef_Node := P_Access_Type_Definition; 735 Set_Null_Exclusion_Present (Typedef_Node); 736 return Typedef_Node; 737 738 else 739 Error_Msg_SC ("expect valid formal access definition!"); 740 Resync_Past_Semicolon; 741 return Error; 742 end if; 743 744 when Tok_Or => 745 -- Ada_2022: incomplete type with default 746 return 747 New_Node (N_Formal_Incomplete_Type_Definition, Token_Ptr); 748 749 when Tok_Private => 750 return P_Formal_Private_Type_Definition; 751 752 when Tok_Tagged => 753 if Next_Token_Is (Tok_Semicolon) 754 or else Next_Token_Is (Tok_Or) 755 then 756 Typedef_Node := 757 New_Node (N_Formal_Incomplete_Type_Definition, Token_Ptr); 758 Set_Tagged_Present (Typedef_Node); 759 760 Scan; -- past tagged 761 return Typedef_Node; 762 763 else 764 return P_Formal_Private_Type_Definition; 765 end if; 766 767 when Tok_Range => 768 return P_Formal_Signed_Integer_Type_Definition; 769 770 when Tok_Record => 771 Error_Msg_SC ("record not allowed in generic type definition!"); 772 Discard_Junk_Node (P_Record_Definition); 773 return Error; 774 775 -- Ada 2005 (AI-345): Task, Protected or Synchronized interface or 776 -- (AI-443): Synchronized formal derived type declaration. 777 778 when Tok_Protected 779 | Tok_Synchronized 780 | Tok_Task 781 => 782 declare 783 Saved_Token : constant Token_Type := Token; 784 785 begin 786 Scan; -- past TASK, PROTECTED or SYNCHRONIZED 787 788 -- Synchronized derived type 789 790 if Token = Tok_New then 791 Typedef_Node := P_Formal_Derived_Type_Definition; 792 793 if Saved_Token = Tok_Synchronized then 794 Set_Synchronized_Present (Typedef_Node); 795 else 796 Error_Msg_SC ("invalid kind of formal derived type"); 797 end if; 798 799 -- Interface 800 801 else 802 Typedef_Node := 803 P_Interface_Type_Definition (Abstract_Present => False); 804 805 case Saved_Token is 806 when Tok_Task => 807 Set_Task_Present (Typedef_Node); 808 809 when Tok_Protected => 810 Set_Protected_Present (Typedef_Node); 811 812 when Tok_Synchronized => 813 Set_Synchronized_Present (Typedef_Node); 814 815 when others => 816 null; 817 end case; 818 end if; 819 820 return Typedef_Node; 821 end; 822 823 when others => 824 Error_Msg_BC ("expecting generic type definition here"); 825 Resync_Past_Semicolon; 826 return Error; 827 end case; 828 end P_Formal_Type_Definition; 829 830 -------------------------------------------- 831 -- 12.5.1 Formal Private Type Definition -- 832 -------------------------------------------- 833 834 -- FORMAL_PRIVATE_TYPE_DEFINITION ::= 835 -- [[abstract] tagged] [limited] private 836 837 -- The caller has checked the initial token is PRIVATE, ABSTRACT, 838 -- TAGGED or LIMITED 839 840 -- Error recovery: cannot raise Error_Resync 841 842 function P_Formal_Private_Type_Definition return Node_Id is 843 Def_Node : Node_Id; 844 845 begin 846 Def_Node := New_Node (N_Formal_Private_Type_Definition, Token_Ptr); 847 848 if Token = Tok_Abstract then 849 Scan; -- past ABSTRACT 850 851 if Token_Name = Name_Tagged then 852 Check_95_Keyword (Tok_Tagged, Tok_Private); 853 Check_95_Keyword (Tok_Tagged, Tok_Limited); 854 end if; 855 856 if Token /= Tok_Tagged then 857 Error_Msg_SP ("ABSTRACT must be followed by TAGGED"); 858 else 859 Set_Abstract_Present (Def_Node, True); 860 end if; 861 end if; 862 863 if Token = Tok_Tagged then 864 Set_Tagged_Present (Def_Node, True); 865 Scan; -- past TAGGED 866 end if; 867 868 if Token = Tok_Limited then 869 Set_Limited_Present (Def_Node, True); 870 Scan; -- past LIMITED 871 end if; 872 873 if Token = Tok_Abstract then 874 if Prev_Token = Tok_Tagged then 875 Error_Msg_SC -- CODEFIX 876 ("ABSTRACT must come before TAGGED"); 877 elsif Prev_Token = Tok_Limited then 878 Error_Msg_SC -- CODEFIX 879 ("ABSTRACT must come before LIMITED"); 880 end if; 881 882 Resync_Past_Semicolon; 883 884 elsif Token = Tok_Tagged then 885 Error_Msg_SC -- CODEFIX 886 ("TAGGED must come before LIMITED"); 887 Resync_Past_Semicolon; 888 end if; 889 890 Set_Sloc (Def_Node, Token_Ptr); 891 T_Private; 892 893 if Token = Tok_Tagged then -- CODEFIX 894 Error_Msg_SC ("TAGGED must come before PRIVATE"); 895 Scan; -- past TAGGED 896 897 elsif Token = Tok_Abstract then -- CODEFIX 898 Error_Msg_SC ("`ABSTRACT TAGGED` must come before PRIVATE"); 899 Scan; -- past ABSTRACT 900 901 if Token = Tok_Tagged then 902 Scan; -- past TAGGED 903 end if; 904 end if; 905 906 return Def_Node; 907 end P_Formal_Private_Type_Definition; 908 909 -------------------------------------------- 910 -- 12.5.1 Formal Derived Type Definition -- 911 -------------------------------------------- 912 913 -- FORMAL_DERIVED_TYPE_DEFINITION ::= 914 -- [abstract] [limited | synchronized] 915 -- new SUBTYPE_MARK [[and INTERFACE_LIST] with private] 916 917 -- The caller has checked the initial token(s) is/are NEW, ABSTRACT NEW, 918 -- or LIMITED NEW, ABSTRACT LIMITED NEW, SYNCHRONIZED NEW or ABSTRACT 919 -- SYNCHRONIZED NEW. 920 921 -- Error recovery: cannot raise Error_Resync 922 923 function P_Formal_Derived_Type_Definition return Node_Id is 924 Def_Node : Node_Id; 925 926 begin 927 Def_Node := New_Node (N_Formal_Derived_Type_Definition, Token_Ptr); 928 929 if Token = Tok_Abstract then 930 Set_Abstract_Present (Def_Node); 931 Scan; -- past ABSTRACT 932 end if; 933 934 if Token = Tok_Limited then 935 Set_Limited_Present (Def_Node); 936 Scan; -- past LIMITED 937 938 Error_Msg_Ada_2005_Extension ("LIMITED in derived type"); 939 940 elsif Token = Tok_Synchronized then 941 Set_Synchronized_Present (Def_Node); 942 Scan; -- past SYNCHRONIZED 943 944 Error_Msg_Ada_2005_Extension ("SYNCHRONIZED in derived type"); 945 end if; 946 947 if Token = Tok_Abstract then 948 Scan; -- past ABSTRACT, diagnosed already in caller. 949 end if; 950 951 Scan; -- past NEW; 952 Set_Subtype_Mark (Def_Node, P_Subtype_Mark); 953 No_Constraint; 954 955 -- Ada 2005 (AI-251): Deal with interfaces 956 957 if Token = Tok_And then 958 Scan; -- past AND 959 960 Error_Msg_Ada_2005_Extension ("abstract interface"); 961 962 Set_Interface_List (Def_Node, New_List); 963 964 loop 965 Append (P_Qualified_Simple_Name, Interface_List (Def_Node)); 966 exit when Token /= Tok_And; 967 Scan; -- past AND 968 end loop; 969 end if; 970 971 if Token = Tok_With then 972 973 if Next_Token_Is (Tok_Private) then 974 Scan; -- past WITH 975 Set_Private_Present (Def_Node, True); 976 T_Private; 977 else 978 -- Formal type has aspect specifications, parsed later. 979 -- Otherwise this is a formal derived type. Note that it may 980 -- also include later aspect specifications, as in: 981 982 -- type DT is new T with private with Atomic; 983 984 Error_Msg_Ada_2022_Feature 985 ("formal type with aspect specification", Token_Ptr); 986 987 return Def_Node; 988 end if; 989 990 elsif Token = Tok_Tagged then 991 Scan; 992 993 if Token = Tok_Private then 994 Error_Msg_SC -- CODEFIX 995 ("TAGGED should be WITH"); 996 Set_Private_Present (Def_Node, True); 997 T_Private; 998 else 999 Ignore (Tok_Tagged); 1000 end if; 1001 end if; 1002 1003 return Def_Node; 1004 end P_Formal_Derived_Type_Definition; 1005 1006 --------------------------------------------- 1007 -- 12.5.2 Formal Discrete Type Definition -- 1008 --------------------------------------------- 1009 1010 -- FORMAL_DISCRETE_TYPE_DEFINITION ::= (<>) 1011 1012 -- The caller has checked the initial token is left paren 1013 1014 -- Error recovery: cannot raise Error_Resync 1015 1016 function P_Formal_Discrete_Type_Definition return Node_Id is 1017 Def_Node : Node_Id; 1018 1019 begin 1020 Def_Node := New_Node (N_Formal_Discrete_Type_Definition, Token_Ptr); 1021 Scan; -- past left paren 1022 T_Box; 1023 T_Right_Paren; 1024 return Def_Node; 1025 end P_Formal_Discrete_Type_Definition; 1026 1027 --------------------------------------------------- 1028 -- 12.5.2 Formal Signed Integer Type Definition -- 1029 --------------------------------------------------- 1030 1031 -- FORMAL_SIGNED_INTEGER_TYPE_DEFINITION ::= range <> 1032 1033 -- The caller has checked the initial token is RANGE 1034 1035 -- Error recovery: cannot raise Error_Resync 1036 1037 function P_Formal_Signed_Integer_Type_Definition return Node_Id is 1038 Def_Node : Node_Id; 1039 1040 begin 1041 Def_Node := 1042 New_Node (N_Formal_Signed_Integer_Type_Definition, Token_Ptr); 1043 Scan; -- past RANGE 1044 T_Box; 1045 return Def_Node; 1046 end P_Formal_Signed_Integer_Type_Definition; 1047 1048 -------------------------------------------- 1049 -- 12.5.2 Formal Modular Type Definition -- 1050 -------------------------------------------- 1051 1052 -- FORMAL_MODULAR_TYPE_DEFINITION ::= mod <> 1053 1054 -- The caller has checked the initial token is MOD 1055 1056 -- Error recovery: cannot raise Error_Resync 1057 1058 function P_Formal_Modular_Type_Definition return Node_Id is 1059 Def_Node : Node_Id; 1060 1061 begin 1062 Def_Node := 1063 New_Node (N_Formal_Modular_Type_Definition, Token_Ptr); 1064 Scan; -- past MOD 1065 T_Box; 1066 return Def_Node; 1067 end P_Formal_Modular_Type_Definition; 1068 1069 ---------------------------------------------- 1070 -- 12.5.2 Formal Floating Point Definition -- 1071 ---------------------------------------------- 1072 1073 -- FORMAL_FLOATING_POINT_DEFINITION ::= digits <> 1074 1075 -- The caller has checked the initial token is DIGITS 1076 1077 -- Error recovery: cannot raise Error_Resync 1078 1079 function P_Formal_Floating_Point_Definition return Node_Id is 1080 Def_Node : Node_Id; 1081 1082 begin 1083 Def_Node := 1084 New_Node (N_Formal_Floating_Point_Definition, Token_Ptr); 1085 Scan; -- past DIGITS 1086 T_Box; 1087 return Def_Node; 1088 end P_Formal_Floating_Point_Definition; 1089 1090 ------------------------------------------- 1091 -- 12.5.2 Formal Fixed Point Definition -- 1092 ------------------------------------------- 1093 1094 -- This routine parses either a formal ordinary fixed point definition 1095 -- or a formal decimal fixed point definition: 1096 1097 -- FORMAL_ORDINARY_FIXED_POINT_DEFINITION ::= delta <> 1098 1099 -- FORMAL_DECIMAL_FIXED_POINT_DEFINITION ::= delta <> digits <> 1100 1101 -- The caller has checked the initial token is DELTA 1102 1103 -- Error recovery: cannot raise Error_Resync 1104 1105 function P_Formal_Fixed_Point_Definition return Node_Id is 1106 Def_Node : Node_Id; 1107 Delta_Sloc : Source_Ptr; 1108 1109 begin 1110 Delta_Sloc := Token_Ptr; 1111 Scan; -- past DELTA 1112 T_Box; 1113 1114 if Token = Tok_Digits then 1115 Def_Node := 1116 New_Node (N_Formal_Decimal_Fixed_Point_Definition, Delta_Sloc); 1117 Scan; -- past DIGITS 1118 T_Box; 1119 else 1120 Def_Node := 1121 New_Node (N_Formal_Ordinary_Fixed_Point_Definition, Delta_Sloc); 1122 end if; 1123 1124 return Def_Node; 1125 end P_Formal_Fixed_Point_Definition; 1126 1127 ---------------------------------------------------- 1128 -- 12.5.2 Formal Ordinary Fixed Point Definition -- 1129 ---------------------------------------------------- 1130 1131 -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) 1132 1133 --------------------------------------------------- 1134 -- 12.5.2 Formal Decimal Fixed Point Definition -- 1135 --------------------------------------------------- 1136 1137 -- Parsed by P_Formal_Fixed_Point_Definition (12.5.2) 1138 1139 ------------------------------------------ 1140 -- 12.5.3 Formal Array Type Definition -- 1141 ------------------------------------------ 1142 1143 -- Parsed by P_Formal_Type_Definition (12.5) 1144 1145 ------------------------------------------- 1146 -- 12.5.4 Formal Access Type Definition -- 1147 ------------------------------------------- 1148 1149 -- Parsed by P_Formal_Type_Definition (12.5) 1150 1151 ----------------------------------------- 1152 -- 12.6 Formal Subprogram Declaration -- 1153 ----------------------------------------- 1154 1155 -- FORMAL_SUBPROGRAM_DECLARATION ::= 1156 -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION 1157 -- | FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION 1158 1159 -- FORMAL_CONCRETE_SUBPROGRAM_DECLARATION ::= 1160 -- with SUBPROGRAM_SPECIFICATION [is SUBPROGRAM_DEFAULT] 1161 -- [ASPECT_SPECIFICATIONS]; 1162 1163 -- FORMAL_ABSTRACT_SUBPROGRAM_DECLARATION ::= 1164 -- with SUBPROGRAM_SPECIFICATION is abstract [SUBPROGRAM_DEFAULT] 1165 -- [ASPECT_SPECIFICATIONS]; 1166 1167 -- SUBPROGRAM_DEFAULT ::= DEFAULT_NAME | <> 1168 -- | ( EXPRESSION ) -- Allowed as extension (-gnatX) 1169 1170 -- DEFAULT_NAME ::= NAME | null 1171 1172 -- The caller has checked that the initial tokens are WITH FUNCTION or 1173 -- WITH PROCEDURE, and the initial WITH has been scanned out. 1174 1175 -- A null default is an Ada 2005 feature 1176 1177 -- Error recovery: cannot raise Error_Resync 1178 1179 function P_Formal_Subprogram_Declaration return Node_Id is 1180 Prev_Sloc : constant Source_Ptr := Prev_Token_Ptr; 1181 Spec_Node : constant Node_Id := P_Subprogram_Specification; 1182 Def_Node : Node_Id; 1183 1184 begin 1185 if Token = Tok_Is then 1186 T_Is; -- past IS, skip extra IS or ";" 1187 1188 if Token = Tok_Abstract then 1189 Def_Node := 1190 New_Node (N_Formal_Abstract_Subprogram_Declaration, Prev_Sloc); 1191 Scan; -- past ABSTRACT 1192 1193 Error_Msg_Ada_2005_Extension ("formal abstract subprogram"); 1194 1195 else 1196 Def_Node := 1197 New_Node (N_Formal_Concrete_Subprogram_Declaration, Prev_Sloc); 1198 end if; 1199 1200 Set_Specification (Def_Node, Spec_Node); 1201 1202 if Token = Tok_Semicolon then 1203 null; 1204 1205 elsif Aspect_Specifications_Present then 1206 null; 1207 1208 elsif Token = Tok_Box then 1209 Set_Box_Present (Def_Node, True); 1210 Scan; -- past <> 1211 1212 elsif Token = Tok_Null then 1213 Error_Msg_Ada_2005_Extension ("null default subprogram"); 1214 1215 if Nkind (Spec_Node) = N_Procedure_Specification then 1216 Set_Null_Present (Spec_Node); 1217 else 1218 Error_Msg_SP ("only procedures can be null"); 1219 end if; 1220 1221 Scan; -- past NULL 1222 1223 -- When extensions are enabled, a formal function can have a default 1224 -- given by a parenthesized expression (expression function syntax). 1225 1226 elsif Token = Tok_Left_Paren then 1227 Error_Msg_GNAT_Extension 1228 ("expression default for formal subprograms"); 1229 1230 if Nkind (Spec_Node) = N_Function_Specification then 1231 Scan; -- past "(" 1232 1233 Set_Expression (Def_Node, P_Expression); 1234 1235 if Token /= Tok_Right_Paren then 1236 Error_Msg_SC ("missing "")"" at end of expression default"); 1237 else 1238 Scan; -- past ")" 1239 end if; 1240 1241 else 1242 Error_Msg_SP 1243 ("only functions can specify a default expression"); 1244 end if; 1245 1246 else 1247 Set_Default_Name (Def_Node, P_Name); 1248 end if; 1249 1250 else 1251 Def_Node := 1252 New_Node (N_Formal_Concrete_Subprogram_Declaration, Prev_Sloc); 1253 Set_Specification (Def_Node, Spec_Node); 1254 end if; 1255 1256 P_Aspect_Specifications (Def_Node); 1257 return Def_Node; 1258 end P_Formal_Subprogram_Declaration; 1259 1260 ------------------------------ 1261 -- 12.6 Subprogram Default -- 1262 ------------------------------ 1263 1264 -- Parsed by P_Formal_Procedure_Declaration (12.6) 1265 1266 ------------------------ 1267 -- 12.6 Default Name -- 1268 ------------------------ 1269 1270 -- Parsed by P_Formal_Procedure_Declaration (12.6) 1271 1272 -------------------------------------- 1273 -- 12.7 Formal Package Declaration -- 1274 -------------------------------------- 1275 1276 -- FORMAL_PACKAGE_DECLARATION ::= 1277 -- with package DEFINING_IDENTIFIER 1278 -- is new generic_package_NAME FORMAL_PACKAGE_ACTUAL_PART 1279 -- [ASPECT_SPECIFICATIONS]; 1280 1281 -- FORMAL_PACKAGE_ACTUAL_PART ::= 1282 -- ([OTHERS =>] <>) | 1283 -- [GENERIC_ACTUAL_PART] 1284 -- (FORMAL_PACKAGE_ASSOCIATION {, FORMAL_PACKAGE_ASSOCIATION} 1285 -- [, OTHERS => <>) 1286 1287 -- FORMAL_PACKAGE_ASSOCIATION ::= 1288 -- GENERIC_ASSOCIATION 1289 -- | GENERIC_FORMAL_PARAMETER_SELECTOR_NAME => <> 1290 1291 -- The caller has checked that the initial tokens are WITH PACKAGE, 1292 -- and the initial WITH has been scanned out (so Token = Tok_Package). 1293 1294 -- Error recovery: cannot raise Error_Resync 1295 1296 function P_Formal_Package_Declaration return Node_Id is 1297 Def_Node : Node_Id; 1298 Scan_State : Saved_Scan_State; 1299 1300 begin 1301 Def_Node := New_Node (N_Formal_Package_Declaration, Prev_Token_Ptr); 1302 Scan; -- past PACKAGE 1303 Set_Defining_Identifier (Def_Node, P_Defining_Identifier (C_Is)); 1304 T_Is; 1305 T_New; 1306 Set_Name (Def_Node, P_Qualified_Simple_Name); 1307 1308 if Token = Tok_Left_Paren then 1309 Save_Scan_State (Scan_State); -- at the left paren 1310 Scan; -- past the left paren 1311 1312 if Token = Tok_Box then 1313 Set_Box_Present (Def_Node, True); 1314 Scan; -- past box 1315 T_Right_Paren; 1316 1317 else 1318 Restore_Scan_State (Scan_State); -- to the left paren 1319 Set_Generic_Associations (Def_Node, P_Generic_Actual_Part_Opt); 1320 end if; 1321 end if; 1322 1323 P_Aspect_Specifications (Def_Node); 1324 return Def_Node; 1325 end P_Formal_Package_Declaration; 1326 1327 -------------------------------------- 1328 -- 12.7 Formal Package Actual Part -- 1329 -------------------------------------- 1330 1331 -- Parsed by P_Formal_Package_Declaration (12.7) 1332 1333end Ch12; 1334