par-ch6.adb 38.1 KB
Newer Older
Richard Kenner committed
1 2 3 4 5 6 7 8
------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                              P A R . C H 6                               --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
9
--                            $Revision: 1.1 $
Richard Kenner committed
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210
--                                                                          --
--          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
--                                                                          --
------------------------------------------------------------------------------

pragma Style_Checks (All_Checks);
--  Turn off subprogram body ordering check. Subprograms are in order
--  by RM section rather than alphabetical

with Sinfo.CN; use Sinfo.CN;

separate (Par)
package body Ch6 is

   --  Local subprograms, used only in this chapter

   function P_Defining_Designator        return Node_Id;
   function P_Defining_Operator_Symbol   return Node_Id;

   procedure Check_Junk_Semicolon_Before_Return;
   --  Check for common error of junk semicolon before RETURN keyword of
   --  function specification. If present, skip over it with appropriate
   --  error message, leaving Scan_Ptr pointing to the RETURN after. This
   --  routine also deals with a possibly misspelled version of Return.

   ----------------------------------------
   -- Check_Junk_Semicolon_Before_Return --
   ----------------------------------------

   procedure Check_Junk_Semicolon_Before_Return is
      Scan_State : Saved_Scan_State;

   begin
      if Token = Tok_Semicolon then
         Save_Scan_State (Scan_State);
         Scan; -- past the semicolon

         if Token = Tok_Return then
            Restore_Scan_State (Scan_State);
            Error_Msg_SC ("Unexpected semicolon ignored");
            Scan; -- rescan past junk semicolon

         else
            Restore_Scan_State (Scan_State);
         end if;

      elsif Bad_Spelling_Of (Tok_Return) then
         null;
      end if;
   end Check_Junk_Semicolon_Before_Return;

   -----------------------------------------------------
   -- 6.1  Subprogram (Also 6.3, 8.5.4, 10.1.3, 12.3) --
   -----------------------------------------------------

   --  This routine scans out a subprogram declaration, subprogram body,
   --  subprogram renaming declaration or subprogram generic instantiation.

   --  SUBPROGRAM_DECLARATION ::= SUBPROGRAM_SPECIFICATION;

   --  ABSTRACT_SUBPROGRAM_DECLARATION ::=
   --    SUBPROGRAM_SPECIFICATION is abstract;

   --  SUBPROGRAM_SPECIFICATION ::=
   --      procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
   --    | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE

   --  PARAMETER_PROFILE ::= [FORMAL_PART]

   --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK

   --  SUBPROGRAM_BODY ::=
   --    SUBPROGRAM_SPECIFICATION is
   --      DECLARATIVE_PART
   --    begin
   --      HANDLED_SEQUENCE_OF_STATEMENTS
   --    end [DESIGNATOR];

   --  SUBPROGRAM_RENAMING_DECLARATION ::=
   --    SUBPROGRAM_SPECIFICATION renames callable_entity_NAME;

   --  SUBPROGRAM_BODY_STUB ::=
   --    SUBPROGRAM_SPECIFICATION is separate;

   --  GENERIC_INSTANTIATION ::=
   --    procedure DEFINING_PROGRAM_UNIT_NAME is
   --      new generic_procedure_NAME [GENERIC_ACTUAL_PART];
   --  | function DEFINING_DESIGNATOR is
   --      new generic_function_NAME [GENERIC_ACTUAL_PART];

   --  The value in Pf_Flags indicates which of these possible declarations
   --  is acceptable to the caller:

   --    Pf_Flags.Decl                 Set if declaration OK
   --    Pf_Flags.Gins                 Set if generic instantiation OK
   --    Pf_Flags.Pbod                 Set if proper body OK
   --    Pf_Flags.Rnam                 Set if renaming declaration OK
   --    Pf_Flags.Stub                 Set if body stub OK

   --  If an inappropriate form is encountered, it is scanned out but an
   --  error message indicating that it is appearing in an inappropriate
   --  context is issued. The only possible values for Pf_Flags are those
   --  defined as constants in the Par package.

   --  The caller has checked that the initial token is FUNCTION or PROCEDURE

   --  Error recovery: cannot raise Error_Resync

   function P_Subprogram (Pf_Flags : Pf_Rec) return Node_Id is
      Specification_Node : Node_Id;
      Name_Node   : Node_Id;
      Fpart_List  : List_Id;
      Fpart_Sloc  : Source_Ptr;
      Return_Node : Node_Id;
      Inst_Node   : Node_Id;
      Body_Node   : Node_Id;
      Decl_Node   : Node_Id;
      Rename_Node : Node_Id;
      Absdec_Node : Node_Id;
      Stub_Node   : Node_Id;
      Fproc_Sloc  : Source_Ptr;
      Func        : Boolean;
      Scan_State  : Saved_Scan_State;

   begin
      --  Set up scope stack entry. Note that the Labl field will be set later

      SIS_Entry_Active := False;
      SIS_Missing_Semicolon_Message := No_Error_Msg;
      Push_Scope_Stack;
      Scope.Table (Scope.Last).Sloc := Token_Ptr;
      Scope.Table (Scope.Last).Etyp := E_Name;
      Scope.Table (Scope.Last).Ecol := Start_Column;
      Scope.Table (Scope.Last).Lreq := False;

      Func := (Token = Tok_Function);
      Fproc_Sloc := Token_Ptr;
      Scan; -- past FUNCTION or PROCEDURE
      Ignore (Tok_Type);
      Ignore (Tok_Body);

      if Func then
         Name_Node := P_Defining_Designator;

         if Nkind (Name_Node) = N_Defining_Operator_Symbol
           and then Scope.Last = 1
         then
            Error_Msg_SP ("operator symbol not allowed at library level");
            Name_Node := New_Entity (N_Defining_Identifier, Sloc (Name_Node));

            --  Set name from file name, we need some junk name, and that's
            --  as good as anything. This is only approximate, since we do
            --  not do anything with non-standard name translations.

            Get_Name_String (File_Name (Current_Source_File));

            for J in 1 .. Name_Len loop
               if Name_Buffer (J) = '.' then
                  Name_Len := J - 1;
                  exit;
               end if;
            end loop;

            Set_Chars (Name_Node, Name_Find);
            Set_Error_Posted (Name_Node);
         end if;

      else
         Name_Node := P_Defining_Program_Unit_Name;
      end if;

      Scope.Table (Scope.Last).Labl := Name_Node;

      if Token = Tok_Colon then
         Error_Msg_SC ("redundant colon ignored");
         Scan; -- past colon
      end if;

      --  Deal with generic instantiation, the one case in which we do not
      --  have a subprogram specification as part of whatever we are parsing

      if Token = Tok_Is then
         Save_Scan_State (Scan_State); -- at the IS
         T_Is; -- checks for redundant IS's

         if Token = Tok_New then
            if not Pf_Flags.Gins then
