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