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