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-2017, 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 ::=
  41    --    PACKAGE_SPECIFICATION;
  42
  43    --  PACKAGE_SPECIFICATION ::=
  44    --    package DEFINING_PROGRAM_UNIT_NAME
  45    --      [ASPECT_SPECIFICATIONS]
  46    --    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
  54    --      [ASPECT_SPECIFICATIONS]
  55    --    is
  56    --      DECLARATIVE_PART
  57    --    [begin
  58    --      HANDLED_SEQUENCE_OF_STATEMENTS]
  59    --    end [[PARENT_UNIT_NAME .] IDENTIFIER]
  60
  61    --  PACKAGE_RENAMING_DECLARATION ::=
  62    --    package DEFINING_IDENTIFIER renames package_NAME
  63    --      [ASPECT_SPECIFICATIONS];
  64
  65    --  PACKAGE_BODY_STUB ::=
  66    --    package body DEFINING_IDENTIFIER is separate
  67    --      [ASPECT_SPECIFICATIONS];
  68
  69    --  PACKAGE_INSTANTIATION ::=
  70    --    package DEFINING_PROGRAM_UNIT_NAME is
  71    --      new generic_package_NAME [GENERIC_ACTUAL_PART]
  72    --        [ASPECT_SPECIFICATIONS];
  73
  74    --  The value in Pf_Flags indicates which of these possible declarations
  75    --  is acceptable to the caller:
  76
  77    --    Pf_Flags.Spcn                 Set if specification OK
  78    --    Pf_Flags.Decl                 Set if declaration OK
  79    --    Pf_Flags.Gins                 Set if generic instantiation OK
  80    --    Pf_Flags.Pbod                 Set if proper body OK
  81    --    Pf_Flags.Rnam                 Set if renaming declaration OK
  82    --    Pf_Flags.Stub                 Set if body stub OK
  83
  84    --  If an inappropriate form is encountered, it is scanned out but an error
  85    --  message indicating that it is appearing in an inappropriate context is
  86    --  issued. The only possible settings for Pf_Flags are those defined as
  87    --  constants in package Par.
  88
  89    --  Note: in all contexts where a package specification is required, there
  90    --  is a terminating semicolon. This semicolon is scanned out in the case
  91    --  where Pf_Flags is set to Pf_Spcn, even though it is not strictly part
  92    --  of the package specification (it's just too much trouble, and really
  93    --  quite unnecessary, to deal with scanning out an END where the semicolon
  94    --  after the END is not considered to be part of the END.
  95
  96    --  The caller has checked that the initial token is PACKAGE
  97
  98    --  Error recovery: cannot raise Error_Resync
  99
 100    function P_Package (Pf_Flags : Pf_Rec) return Node_Id is
 101       Package_Node       : Node_Id;
 102       Specification_Node : Node_Id;
 103       Name_Node          : Node_Id;
 104       Package_Sloc       : Source_Ptr;
 105
 106       Aspect_Sloc : Source_Ptr := No_Location;
 107       --  Save location of WITH for scanned aspects. Left set to No_Location
 108       --  if no aspects scanned before the IS keyword.
 109
 110       Is_Sloc : Source_Ptr;
 111       --  Save location of IS token for package declaration
 112
 113       Dummy_Node : constant Node_Id :=
 114                      New_Node (N_Package_Specification, Token_Ptr);
 115       --  Dummy node to attach aspect specifications to until we properly
 116       --  figure out where they eventually belong.
 117
 118       Body_Is_Hidden_In_SPARK         : Boolean;
 119       Private_Part_Is_Hidden_In_SPARK : Boolean;
 120       Hidden_Region_Start             : Source_Ptr;
 121
 122    begin
 123       Push_Scope_Stack;
 124       Scope.Table (Scope.Last).Etyp := E_Name;
 125       Scope.Table (Scope.Last).Ecol := Start_Column;
 126       Scope.Table (Scope.Last).Lreq := False;
 127
 128       Package_Sloc := Token_Ptr;
 129       Scan; -- past PACKAGE
 130
 131       if Token = Tok_Type then
 132          Error_Msg_SC -- CODEFIX
 133            ("TYPE not allowed here");
 134          Scan; -- past TYPE
 135       end if;
 136
 137       --  Case of package body. Note that we demand a package body if that
 138       --  is the only possibility (even if the BODY keyword is not present)
 139
 140       if Token = Tok_Body or else Pf_Flags = Pf_Pbod_Pexp then
 141          if not Pf_Flags.Pbod then
 142             Error_Msg_SC ("package body cannot appear here!");
 143          end if;
 144
 145          T_Body;
 146          Scope.Table (Scope.Last).Sloc := Token_Ptr;
 147          Name_Node := P_Defining_Program_Unit_Name;
 148          Scope.Table (Scope.Last).Labl := Name_Node;
 149          Current_Node := Name_Node;
 150
 151          if Aspect_Specifications_Present then
 152             Aspect_Sloc := Token_Ptr;
 153             P_Aspect_Specifications (Dummy_Node, Semicolon => False);
 154          end if;
 155
 156          TF_Is;
 157
 158          if Separate_Present then
 159             if not Pf_Flags.Stub then
 160                Error_Msg_SC ("body stub cannot appear here!");
 161             end if;
 162
 163             Scan; -- past SEPARATE
 164
 165             Package_Node := New_Node (N_Package_Body_Stub, Package_Sloc);
 166             Set_Defining_Identifier (Package_Node, Name_Node);
 167
 168             if Has_Aspects (Dummy_Node) then
 169                Error_Msg
 170                  ("aspect specifications must come after SEPARATE",
 171                   Aspect_Sloc);
 172             end if;
 173
 174             P_Aspect_Specifications (Package_Node, Semicolon => False);
 175             TF_Semicolon;
 176             Pop_Scope_Stack;
 177
 178          else
 179             Package_Node := New_Node (N_Package_Body, Package_Sloc);
 180             Set_Defining_Unit_Name (Package_Node, Name_Node);
 181
 182             --  Move the aspect specifications to the body node
 183
 184             if Has_Aspects (Dummy_Node) then
 185                Move_Aspects (From => Dummy_Node, To => Package_Node);
 186             end if;
 187
 188             --  In SPARK, a HIDE directive can be placed at the beginning of a
 189             --  package implementation, thus hiding the package body from SPARK
 190             --  tool-set. No violation of the SPARK restriction should be
 191             --  issued on nodes in a hidden part, which is obtained by marking
 192             --  such hidden parts.
 193
 194             if Token = Tok_SPARK_Hide then
 195                Body_Is_Hidden_In_SPARK := True;
 196                Hidden_Region_Start     := Token_Ptr;
 197                Scan; -- past HIDE directive
 198             else
 199                Body_Is_Hidden_In_SPARK := False;
 200             end if;
 201
 202             Parse_Decls_Begin_End (Package_Node);
 203
 204             if Body_Is_Hidden_In_SPARK then
 205                Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
 206             end if;
 207          end if;
 208
 209       --  Cases other than Package_Body
 210
 211       else
 212          Scope.Table (Scope.Last).Sloc := Token_Ptr;
 213          Name_Node := P_Defining_Program_Unit_Name;
 214          Scope.Table (Scope.Last).Labl := Name_Node;
 215          Current_Node := Name_Node;
 216
 217          --  Case of renaming declaration
 218
 219          Check_Misspelling_Of (Tok_Renames);
 220
 221          if Token = Tok_Renames then
 222             if not Pf_Flags.Rnam then
 223                Error_Msg_SC ("renaming declaration cannot appear here!");
 224             end if;
 225
 226             Scan; -- past RENAMES;
 227
 228             Package_Node :=
 229               New_Node (N_Package_Renaming_Declaration, Package_Sloc);
 230             Set_Defining_Unit_Name (Package_Node, Name_Node);
 231             Set_Name (Package_Node, P_Qualified_Simple_Name);
 232
 233             No_Constraint;
 234             P_Aspect_Specifications (Package_Node, Semicolon => False);
 235             TF_Semicolon;
 236             Pop_Scope_Stack;
 237
 238          --  Generic package instantiation or package declaration
 239
 240          else
 241             if Aspect_Specifications_Present then
 242                Aspect_Sloc := Token_Ptr;
 243                P_Aspect_Specifications (Dummy_Node, Semicolon => False);
 244             end if;
 245
 246             Is_Sloc := Token_Ptr;
 247             TF_Is;
 248
 249             --  Case of generic instantiation
 250
 251             if Token = Tok_New then
 252                if not Pf_Flags.Gins then
 253                   Error_Msg_SC
 254                      ("generic instantiation cannot appear here!");
 255                end if;
 256
 257                if Aspect_Sloc /= No_Location then
 258                   Error_Msg
 259                     ("misplaced aspects for package instantiation",
 260                      Aspect_Sloc);
 261                end if;
 262
 263                Scan; -- past NEW
 264
 265                Package_Node :=
 266                  New_Node (N_Package_Instantiation, Package_Sloc);
 267                Set_Defining_Unit_Name (Package_Node, Name_Node);
 268                Set_Name (Package_Node, P_Qualified_Simple_Name);
 269                Set_Generic_Associations
 270                  (Package_Node, P_Generic_Actual_Part_Opt);
 271
 272                if Aspect_Sloc /= No_Location
 273                  and then not Aspect_Specifications_Present
 274                then
 275                   Error_Msg_SC ("info: aspect specifications belong here??");
 276                   Move_Aspects (From => Dummy_Node, To => Package_Node);
 277                end if;
 278
 279                P_Aspect_Specifications (Package_Node);
 280                Pop_Scope_Stack;
 281
 282             --  Case of package declaration or package specification
 283
 284             else
 285                Specification_Node :=
 286                  New_Node (N_Package_Specification, Package_Sloc);
 287
 288                Set_Defining_Unit_Name (Specification_Node, Name_Node);
 289                Set_Visible_Declarations
 290                  (Specification_Node, P_Basic_Declarative_Items);
 291
 292                if Token = Tok_Private then
 293                   Error_Msg_Col := Scope.Table (Scope.Last).Ecol;
 294
 295                   if RM_Column_Check then
 296                      if Token_Is_At_Start_Of_Line
 297                        and then Start_Column /= Error_Msg_Col
 298                      then
 299                         Error_Msg_SC
 300                           ("(style) PRIVATE in wrong column, should be@");
 301                      end if;
 302                   end if;
 303
 304                   Scan; -- past PRIVATE
 305
 306                   if Token = Tok_SPARK_Hide then
 307                      Private_Part_Is_Hidden_In_SPARK := True;
 308                      Hidden_Region_Start             := Token_Ptr;
 309                      Scan; -- past HIDE directive
 310                   else
 311                      Private_Part_Is_Hidden_In_SPARK := False;
 312                   end if;
 313
 314                   Set_Private_Declarations
 315                     (Specification_Node, P_Basic_Declarative_Items);
 316
 317                   --  In SPARK, a HIDE directive can be placed at the beginning
 318                   --  of a private part, thus hiding all declarations in the
 319                   --  private part from SPARK tool-set. No violation of the
 320                   --  SPARK restriction should be issued on nodes in a hidden
 321                   --  part, which is obtained by marking such hidden parts.
 322
 323                   if Private_Part_Is_Hidden_In_SPARK then
 324                      Set_Hidden_Part_In_SPARK (Hidden_Region_Start, Token_Ptr);
 325                   end if;
 326
 327                   --  Deal gracefully with multiple PRIVATE parts
 328
 329                   while Token = Tok_Private loop
 330                      Error_Msg_SC
 331                        ("only one private part allowed per package");
 332                      Scan; -- past PRIVATE
 333                      Append_List (P_Basic_Declarative_Items,
 334                        Private_Declarations (Specification_Node));
 335                   end loop;
 336                end if;
 337
 338                if Pf_Flags = Pf_Spcn then
 339                   Package_Node := Specification_Node;
 340                else
 341                   Package_Node :=
 342                     New_Node (N_Package_Declaration, Package_Sloc);
 343                   Set_Specification (Package_Node, Specification_Node);
 344                end if;
 345
 346                if Token = Tok_Begin then
 347                   Error_Msg_SC ("begin block not allowed in package spec");
 348                   Scan; -- past BEGIN
 349                   Discard_Junk_List (P_Sequence_Of_Statements (SS_None));
 350                end if;
 351
 352                End_Statements (Specification_Node, Empty, Is_Sloc);
 353                Move_Aspects (From => Dummy_Node, To => Package_Node);
 354             end if;
 355          end if;
 356       end if;
 357
 358       return Package_Node;
 359    end P_Package;
 360
 361    ------------------------------
 362    -- 7.1  Package Declaration --
 363    ------------------------------
 364
 365    --  Parsed by P_Package (7.1)
 366
 367    --------------------------------
 368    -- 7.1  Package Specification --
 369    --------------------------------
 370
 371    --  Parsed by P_Package (7.1)
 372
 373    -----------------------
 374    -- 7.1  Package Body --
 375    -----------------------
 376
 377    --  Parsed by P_Package (7.1)
 378
 379    -----------------------------------
 380    -- 7.3  Private Type Declaration --
 381    -----------------------------------
 382
 383    --  Parsed by P_Type_Declaration (3.2.1)
 384
 385    ----------------------------------------
 386    -- 7.3  Private Extension Declaration --
 387    ----------------------------------------
 388
 389    --  Parsed by P_Type_Declaration (3.2.1)
 390
 391 end Ch7;