211
               Error_Msg_SC ("generic instantiation not allowed here!");
Richard Kenner committed
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085
            end if;

            Scan; -- past NEW

            if Func then
               Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
               Set_Name (Inst_Node, P_Function_Name);
            else
               Inst_Node := New_Node (N_Procedure_Instantiation, Fproc_Sloc);
               Set_Name (Inst_Node, P_Qualified_Simple_Name);
            end if;

            Set_Defining_Unit_Name (Inst_Node, Name_Node);
            Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
            TF_Semicolon;
            Pop_Scope_Stack; -- Don't need scope stack entry in this case
            return Inst_Node;

         else
            Restore_Scan_State (Scan_State); -- to the IS
         end if;
      end if;

      --  If not a generic instantiation, then we definitely have a subprogram
      --  specification (all possibilities at this stage include one here)

      Fpart_Sloc := Token_Ptr;

      Check_Misspelling_Of (Tok_Return);

      --  Scan formal part. First a special error check. If we have an
      --  identifier here, then we have a definite error. If this identifier
      --  is on the same line as the designator, then we assume it is the
      --  first formal after a missing left parenthesis

      if Token = Tok_Identifier
        and then not Token_Is_At_Start_Of_Line
      then
            T_Left_Paren; -- to generate message
            Fpart_List := P_Formal_Part;

      --  Otherwise scan out an optional formal part in the usual manner

      else
         Fpart_List := P_Parameter_Profile;
      end if;

      --  We treat what we have as a function specification if FUNCTION was
      --  used, or if a RETURN is present. This gives better error recovery
      --  since later RETURN statements will be valid in either case.

      Check_Junk_Semicolon_Before_Return;
      Return_Node := Error;

      if Token = Tok_Return then
         if not Func then
            Error_Msg ("PROCEDURE should be FUNCTION", Fproc_Sloc);
            Func := True;
         end if;

         Scan; -- past RETURN
         Return_Node := P_Subtype_Mark;
         No_Constraint;

      else
         if Func then
            Ignore (Tok_Right_Paren);
            TF_Return;
         end if;
      end if;

      if Func then
         Specification_Node :=
           New_Node (N_Function_Specification, Fproc_Sloc);
         Set_Subtype_Mark (Specification_Node, Return_Node);

      else
         Specification_Node :=
           New_Node (N_Procedure_Specification, Fproc_Sloc);
      end if;

      Set_Defining_Unit_Name (Specification_Node, Name_Node);
      Set_Parameter_Specifications (Specification_Node, Fpart_List);

      --  Error check: barriers not allowed on protected functions/procedures

      if Token = Tok_When then
         if Func then
            Error_Msg_SC ("barrier not allowed on function, only on entry");
         else
            Error_Msg_SC ("barrier not allowed on procedure, only on entry");
         end if;

         Scan; -- past WHEN
         Discard_Junk_Node (P_Expression);
      end if;

      --  Deal with case of semicolon ending a subprogram declaration

      if Token = Tok_Semicolon then
         if not Pf_Flags.Decl then
            T_Is;
         end if;

         Scan; -- past semicolon

         --  If semicolon is immediately followed by IS, then ignore the
         --  semicolon, and go process the body.

         if Token = Tok_Is then
            Error_Msg_SP ("unexpected semicolon ignored");
            T_Is; -- ignroe redundant IS's
            goto Subprogram_Body;

         --  If BEGIN follows in an appropriate column, we immediately
         --  commence the error action of assuming that the previous
         --  subprogram declaration should have been a subprogram body,
         --  i.e. that the terminating semicolon should have been IS.

         elsif Token = Tok_Begin
            and then Start_Column >= Scope.Table (Scope.Last).Ecol
         then
            Error_Msg_SP (""";"" should be IS!");
            goto Subprogram_Body;

         else
            goto Subprogram_Declaration;
         end if;

      --  Case of not followed by semicolon

      else
         --  Subprogram renaming declaration case

         Check_Misspelling_Of (Tok_Renames);

         if Token = Tok_Renames then
            if not Pf_Flags.Rnam then
               Error_Msg_SC ("renaming declaration not allowed here!");
            end if;

            Rename_Node :=
              New_Node (N_Subprogram_Renaming_Declaration, Token_Ptr);
            Scan; -- past RENAMES
            Set_Name (Rename_Node, P_Name);
            Set_Specification (Rename_Node, Specification_Node);
            TF_Semicolon;
            Pop_Scope_Stack;
            return Rename_Node;

         --  Case of IS following subprogram specification

         elsif Token = Tok_Is then
            T_Is; -- ignore redundant Is's

            if Token_Name = Name_Abstract then
               Check_95_Keyword (Tok_Abstract, Tok_Semicolon);
            end if;

            --  Deal nicely with (now obsolete) use of <> in place of abstract

            if Token = Tok_Box then
               Error_Msg_SC ("ABSTRACT expected");
               Token := Tok_Abstract;
            end if;

            --  Abstract subprogram declaration case

            if Token = Tok_Abstract then
               Absdec_Node :=
                 New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr);
               Set_Specification (Absdec_Node, Specification_Node);
               Pop_Scope_Stack; -- discard unneeded entry
               Scan; -- past ABSTRACT
               TF_Semicolon;
               return Absdec_Node;

            --  Check for IS NEW with Formal_Part present and handle nicely

            elsif Token = Tok_New then
               Error_Msg
                 ("formal part not allowed in instantiation", Fpart_Sloc);
               Scan; -- past NEW

               if Func then
                  Inst_Node := New_Node (N_Function_Instantiation, Fproc_Sloc);
               else
                  Inst_Node :=
                    New_Node (N_Procedure_Instantiation, Fproc_Sloc);
               end if;

               Set_Defining_Unit_Name (Inst_Node, Name_Node);
               Set_Name (Inst_Node, P_Name);
               Set_Generic_Associations (Inst_Node, P_Generic_Actual_Part_Opt);
               TF_Semicolon;
               Pop_Scope_Stack; -- Don't need scope stack entry in this case
               return Inst_Node;

            else
               goto Subprogram_Body;
            end if;

         --  Here we have a missing IS or missing semicolon, we always guess
         --  a missing semicolon, since we are pretty good at fixing up a
         --  semicolon which should really be an IS

         else
            Error_Msg_AP ("missing "";""");
            SIS_Missing_Semicolon_Message := Get_Msg_Id;
            goto Subprogram_Declaration;
         end if;
      end if;

      --  Processing for subprogram body

      <<Subprogram_Body>>
         if not Pf_Flags.Pbod then
            Error_Msg_SP ("subprogram body not allowed here!");
         end if;

         --  Subprogram body stub case

         if Separate_Present then
            if not Pf_Flags.Stub then
               Error_Msg_SC ("body stub not allowed here!");
            end if;

            if Nkind (Name_Node) = N_Defining_Operator_Symbol then
               Error_Msg
                 ("operator symbol cannot be used as subunit name",
                  Sloc (Name_Node));
            end if;

            Stub_Node :=
              New_Node (N_Subprogram_Body_Stub, Sloc (Specification_Node));
            Set_Specification (Stub_Node, Specification_Node);
            Scan; -- past SEPARATE
            Pop_Scope_Stack;
            TF_Semicolon;
            return Stub_Node;

         --  Subprogram body case

         else
            --  Here is the test for a suspicious IS (i.e. one that looks
            --  like it might more properly be a semicolon). See separate
            --  section discussing use of IS instead of semicolon in
            --  package Parse.

            if (Token in Token_Class_Declk
                  or else
                Token = Tok_Identifier)
              and then Start_Column <= Scope.Table (Scope.Last).Ecol
              and then Scope.Last /= 1
            then
               Scope.Table (Scope.Last).Etyp := E_Suspicious_Is;
               Scope.Table (Scope.Last).S_Is := Prev_Token_Ptr;
            end if;

            Body_Node :=
              New_Node (N_Subprogram_Body, Sloc (Specification_Node));
            Set_Specification (Body_Node, Specification_Node);
            Parse_Decls_Begin_End (Body_Node);
            return Body_Node;
         end if;

      --  Processing for subprogram declaration

      <<Subprogram_Declaration>>
         Decl_Node :=
           New_Node (N_Subprogram_Declaration, Sloc (Specification_Node));
         Set_Specification (Decl_Node, Specification_Node);

         --  If this is a context in which a subprogram body is permitted,
         --  set active SIS entry in case (see section titled "Handling
         --  Semicolon Used in Place of IS" in body of Parser package)
         --  Note that SIS_Missing_Semicolon_Message is already set properly.

         if Pf_Flags.Pbod then
            SIS_Labl := Scope.Table (Scope.Last).Labl;
            SIS_Sloc := Scope.Table (Scope.Last).Sloc;
            SIS_Ecol := Scope.Table (Scope.Last).Ecol;
            SIS_Declaration_Node := Decl_Node;
            SIS_Semicolon_Sloc := Prev_Token_Ptr;
            SIS_Entry_Active := True;
         end if;

         Pop_Scope_Stack;
         return Decl_Node;

   end P_Subprogram;

   ---------------------------------
   -- 6.1  Subprogram Declaration --
   ---------------------------------

   --  Parsed by P_Subprogram (6.1)

   ------------------------------------------
   -- 6.1  Abstract Subprogram Declaration --
   ------------------------------------------

   --  Parsed by P_Subprogram (6.1)

   -----------------------------------
   -- 6.1  Subprogram Specification --
   -----------------------------------

   --  SUBPROGRAM_SPECIFICATION ::=
   --      procedure DEFINING_PROGRAM_UNIT_NAME PARAMETER_PROFILE
   --    | function DEFINING_DESIGNATOR PARAMETER_AND_RESULT_PROFILE

   --  PARAMETER_PROFILE ::= [FORMAL_PART]

   --  PARAMETER_AND_RESULT_PROFILE ::= [FORMAL_PART] return SUBTYPE_MARK

   --  Subprogram specifications that appear in subprogram declarations
   --  are parsed by P_Subprogram (6.1). This routine is used in other
   --  contexts where subprogram specifications occur.

   --  Note: this routine does not affect the scope stack in any way

   --  Error recovery: can raise Error_Resync

   function P_Subprogram_Specification return Node_Id is
      Specification_Node : Node_Id;

   begin
      if Token = Tok_Function then
         Specification_Node := New_Node (N_Function_Specification, Token_Ptr);
         Scan; -- past FUNCTION
         Ignore (Tok_Body);
         Set_Defining_Unit_Name (Specification_Node, P_Defining_Designator);
         Set_Parameter_Specifications
           (Specification_Node, P_Parameter_Profile);
         Check_Junk_Semicolon_Before_Return;
         TF_Return;
         Set_Subtype_Mark (Specification_Node, P_Subtype_Mark);
         No_Constraint;
         return Specification_Node;

      elsif Token = Tok_Procedure then
         Specification_Node := New_Node (N_Procedure_Specification, Token_Ptr);
         Scan; -- past PROCEDURE
         Ignore (Tok_Body);
         Set_Defining_Unit_Name
           (Specification_Node, P_Defining_Program_Unit_Name);
         Set_Parameter_Specifications
           (Specification_Node, P_Parameter_Profile);
         return Specification_Node;

      else
         Error_Msg_SC ("subprogram specification expected");
         raise Error_Resync;
      end if;
   end P_Subprogram_Specification;

   ---------------------
   -- 6.1  Designator --
   ---------------------

   --  DESIGNATOR ::=
   --    [PARENT_UNIT_NAME .] IDENTIFIER | OPERATOR_SYMBOL

   --  The caller has checked that the initial token is an identifier,
   --  operator symbol, or string literal. Note that we don't bother to
   --  do much error diagnosis in this routine, since it is only used for
   --  the label on END lines, and the routines in package Par.Endh will
   --  check that the label is appropriate.

   --  Error recovery: cannot raise Error_Resync

   function P_Designator return Node_Id is
      Ident_Node  : Node_Id;
      Name_Node   : Node_Id;
      Prefix_Node : Node_Id;

      function Real_Dot return Boolean;
      --  Tests if a current token is an interesting period, i.e. is followed
      --  by an identifier or operator symbol or string literal. If not, it is
      --  probably just incorrect punctuation to be caught by our caller. Note
      --  that the case of an operator symbol or string literal is also an
      --  error, but that is an error that we catch here. If the result is
      --  True, a real dot has been scanned and we are positioned past it,
      --  if the result is False, the scan position is unchanged.

      function Real_Dot return Boolean is
         Scan_State  : Saved_Scan_State;

      begin
         if Token /= Tok_Dot then
            return False;

         else
            Save_Scan_State (Scan_State);
            Scan; -- past dot

            if Token = Tok_Identifier
              or else Token = Tok_Operator_Symbol
              or else Token = Tok_String_Literal
            then
               return True;

            else
               Restore_Scan_State (Scan_State);
               return False;
            end if;
         end if;
      end Real_Dot;

   --  Start of processing for P_Designator

   begin
      Ident_Node := Token_Node;
      Scan; -- past initial token

      if Prev_Token = Tok_Operator_Symbol
        or else Prev_Token = Tok_String_Literal
        or else not Real_Dot
      then
         return Ident_Node;

      --  Child name case

      else
         Prefix_Node := Ident_Node;

         --  Loop through child names, on entry to this loop, Prefix contains
         --  the name scanned so far, and Ident_Node is the last identifier.

         loop
            Name_Node := New_Node (N_Selected_Component, Prev_Token_Ptr);
            Set_Prefix (Name_Node, Prefix_Node);
            Ident_Node := P_Identifier;
            Set_Selector_Name (Name_Node, Ident_Node);
            Prefix_Node := Name_Node;
            exit when not Real_Dot;
         end loop;

         --  On exit from the loop, Ident_Node is the last identifier scanned,
         --  i.e. the defining identifier, and Prefix_Node is a node for the
         --  entire name, structured (incorrectly!) as a selected component.

         Name_Node := Prefix (Prefix_Node);
         Change_Node (Prefix_Node, N_Designator);
         Set_Name (Prefix_Node, Name_Node);
         Set_Identifier (Prefix_Node, Ident_Node);
         return Prefix_Node;
      end if;

   exception
      when Error_Resync =>
         while Token = Tok_Dot or else Token = Tok_Identifier loop
            Scan;
         end loop;

         return Error;
   end P_Designator;

   ------------------------------
   -- 6.1  Defining Designator --
   ------------------------------

   --  DEFINING_DESIGNATOR ::=
   --    DEFINING_PROGRAM_UNIT_NAME | DEFINING_OPERATOR_SYMBOL

   --  Error recovery: cannot raise Error_Resync

   function P_Defining_Designator return Node_Id is
   begin
      if Token = Tok_Operator_Symbol then
         return P_Defining_Operator_Symbol;

      elsif Token = Tok_String_Literal then
         Error_Msg_SC ("invalid operator name");
         Scan; -- past junk string
         return Error;

      else
         return P_Defining_Program_Unit_Name;
      end if;
   end P_Defining_Designator;

   -------------------------------------
   -- 6.1  Defining Program Unit Name --
   -------------------------------------

   --  DEFINING_PROGRAM_UNIT_NAME ::=
   --    [PARENT_UNIT_NAME .] DEFINING_IDENTIFIER

   --  Note: PARENT_UNIT_NAME may be present only in 95 mode at the outer level

   --  Error recovery: cannot raise Error_Resync

   function P_Defining_Program_Unit_Name return Node_Id is
      Ident_Node  : Node_Id;
      Name_Node   : Node_Id;
      Prefix_Node : Node_Id;

   begin
      --  Set identifier casing if not already set and scan initial identifier

      if Token = Tok_Identifier
        and then Identifier_Casing (Current_Source_File) = Unknown
      then
         Set_Identifier_Casing (Current_Source_File, Determine_Token_Casing);
      end if;

      Ident_Node := P_Identifier;
      Merge_Identifier (Ident_Node, Tok_Return);

      --  Normal case (not child library unit name)

      if Token /= Tok_Dot then
         Change_Identifier_To_Defining_Identifier (Ident_Node);
         return Ident_Node;

      --  Child library unit name case

      else
         if Scope.Last > 1 then
            Error_Msg_SP ("child unit allowed only at library level");
            raise Error_Resync;

         elsif Ada_83 then
            Error_Msg_SP ("(Ada 83) child unit not allowed!");

         end if;

         Prefix_Node := Ident_Node;

         --  Loop through child names, on entry to this loop, Prefix contains
         --  the name scanned so far, and Ident_Node is the last identifier.

         loop
            exit when Token /= Tok_Dot;
            Name_Node := New_Node (N_Selected_Component, Token_Ptr);
            Scan; -- past period
            Set_Prefix (Name_Node, Prefix_Node);
            Ident_Node := P_Identifier;
            Set_Selector_Name (Name_Node, Ident_Node);
            Prefix_Node := Name_Node;
         end loop;

         --  On exit from the loop, Ident_Node is the last identifier scanned,
         --  i.e. the defining identifier, and Prefix_Node is a node for the
         --  entire name, structured (incorrectly!) as a selected component.

         Name_Node := Prefix (Prefix_Node);
         Change_Node (Prefix_Node, N_Defining_Program_Unit_Name);
         Set_Name (Prefix_Node, Name_Node);
         Change_Identifier_To_Defining_Identifier (Ident_Node);
         Set_Defining_Identifier (Prefix_Node, Ident_Node);

         --  All set with unit name parsed

         return Prefix_Node;
      end if;

   exception
      when Error_Resync =>
         while Token = Tok_Dot or else Token = Tok_Identifier loop
            Scan;
         end loop;

         return Error;
   end P_Defining_Program_Unit_Name;

   --------------------------
   -- 6.1  Operator Symbol --
   --------------------------

   --  OPERATOR_SYMBOL ::= STRING_LITERAL

   --  Operator symbol is returned by the scanner as Tok_Operator_Symbol

   -----------------------------------
   -- 6.1  Defining Operator Symbol --
   -----------------------------------

   --  DEFINING_OPERATOR_SYMBOL ::= OPERATOR_SYMBOL

   --  The caller has checked that the initial symbol is an operator symbol

   function P_Defining_Operator_Symbol return Node_Id is
      Op_Node : Node_Id;

   begin
      Op_Node := Token_Node;
      Change_Operator_Symbol_To_Defining_Operator_Symbol (Op_Node);
      Scan; -- past operator symbol
      return Op_Node;
   end P_Defining_Operator_Symbol;

   ----------------------------
   -- 6.1  Parameter_Profile --
   ----------------------------

   --  PARAMETER_PROFILE ::= [FORMAL_PART]

   --  Empty is returned if no formal part is present

   --  Error recovery: cannot raise Error_Resync

   function P_Parameter_Profile return List_Id is
   begin
      if Token = Tok_Left_Paren then
         Scan; -- part left paren
         return P_Formal_Part;
      else
         return No_List;
      end if;
   end P_Parameter_Profile;

   ---------------------------------------
   -- 6.1  Parameter And Result Profile --
   ---------------------------------------

   --  Parsed by its parent construct, which uses P_Parameter_Profile to
   --  parse the parameters, and P_Subtype_Mark to parse the return type.

   ----------------------
   -- 6.1  Formal part --
   ----------------------

   --  FORMAL_PART ::= (PARAMETER_SPECIFICATION {; PARAMETER_SPECIFICATION})

   --  PARAMETER_SPECIFICATION ::=
   --    DEFINING_IDENTIFIER_LIST : MODE SUBTYPE_MARK
   --      [:= DEFAULT_EXPRESSION]
   --  | DEFINING_IDENTIFIER_LIST : ACCESS_DEFINITION
   --      [:= DEFAULT_EXPRESSION]

   --  This scans the construct Formal_Part. The caller has already checked
   --  that the initial token is a left parenthesis, and skipped past it, so
   --  that on entry Token is the first token following the left parenthesis.

   --  Error recovery: cannot raise Error_Resync

   function P_Formal_Part return List_Id is
      Specification_List : List_Id;
      Specification_Node : Node_Id;
      Scan_State         : Saved_Scan_State;
      Num_Idents         : Nat;
      Ident              : Nat;
      Ident_Sloc         : Source_Ptr;

      Idents : array (Int range 1 .. 4096) of Entity_Id;
      --  This array holds the list of defining identifiers. The upper bound
      --  of 4096 is intended to be essentially infinite, and we do not even
      --  bother to check for it being exceeded.

   begin
      Specification_List := New_List;

      Specification_Loop : loop
         begin
            if Token = Tok_Pragma then
               P_Pragmas_Misplaced;
            end if;

            Ignore (Tok_Left_Paren);
            Ident_Sloc := Token_Ptr;
            Idents (1) := P_Defining_Identifier;
            Num_Idents := 1;

            Ident_Loop : loop
               exit Ident_Loop when Token = Tok_Colon;

               --  The only valid tokens are colon and comma, so if we have
               --  neither do a bit of investigation to see which is the
               --  better choice for insertion.

               if Token /= Tok_Comma then

                  --  Assume colon if IN or OUT keyword found

                  exit Ident_Loop when Token = Tok_In or else Token = Tok_Out;

                  --  Otherwise scan ahead

                  Save_Scan_State (Scan_State);
                  Look_Ahead : loop

                     --  If we run into a semicolon, then assume that a
                     --  colon was missing, e.g.  Parms (X Y; ...). Also
                     --  assume missing colon on EOF (a real disaster!)
                     --  and on a right paren, e.g. Parms (X Y), and also
                     --  on an assignment symbol, e.g. Parms (X Y := ..)

                     if Token = Tok_Semicolon
                       or else Token = Tok_Right_Paren
                       or else Token = Tok_EOF
                       or else Token = Tok_Colon_Equal
                     then
                        Restore_Scan_State (Scan_State);
                        exit Ident_Loop;

                     --  If we run into a colon, assume that we had a missing
                     --  comma, e.g. Parms (A B : ...). Also assume a missing
                     --  comma if we hit another comma, e.g. Parms (A B, C ..)

                     elsif Token = Tok_Colon
                       or else Token = Tok_Comma
                     then
                        Restore_Scan_State (Scan_State);
                        exit Look_Ahead;
                     end if;

                     Scan;
                  end loop Look_Ahead;
               end if;

               --  Here if a comma is present, or to be assumed

               T_Comma;
               Num_Idents := Num_Idents + 1;
               Idents (Num_Idents) := P_Defining_Identifier;
            end loop Ident_Loop;

            --  Fall through the loop on encountering a colon, or deciding
            --  that there is a missing colon.

            T_Colon;

            --  If there are multiple identifiers, we repeatedly scan the
            --  type and initialization expression information by resetting
            --  the scan pointer (so that we get completely separate trees
            --  for each occurrence).

            if Num_Idents > 1 then
               Save_Scan_State (Scan_State);
            end if;

            --  Loop through defining identifiers in list

            Ident := 1;

            Ident_List_Loop : loop
               Specification_Node :=
                 New_Node (N_Parameter_Specification, Ident_Sloc);
               Set_Defining_Identifier (Specification_Node, Idents (Ident));

               if Token = Tok_Access then
                  if Ada_83 then
                     Error_Msg_SC ("(Ada 83) access parameters not allowed");
                  end if;

                  Set_Parameter_Type
                    (Specification_Node, P_Access_Definition);

               else
                  P_Mode (Specification_Node);

                  if Token = Tok_Procedure
                       or else
                     Token = Tok_Function
                  then
                     Error_Msg_SC ("formal subprogram parameter not allowed");
                     Scan;

                     if Token = Tok_Left_Paren then
                        Discard_Junk_List (P_Formal_Part);
                     end if;

                     if Token = Tok_Return then
                        Scan;
                        Discard_Junk_Node (P_Subtype_Mark);
                     end if;

                     Set_Parameter_Type (Specification_Node, Error);

                  else
                     Set_Parameter_Type (Specification_Node, P_Subtype_Mark);
                     No_Constraint;
                  end if;
               end if;

               Set_Expression (Specification_Node, Init_Expr_Opt (True));

               if Ident > 1 then
                  Set_Prev_Ids (Specification_Node, True);
               end if;

               if Ident < Num_Idents then
                  Set_More_Ids (Specification_Node, True);
               end if;

               Append (Specification_Node, Specification_List);
               exit Ident_List_Loop when Ident = Num_Idents;
               Ident := Ident + 1;
               Restore_Scan_State (Scan_State);
            end loop Ident_List_Loop;

         exception
            when Error_Resync =>
               Resync_Semicolon_List;
         end;

         if Token = Tok_Semicolon then
            Scan; -- past semicolon

            --  If we have RETURN or IS after the semicolon, then assume
            --  that semicolon should have been a right parenthesis and exit

            if Token = Tok_Is or else Token = Tok_Return then
               Error_Msg_SP ("expected "")"" in place of "";""");
               exit Specification_Loop;
            end if;

         elsif Token = Tok_Right_Paren then
            Scan; -- past right paren
            exit Specification_Loop;

         --  Special check for common error of using comma instead of semicolon

         elsif Token = Tok_Comma then
            T_Semicolon;
            Scan; -- past comma

         --  Special check for omitted separator

         elsif Token = Tok_Identifier then
            T_Semicolon;

         --  If nothing sensible, skip to next semicolon or right paren

         else
            T_Semicolon;
            Resync_Semicolon_List;

            if Token = Tok_Semicolon then
               Scan; -- past semicolon
            else
               T_Right_Paren;
               exit Specification_Loop;
            end if;
         end if;
      end loop Specification_Loop;

      return Specification_List;
   end P_Formal_Part;

   ----------------------------------
   -- 6.1  Parameter Specification --
   ----------------------------------

   --  Parsed by P_Formal_Part (6.1)

   ---------------
   -- 6.1  Mode --
   ---------------

   --  MODE ::= [in] | in out | out

   --  There is no explicit node in the tree for the Mode. Instead the
   --  In_Present and Out_Present flags are set in the parent node to
   --  record the presence of keywords specifying the mode.

   --  Error_Recovery: cannot raise Error_Resync

   procedure P_Mode (Node : Node_Id) is
   begin
      if Token = Tok_In then
         Scan; -- past IN
         Set_In_Present (Node, True);
      end if;

      if Token = Tok_Out then
         Scan; -- past OUT
         Set_Out_Present (Node, True);
      end if;

      if Token = Tok_In then
1086
         Error_Msg_SC ("IN must precede OUT in parameter mode");
Richard Kenner committed
1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165
         Scan; -- past IN
         Set_In_Present (Node, True);
      end if;
   end P_Mode;

   --------------------------
   -- 6.3  Subprogram Body --
   --------------------------

   --  Parsed by P_Subprogram (6.1)

   -----------------------------------
   -- 6.4  Procedure Call Statement --
   -----------------------------------

   --  Parsed by P_Sequence_Of_Statements (5.1)

   ------------------------
   -- 6.4  Function Call --
   ------------------------

   --  Parsed by P_Call_Or_Name (4.1)

   --------------------------------
   -- 6.4  Actual Parameter Part --
   --------------------------------

   --  Parsed by P_Call_Or_Name (4.1)

   --------------------------------
   -- 6.4  Parameter Association --
   --------------------------------

   --  Parsed by P_Call_Or_Name (4.1)

   ------------------------------------
   -- 6.4  Explicit Actual Parameter --
   ------------------------------------

   --  Parsed by P_Call_Or_Name (4.1)

   ---------------------------
   -- 6.5  Return Statement --
   ---------------------------

   --  RETURN_STATEMENT ::= return [EXPRESSION];

   --  The caller has checked that the initial token is RETURN

   --  Error recovery: can raise Error_Resync

   function P_Return_Statement return Node_Id is
      Return_Node : Node_Id;

   begin
      Return_Node := New_Node (N_Return_Statement, Token_Ptr);

      --  Sloc points to RETURN
      --  Expression (Op3)

      Scan; -- past RETURN

      if Token /= Tok_Semicolon then

         --  If no semicolon, then scan an expression, except that
         --  we avoid trying to scan an expression if we are at an
         --  expression terminator since in that case the best error
         --  message is probably that we have a missing semicolon.

         if Token not in Token_Class_Eterm then
            Set_Expression (Return_Node, P_Expression_No_Right_Paren);
         end if;
      end if;

      TF_Semicolon;
      return Return_Node;
   end P_Return_Statement;

end Ch6;