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