gcc/ada/par-ch7.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P A R . C H 7                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2008, 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
  26 pragma Style_Checks (All_Checks);
  27 --  Turn off subprogram body ordering check. Subprograms are in order
  28 --  by RM section rather than alphabetical
  29
  30 separate (Par)
  31 package body Ch7 is
  32
  33    ---------------------------------------------
  34    -- 7.1  Package (also 8.5.3, 10.1.3, 12.3) --
  35    ---------------------------------------------
  36
  37    --  This routine scans out a package declaration, package body, or a
  38    --  renaming declaration or generic instantiation starting with PACKAGE
  39
  40    --  PACKAGE_DECLARATION ::= PACKAGE_SPECIFICATION;
  41
  42    --  PACKAGE_SPECIFICATION ::=
  43    --    package DEFINING_PROGRAM_UNIT_NAME is
  44    --      {BASIC_DECLARATIVE_ITEM}
  45    --    [private
  46    --      {BASIC_DECLARATIVE_ITEM}]
  47    --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
  48
  49    --  PACKAGE_BODY ::=
  50    --    package body DEFINING_PROGRAM_UNIT_NAME is
  51    --      DECLARATIVE_PART
  52    --    [begin
  53    --      HANDLED_SEQUENCE_OF_STATEMENTS]
  54    --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
  55
  56    --  PACKAGE_RENAMING_DECLARATION ::=
  57    --    package DEFINING_IDENTIFIER renames package_NAME;
  58
  59    --  PACKAGE_BODY_STUB ::=
  60    --    package body DEFINING_IDENTIFIER is separate;
  61
  62    --  The value in Pf_Flags indicates which of these possible declarations
  63    --  is acceptable to the caller:
  64
  65    --    Pf_Flags.Spcn                 Set if specification OK
  66    --    Pf_Flags.Decl                 Set if declaration OK
  67    --    Pf_Flags.Gins                 Set if generic instantiation OK
  68    --    Pf_Flags.Pbod                 Set if proper body OK
  69    --    Pf_Flags.Rnam                 Set if renaming declaration OK
  70    --    Pf_Flags.Stub                 Set if body stub OK
  71
  72    --  If an inappropriate form is encountered, it is scanned out but an
  73    --  error message indicating that it is appearing in an inappropriate
  74    --  context is issued. The only possible settings for Pf_Flags are those
  75    --  defined as constants in package Par.
  76
  77    --  Note: in all contexts where a package specification is required, there
  78    --  is a terminating semicolon. This semicolon is scanned out in the case
  79    --  where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
  80    --  of the package specification (it's just too much trouble, and really
  81    --  quite unnecessary, to deal with scanning out an END where the semicolon
  82    --  after the END is not considered to be part of the END.
  83
  84    --  The caller has checked that the initial token is PACKAGE
  85
  86    --  Error recovery: cannot raise Error_Resync
  87
  88    function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
  89       Package_Node       : Node_Id;
  90       Specification_Node : Node_Id;
  91       Name_Node          : Node_Id;
  92       Package_Sloc       : Source_Ptr;
  93
  94    begin
  95       Push_Scope_Stack;
  96       Scope.Table (Scope.Last).Etyp := E_Name;
  97       Scope.Table (Scope.Last).Ecol := Start_Column;
  98       Scope.Table (Scope.Last).Lreq := False;
  99
 100       Package_Sloc := Token_Ptr;
 101       Scan; -- past PACKAGE
 102
 103       if Token = Tok_Type then
 104          Error_Msg_SC ("TYPE not allowed here");
 105          Scan; -- past TYPE
 106       end if;
 107
 108       --  Case of package body. Note that we demand a package body if that
 109       --  is the only possibility (even if the BODY keyword is not present)
 110
 111       if Token = Tok_Body or else Pf_Flags = Pf_Pbod then
 112          if not Pf_Flags.Pbod then
 113             Error_Msg_SC ("package body cannot appear here!");
 114          end if;
 115
 116          T_Body;
 117          Name_Node := P_Defining_Program_Unit_Name;
 118          Scope.Table (Scope.Last).Labl := Name_Node;
 119          TF_Is;
 120
 121          if Separate_Present then
 122             if not Pf_Flags.Stub then
 123                Error_Msg_SC ("body stub cannot appear here!");
 124             end if;
 125
 126             Scan; -- past SEPARATE
 127             TF_Semicolon;
 128             Pop_Scope_Stack;
 129
 130             Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
 131             Set_Defining_Identifier (Package_Node, Name_Node);
 132
 133          else
 134             Package_Node := New_Node (N_Package_Body, Package_Sloc);
 135             Set_Defining_Unit_Name (Package_Node, Name_Node);
 136             Parse_Decls_Begin_End (Package_Node);
 137          end if;
 138
 139          return Package_Node;
 140
 141       --  Cases other than Package_Body
 142
 143       else
 144          Name_Node := P_Defining_Program_Unit_Name;
 145          Scope.Table (Scope.Last).Labl := Name_Node;
 146
 147          --  Case of renaming declaration
 148
 149          Check_Misspelling_Of (Tok_Renames);
 150
 151          if Token = Tok_Renames then
 152             if not Pf_Flags.Rnam then
 153                Error_Msg_SC ("renaming declaration cannot appear here!");
 154             end if;
 155
 156             Scan; -- past RENAMES;
 157
 158             Package_Node :=
 159               New_Node (N_Package_Renaming_Declaration, Package_Sloc);
 160             Set_Defining_Unit_Name (Package_Node, Name_Node);
 161             Set_Name (Package_Node, P_Qualified_Simple_Name);
 162
 163             No_Constraint;
 164             TF_Semicolon;
 165             Pop_Scope_Stack;
 166             return Package_Node;
 167
 168          else
 169             TF_Is;
 170
 171             --  Case of generic instantiation
 172
 173             if Token = Tok_New then
 174                if not Pf_Flags.Gins then
 175                   Error_Msg_SC
 176                      ("generic instantiation cannot appear here!");
 177                end if;
 178
 179                Scan; -- past NEW
 180
 181                Package_Node :=
 182                   New_Node (N_Package_Instantiation, Package_Sloc);
 183                Set_Defining_Unit_Name (Package_Node, Name_Node);
 184                Set_Name (Package_Node, P_Qualified_Simple_Name);
 185                Set_Generic_Associations
 186                  (Package_Node, P_Generic_Actual_Part_Opt);
 187                TF_Semicolon;
 188                Pop_Scope_Stack;
 189
 190             --  Case of package declaration or package specification
 191
 192             else
 193                Specification_Node :=
 194                  New_Node (N_Package_Specification, Package_Sloc);
 195
 196                Set_Defining_Unit_Name (Specification_Node, Name_Node);
 197                Set_Visible_Declarations
 198                  (Specification_Node, P_Basic_Declarative_Items);
 199
 200                if Token = Tok_Private then
 201                   Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
 202
 203                   if RM_Column_Check then
 204                      if Token_Is_At_Start_Of_Line
 205                        and then Start_Column /= Error_Msg_Col
 206                      then
 207                         Error_Msg_SC
 208                           ("(style) PRIVATE in wrong column, should be@");
 209                      end if;
 210                   end if;
 211
 212                   Scan; -- past PRIVATE
 213                   Set_Private_Declarations
 214                     (Specification_Node, P_Basic_Declarative_Items);
 215
 216                   --  Deal gracefully with multiple PRIVATE parts
 217
 218                   while Token = Tok_Private loop
 219                      Error_Msg_SC
 220                        ("only one private part allowed per package");
 221                      Scan; -- past PRIVATE
 222                      Append_List (P_Basic_Declarative_Items,
 223                        Private_Declarations (Specification_Node));
 224                   end loop;
 225                end if;
 226
 227                if Pf_Flags = Pf_Spcn then
 228                   Package_Node := Specification_Node;
 229                else
 230                   Package_Node :=
 231                     New_Node (N_Package_Declaration, Package_Sloc);
 232                   Set_Specification (Package_Node, Specification_Node);
 233                end if;
 234
 235                if Token = Tok_Begin then
 236                   Error_Msg_SC ("begin block not allowed in package spec");
 237                   Scan; -- past BEGIN
 238                   Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
 239                end if;
 240
 241                End_Statements (Specification_Node);
 242             end if;
 243
 244             return Package_Node;
 245          end if;
 246       end if;
 247    end P_Package;
 248
 249    ------------------------------
 250    -- 7.1  Package Declaration --
 251    ------------------------------
 252
 253    --  Parsed by P_Package (7.1)
 254
 255    --------------------------------
 256    -- 7.1  Package Specification --
 257    --------------------------------
 258
 259    --  Parsed by P_Package (7.1)
 260
 261    -----------------------
 262    -- 7.1  Package Body --
 263    -----------------------
 264
 265    --  Parsed by P_Package (7.1)
 266
 267    -----------------------------------
 268    -- 7.3  Private Type Declaration --
 269    -----------------------------------
 270
 271    --  Parsed by P_Type_Declaration (3.2.1)
 272
 273    ----------------------------------------
 274    -- 7.3  Private Extension Declaration --
 275    ----------------------------------------
 276
 277    --  Parsed by P_Type_Declaration (3.2.1)
 278
 279 end Ch7;